From bdf9a71ab7baa2b1de9abcfd5df1a9107a55d141 Mon Sep 17 00:00:00 2001 From: Jack Jamison Date: Sun, 5 Jul 2026 01:19:30 -0400 Subject: add a bunch of emacs packages HELP --- .config/emacs/lisp/libs/compat-31.el | 416 +++ .config/emacs/lisp/libs/compat-macs.el | 272 ++ .config/emacs/lisp/libs/compat.el | 93 + .config/emacs/lisp/libs/cond-let.el | 567 ++++ .config/emacs/lisp/libs/cond-let.elc | Bin 0 -> 17761 bytes .config/emacs/lisp/libs/dash.el | 4176 +++++++++++++++++++++++ .config/emacs/lisp/libs/dash.elc | Bin 0 -> 160135 bytes .config/emacs/lisp/libs/elisp-refs.el | 913 +++++ .config/emacs/lisp/libs/elisp-refs.elc | Bin 0 -> 25991 bytes .config/emacs/lisp/libs/f.el | 799 +++++ .config/emacs/lisp/libs/f.elc | Bin 0 -> 24744 bytes .config/emacs/lisp/libs/ht.el | 354 ++ .config/emacs/lisp/libs/ht.elc | Bin 0 -> 14059 bytes .config/emacs/lisp/libs/llama.el | 572 ++++ .config/emacs/lisp/libs/llama.elc | Bin 0 -> 17102 bytes .config/emacs/lisp/libs/s.el | 792 +++++ .config/emacs/lisp/libs/s.elc | Bin 0 -> 28793 bytes .config/emacs/lisp/libs/transient.el | 5497 +++++++++++++++++++++++++++++++ .config/emacs/lisp/libs/transient.elc | Bin 0 -> 224549 bytes .config/emacs/lisp/libs/with-editor.el | 998 ++++++ .config/emacs/lisp/libs/with-editor.elc | Bin 0 -> 36589 bytes 21 files changed, 15449 insertions(+) create mode 100644 .config/emacs/lisp/libs/compat-31.el create mode 100644 .config/emacs/lisp/libs/compat-macs.el create mode 100644 .config/emacs/lisp/libs/compat.el create mode 100644 .config/emacs/lisp/libs/cond-let.el create mode 100644 .config/emacs/lisp/libs/cond-let.elc create mode 100644 .config/emacs/lisp/libs/dash.el create mode 100644 .config/emacs/lisp/libs/dash.elc create mode 100644 .config/emacs/lisp/libs/elisp-refs.el create mode 100644 .config/emacs/lisp/libs/elisp-refs.elc create mode 100644 .config/emacs/lisp/libs/f.el create mode 100644 .config/emacs/lisp/libs/f.elc create mode 100644 .config/emacs/lisp/libs/ht.el create mode 100644 .config/emacs/lisp/libs/ht.elc create mode 100644 .config/emacs/lisp/libs/llama.el create mode 100644 .config/emacs/lisp/libs/llama.elc create mode 100644 .config/emacs/lisp/libs/s.el create mode 100644 .config/emacs/lisp/libs/s.elc create mode 100644 .config/emacs/lisp/libs/transient.el create mode 100644 .config/emacs/lisp/libs/transient.elc create mode 100644 .config/emacs/lisp/libs/with-editor.el create mode 100644 .config/emacs/lisp/libs/with-editor.elc (limited to '.config/emacs/lisp/libs') diff --git a/.config/emacs/lisp/libs/compat-31.el b/.config/emacs/lisp/libs/compat-31.el new file mode 100644 index 0000000..2b61749 --- /dev/null +++ b/.config/emacs/lisp/libs/compat-31.el @@ -0,0 +1,416 @@ +;;; compat-31.el --- Functionality added in Emacs 31 -*- lexical-binding: t; -*- + +;; Copyright (C) 2025-2026 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Functionality added in Emacs 31, needed by older Emacs versions. + +;;; Code: + +(eval-when-compile (load "compat-macs.el" nil t t)) +(compat-require compat-30 "30.1") + +;; TODO Update to 31.1 as soon as the Emacs emacs-31 branch version bumped +(compat-version "31.0.50") + +;;;; Defined in subr.el + +(compat-defun error-type-p (symbol) ;; + "Return non-nil if SYMBOL is a condition type." + (get symbol 'error-conditions)) + +(compat-defun error-has-type-p (error condition) ;; + "Return non-nil if ERROR is of type CONDITION (or a subtype of it)." + (unless (let ((type (car-safe error))) + (and type (symbolp type) (listp (cdr error)) + (error-type-p type))) + (signal 'wrong-type-argument (list error))) + (or (eq condition t) + (memq condition (get (car error) 'error-conditions)))) + +(compat-defalias error-type car ;; + "Return the symbol which represents the type of ERROR. +\n(fn ERROR)") + +(compat-defalias error-slot-value elt ;; + "Access the SLOT of object ERROR. +Slots are specified by position, and slot 0 is the error symbol. +\n(fn ERROR SLOT)") + +(compat-defun ensure-proper-list (object) ;; + "Return OBJECT as a list. +If OBJECT is already a proper list, return OBJECT itself. If it's not a +proper list, return a one-element list containing OBJECT. + +`ensure-list' is usually preferable because that function runs in +constant time, but this one has to traverse the whole of OBJECT." + (declare (side-effect-free error-free)) + (if (proper-list-p object) + object + (list object))) + +(compat-defun set-local (variable value) ;; + "Make VARIABLE buffer local and set it to VALUE." + (set (make-local-variable variable) value)) + +(compat-defun take-while (pred list) ;; + "Return the longest prefix of LIST whose elements satisfy PRED." + (let ((r nil)) + (while (and list (funcall pred (car list))) + (push (car list) r) + (setq list (cdr list))) + (nreverse r))) + +(compat-defun drop-while (pred list) ;; + "Skip initial elements of LIST satisfying PRED and return the rest." + (while (and list (funcall pred (car list))) + (setq list (cdr list))) + list) + +(compat-defun all (pred list) ;; + "Non-nil if PRED is true for all elements in LIST." + (not (drop-while pred list))) + +(compat-defun member-if (pred list) ;; + "Non-nil if PRED is true for at least one element in LIST. +Returns the LIST suffix starting at the first element that satisfies PRED, +or nil if none does." + (drop-while (lambda (x) (not (funcall pred x))) list)) + +(compat-defalias any member-if) ;; + +(compat-defun hash-table-contains-p (key table) ;; + "Return non-nil if TABLE has an element with KEY." + (declare (side-effect-free t)) + (let ((missing '#:missing)) + (not (eq (gethash key table missing) missing)))) + +(compat-defmacro static-when (condition &rest body) ;; + "A conditional compilation macro. +Evaluate CONDITION at macro-expansion time. If it is non-nil, +expand the macro to evaluate all BODY forms sequentially and return +the value of the last one, or nil if there are none." + (declare (indent 1) (debug t)) + (if body + (if (eval condition lexical-binding) + (cons 'progn body) + nil) + (macroexp-warn-and-return (format-message "`static-when' with empty body") + (list 'progn nil nil) '(empty-body static-when) t))) + +(compat-defmacro static-unless (condition &rest body) ;; + "A conditional compilation macro. +Evaluate CONDITION at macro-expansion time. If it is nil, +expand the macro to evaluate all BODY forms sequentially and return +the value of the last one, or nil if there are none." + (declare (indent 1) (debug t)) + (if body + (if (eval condition lexical-binding) + nil + (cons 'progn body)) + (macroexp-warn-and-return (format-message "`static-unless' with empty body") + (list 'progn nil nil) '(empty-body static-unless) t))) + +(compat-defun oddp (integer) ;; + "Return t if INTEGER is odd." + (not (eq (% integer 2) 0))) + +(compat-defun evenp (integer) ;; + "Return t if INTEGER is even." + (eq (% integer 2) 0)) + +(compat-defun plusp (number) ;; + "Return t if NUMBER is positive." + (> number 0)) + +(compat-defun minusp (number) ;; + "Return t if NUMBER is negative." + (< number 0)) + +(compat-defmacro incf (place &optional delta) ;; + "Increment PLACE by DELTA (default to 1). + +The DELTA is first added to PLACE, and then stored in PLACE. +Return the incremented value of PLACE. + +See also `decf'." + (gv-letplace (getter setter) place + (funcall setter `(+ ,getter ,(or delta 1))))) + +(compat-defmacro decf (place &optional delta) ;; + "Decrement PLACE by DELTA (default to 1). + +The DELTA is first subtracted from PLACE, and then stored in PLACE. +Return the decremented value of PLACE. + +See also `incf'." + (gv-letplace (getter setter) place + (funcall setter `(- ,getter ,(or delta 1))))) + +;;;; Defined in color.el + +(compat-defun color-blend (a b &optional alpha) ;; + "Blend the two colors A and B in linear space with ALPHA. +A and B should be lists (RED GREEN BLUE), where each element is +between 0.0 and 1.0, inclusive. ALPHA controls the influence A +has on the result and should be between 0.0 and 1.0, inclusive. + +For instance: + + (color-blend \\='(1 0.5 1) \\='(0 0 0) 0.75) + => (0.75 0.375 0.75)" + (setq alpha (or alpha 0.5)) + (let (blend) + (dotimes (i 3) + (push (+ (* (nth i a) alpha) (* (nth i b) (- 1 alpha))) blend)) + (nreverse blend))) + +;;;; Defined in time-date.el + +(compat-defvar seconds-to-string ;; + (list (list 1 "ms" 0.001) + (list 100 "s" 1) + (list (* 60 100) "m" 60.0) + (list (* 3600 30) "h" 3600.0) + (list (* 3600 24 400) "d" (* 3600.0 24.0)) + (list nil "y" (* 365.25 24 3600))) + "Formatting used by the function `seconds-to-string'.") + +(compat-defvar seconds-to-string-readable ;; + `(("Y" "year" "years" ,(round (* 60 60 24 365.2425))) + ("M" "month" "months" ,(round (* 60 60 24 30.436875))) + ("w" "week" "weeks" ,(* 60 60 24 7)) + ("d" "day" "days" ,(* 60 60 24)) + ("h" "hour" "hours" ,(* 60 60)) + ("m" "minute" "minutes" 60) + ("s" "second" "seconds" 1)) + "Formatting used by the function `seconds-to-string' with READABLE set. +The format is an alist, with string keys ABBREV-UNIT, and elements like: + + (ABBREV-UNIT UNIT UNIT-PLURAL SECS) + +where UNIT is a unit of time, ABBREV-UNIT is the abbreviated form of +UNIT, UNIT-PLURAL is the plural form of UNIT, and SECS is the number of +seconds per UNIT.") + +(compat-defun seconds-to-string (delay &optional readable abbrev precision) ;; + "Handle optional arguments READABLE, ABBREV and PRECISION." + :extended t + (cond + ((< delay 0) + (concat "-" (seconds-to-string (- delay) readable precision))) + (readable + (let* ((stsa seconds-to-string-readable) + (expanded (eq readable 'expanded)) + digits + (round-to (cond + ((wholenump precision) + (setq digits precision) + (expt 10 (- precision))) + ((and (floatp precision) (< precision 1.)) + (setq digits (- (floor (log precision 10)))) + precision) + (t (setq digits 0) 1))) + (dformat (if (> digits 0) (format "%%0.%df" digits))) + (padding (if abbrev "" " ")) + here cnt cnt-pre here-pre cnt-val isfloatp) + (if (= (round delay round-to) 0) + (format "0%s" (if abbrev "s" " seconds")) + (while (and (setq here (pop stsa)) stsa + (< (/ delay (nth 3 here)) 1))) + (or (and + expanded stsa ; smaller unit remains + (progn + (setq + here-pre here here (car stsa) + cnt-pre (floor (/ (float delay) (nth 3 here-pre))) + cnt (round + (/ (- (float delay) (* cnt-pre (nth 3 here-pre))) + (nth 3 here)) + round-to)) + (if (> cnt 0) t (setq cnt cnt-pre here here-pre here-pre nil)))) + (setq cnt (round (/ (float delay) (nth 3 here)) round-to))) + (setq cnt-val (* cnt round-to) + isfloatp (and (> digits 0) + (> (- cnt-val (floor cnt-val)) 0.))) + (cl-labels + ((unit (val here &optional plural) + (cond (abbrev (car here)) + ((and (not plural) (<= (floor val) 1)) (nth 1 here)) + (t (nth 2 here))))) + (concat + (when here-pre + (concat (number-to-string cnt-pre) padding + (unit cnt-pre here-pre) " ")) + (if isfloatp (format dformat cnt-val) + (number-to-string (floor cnt-val))) + padding + (unit cnt-val here isfloatp)))))) ; float formats are always plural + ((= 0 delay) "0s") + (t (let ((sts seconds-to-string) here) + (while (and (car (setq here (pop sts))) + (<= (car here) delay))) + (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here)))))) + +;;;; Defined in minibuffer.el + +(compat-defun completion-list-candidate-at-point (&optional pt) ;; + "Candidate string and bounds at PT in completions buffer. +The return value has the format (STR BEG END). +The optional argument PT defaults to (point)." + (let ((pt (or pt (point))) beg end) + (cond + ((and (/= pt (point-max)) (get-text-property pt 'mouse-face)) + (setq end pt beg (1+ pt))) + ((and (/= pt (point-min)) (get-text-property (1- pt) 'mouse-face)) + (setq end (1- pt) beg pt))) + (when (and beg end) + (setq beg (previous-single-property-change beg 'mouse-face)) + (setq end (or (next-single-property-change end 'mouse-face) (point-max))) + (list (or (get-text-property beg 'completion--string) + (buffer-substring beg end)) + beg end)))) + +(compat-defun completion-table-with-metadata (table metadata) ;; + "Return new completion TABLE with METADATA. +METADATA should be an alist of completion metadata. See +`completion-metadata' for a list of supported metadata." + (lambda (string pred action) + (if (eq action 'metadata) + `(metadata . ,metadata) + (complete-with-action action table string pred)))) + +;;;; Defined in subr-x.el + +(compat-defun add-remove--display-text-property (start end spec value &optional object remove) ;; + "Helper function for `add-display-text-property' and `remove-display-text-property'." + (let ((sub-start start) + (sub-end 0) + (limit (if (stringp object) + (min (length object) end) + (min end (point-max)))) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + limit)) + (if (not (setq disp (get-text-property sub-start 'display object))) + (unless remove + (put-text-property sub-start sub-end 'display (list spec value) + object)) + (let ((changed nil) + type) + (setq disp + (cond + ((vectorp disp) + (setq type 'vector) + (seq-into disp 'list)) + ((or (not (consp (car-safe disp))) + (eq (caar disp) 'margin)) + (setq type 'scalar) + (list disp)) + (t + (setq type 'list) + disp))) + (when-let* ((old (assoc spec disp))) + (setq disp (if (eq type 'list) + (remove old disp) + (delete old disp)) + changed t)) + (unless remove + (setq disp (cons (list spec value) disp) + changed t)) + (when changed + (if (not disp) + (remove-text-properties sub-start sub-end '(display nil) object) + (when (eq type 'vector) + (setq disp (seq-into disp 'vector))) + (put-text-property sub-start sub-end 'display disp object))))) + (setq sub-start sub-end)))) + +(compat-defun remove-display-text-property (start end spec &optional object) ;; + "Remove the display specification SPEC from the text from START to END. +SPEC is the car of the display specification to remove, e.g. `height'. +If any text in the region has other display specifications, those specs +are retained. + +OBJECT is either a string or a buffer to remove the specification from. +If omitted, OBJECT defaults to the current buffer." + (add-remove--display-text-property start end spec nil object 'remove)) + +(compat-defvar work-buffer-limit 10 ;; + "Maximum number of reusable work buffers. +When this limit is exceeded, newly allocated work buffers are +automatically killed, which means that in a such case +`with-work-buffer' becomes equivalent to `with-temp-buffer'.") + +;; On Emacs 29 and newer `kill-all-local-variables' has a KILL-PERMANENT argument. +(static-if (< emacs-major-version 29) nil + (compat-defvar work-buffer--list nil ;; + "List of work buffers.") + + (compat-defun work-buffer--get () ;; + "Get a work buffer." + (let ((buffer (pop work-buffer--list))) + (if (buffer-live-p buffer) + buffer + (generate-new-buffer " *work*" t)))) + + (compat-defun work-buffer--release (buffer) ;; + "Release work BUFFER." + (if (buffer-live-p buffer) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (delete-all-overlays)) + (let (change-major-mode-hook) + (setq buffer-read-only nil) + (kill-all-local-variables t)) + (push buffer work-buffer--list))) + (when (> (length work-buffer--list) work-buffer-limit) + (mapc #'kill-buffer (nthcdr work-buffer-limit work-buffer--list)) + (setq work-buffer--list (ntake work-buffer-limit work-buffer--list))))) + +(compat-defmacro with-work-buffer (&rest body) ;; + "Create a work buffer, and evaluate BODY there like `progn'. +Like `with-temp-buffer', but reuse an already created temporary buffer +when possible, instead of creating a new one on each call. Avoid +retaining state referring to a work buffer, and kill any indirect +buffers you create that use a work buffer as a base." + (declare (indent 0) (debug t)) + (static-if (< emacs-major-version 29) + `(with-temp-buffer ,@body) + (let ((work-buffer (make-symbol "work-buffer"))) + `(let ((,work-buffer (work-buffer--get))) + (with-current-buffer ,work-buffer + (unwind-protect + (progn ,@body) + (work-buffer--release ,work-buffer))))))) + +;;;; Defined in button.el + +(compat-defun unbuttonize-region (start end) ;; + "Remove all the buttons between START and END. +This removes both text-property and overlay based buttons." + (dolist (o (overlays-in start end)) + (when (overlay-get o 'button) + (delete-overlay o))) + (with-silent-modifications + (remove-text-properties start end (button--properties nil nil nil)) + (add-face-text-property start end 'button nil))) + +(provide 'compat-31) +;;; compat-31.el ends here diff --git a/.config/emacs/lisp/libs/compat-macs.el b/.config/emacs/lisp/libs/compat-macs.el new file mode 100644 index 0000000..b3206f7 --- /dev/null +++ b/.config/emacs/lisp/libs/compat-macs.el @@ -0,0 +1,272 @@ +;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*- + +;; Copyright (C) 2021-2026 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; WARNING: This file provides *internal* macros. The macros are used +;; by Compat to facilitate the definition of compatibility functions, +;; compatibility macros and compatibility variables. The +;; `compat-macs' feature should never be loaded at runtime in your +;; Emacs and will only be used during byte compilation. Every +;; definition provided here is internal, may change any time between +;; Compat releases and must not be used by other packages. + +;;; Code: + +;; We always require subr-x at compile time for the fboundp check +;; since definitions have been moved around. The cl-lib macros are +;; needed by compatibility definitions. +(require 'subr-x) +(require 'cl-lib) + +(defvar compat-macs--version nil + "Version of the currently defined compatibility definitions.") + +(defun compat-macs--strict (cond &rest error) + "Assert strict COND, otherwise fail with ERROR." + (when (bound-and-true-p compat-strict) + (apply #'compat-macs--assert cond error))) + +(defun compat-macs--assert (cond &rest error) + "Assert COND, otherwise fail with ERROR." + (unless cond (apply #'error error))) + +(defun compat-macs--docstring (type name docstring) + "Format DOCSTRING for NAME of TYPE. +Prepend compatibility notice to the actual documentation string." + (with-temp-buffer + (insert + (format + "[Compatibility %s for `%s', defined in Emacs %s. \ +See (compat) Emacs %s' for more details.]\n\n%s" + type name compat-macs--version compat-macs--version docstring)) + (let ((fill-column 80)) + (fill-region (point-min) (point-max))) + (buffer-string))) + +(defun compat-macs--check-attributes (attrs preds) + "Check ATTRS given PREDS predicate plist and return rest." + (while (keywordp (car attrs)) + (compat-macs--assert (cdr attrs) "Attribute list length is odd") + (compat-macs--assert (let ((p (plist-get preds (car attrs)))) + (and p (or (eq p t) (funcall p (cadr attrs))))) + "Invalid attribute %s" (car attrs)) + (setq attrs (cddr attrs))) + attrs) + +(defun compat-macs--guard (attrs preds fun) + "Guard compatibility definition generation. +The version constraints specified by ATTRS are checked. PREDS is +a plist of predicates for arguments which are passed to FUN." + (declare (indent 2)) + (compat-macs--assert compat-macs--version "No `compat-version' was declared") + (let* ((body (compat-macs--check-attributes + attrs `(,@preds :feature symbolp))) + (feature (plist-get attrs :feature)) + (attrs `(:body ,body ,@attrs)) + args) + ;; Require feature at compile time + (when feature + (compat-macs--assert (not (eq feature 'subr-x)) "Invalid feature subr-x") + (require feature)) + ;; The current Emacs must be older than the currently declared version. + (when (version< emacs-version compat-macs--version) + (while preds + (push (plist-get attrs (car preds)) args) + (setq preds (cddr preds))) + (setq body (apply fun (nreverse args))) + (if (and feature body) + `(with-eval-after-load ',feature ,@body) + (macroexp-progn body))))) + +(defun compat-macs--defun (type name arglist docstring rest) + "Define function NAME of TYPE with ARGLIST and DOCSTRING. +REST are attributes and the function BODY." + (compat-macs--guard + rest (list :extended (lambda (x) (or (booleanp x) (version-to-list x))) + :obsolete (lambda (x) (or (booleanp x) (stringp x))) + :body t) + (lambda (extended obsolete body) + (when (stringp extended) + (compat-macs--assert + (and (version< extended compat-macs--version) (version< "25.1" extended)) + "Invalid :extended version %s for %s %s" extended type name) + (setq extended (version<= extended emacs-version))) + (compat-macs--strict (eq extended (fboundp name)) + "Wrong :extended flag for %s %s" type name) + ;; Remove unsupported declares. It might be possible to set these + ;; properties otherwise. That should be looked into and implemented + ;; if it is the case. + (when (and (listp (car-safe body)) (eq (caar body) 'declare) (<= emacs-major-version 25)) + (setcar body (assq-delete-all 'pure (assq-delete-all + 'side-effect-free (car body))))) + ;; Use `:extended' name if the function is already defined. + (let* ((defname (if (and extended (fboundp name)) + (intern (format "compat--%s" name)) + name)) + (def `(,(if (memq '&key arglist) + (if (eq type 'macro) 'cl-defmacro 'cl-defun) + (if (eq type 'macro) 'defmacro 'defun)) + ,defname ,arglist + ,(compat-macs--docstring type name docstring) + ,@body))) + `(,@(if (eq defname name) + ;; An additional fboundp check is performed at runtime to make + ;; sure that we never redefine an existing definition if Compat + ;; is loaded on a newer Emacs version. Declare the function, + ;; such that the byte compiler does not complain about possibly + ;; missing functions at runtime. The warnings are generated due + ;; to the fboundp check. + `((declare-function ,name nil) + (unless (fboundp ',name) ,def)) + (list def)) + ,@(when obsolete + `((make-obsolete + ',defname ,(if (stringp obsolete) obsolete "No substitute") + ,compat-macs--version)))))))) + +(defmacro compat-guard (cond &rest rest) + "Guard definition with a runtime COND and a version check. +The runtime condition must make sure that no definition is +overridden. REST is an attribute plist followed by the definition +body. The attributes specify the conditions under which the +definition is generated. + +- :feature :: Wrap the definition with `with-eval-after-load' for + the given feature." + (declare (debug ([&rest keywordp sexp] def-body)) + (indent 1)) + (compat-macs--guard rest '(:body t) + (lambda (body) + (compat-macs--assert body "The guarded body is empty") + (if (eq cond t) + body + (compat-macs--strict (eval cond t) "Guard %S failed" cond) + `((when ,cond ,@body)))))) + +(defmacro compat-defalias (name def &rest attrs) + "Define compatibility alias NAME as DEF. +ATTRS is a plist of attributes, which specify the conditions +under which the definition is generated. + +- :obsolete :: Mark the alias as obsolete if t. + +- :feature :: See `compat-guard'." + (declare (debug (name symbolp [&rest keywordp sexp]))) + (compat-macs--guard attrs '(:obsolete booleanp) + (lambda (obsolete) + (compat-macs--strict (not (fboundp name)) "%s already defined" name) + ;; The fboundp check is performed at runtime to make sure that we never + ;; redefine an existing definition if Compat is loaded on a newer Emacs + ;; version. + `((unless (fboundp ',name) + (defalias ',name ',def + ,(compat-macs--docstring 'function name + (get name 'function-documentation))) + ,@(when obsolete + `((make-obsolete ',name ',def ,compat-macs--version)))))))) + +(defmacro compat-defun (name arglist docstring &rest rest) + "Define compatibility function NAME with arguments ARGLIST. +The function must be documented in DOCSTRING. REST is an +attribute plist followed by the function body. The attributes +specify the conditions under which the definition is generated. + +- :extended :: Mark the function as extended if t. The function + must be called explicitly via `compat-call'. This attribute + should be used for functions which extend already existing + functions, e.g., functions which changed their calling + convention or their behavior. The value can also be a version + string, which specifies the Emacs version when the original + version of the function was introduced. + +- :obsolete :: Mark the function as obsolete if t, can be a + string describing the obsoletion. + +- :feature :: See `compat-guard'." + (declare (debug (&define name (&rest symbolp) + stringp + [&rest keywordp sexp] + def-body)) + (doc-string 3) (indent 2)) + (compat-macs--defun 'function name arglist docstring rest)) + +(defmacro compat-defmacro (name arglist docstring &rest rest) + "Define compatibility macro NAME with arguments ARGLIST. +The macro must be documented in DOCSTRING. REST is an attribute +plist followed by the macro body. See `compat-defun' for +details." + (declare (debug compat-defun) (doc-string 3) (indent 2)) + (compat-macs--defun 'macro name arglist docstring rest)) + +(defmacro compat-defvar (name initval docstring &rest attrs) + "Define compatibility variable NAME with initial value INITVAL. +The variable must be documented in DOCSTRING. ATTRS is a plist +of attributes, which specify the conditions under which the +definition is generated. + +- :constant :: Mark the variable as constant if t. + +- :risky :: Mark the variable as risky if t. + +- :local :: Make the variable buffer-local if t. If the value is + `permanent' make the variable additionally permanently local. + +- :obsolete :: Mark the variable as obsolete if t, can be a + string describing the obsoletion. + +- :feature :: See `compat-guard'." + (declare (debug (name form stringp [&rest keywordp sexp])) + (doc-string 3) (indent 2)) + (compat-macs--guard + attrs (list :constant #'booleanp + :risky #'booleanp + :local (lambda (x) (memq x '(nil t permanent))) + :obsolete (lambda (x) (or (booleanp x) (stringp x)))) + (lambda (constant risky local obsolete) + (compat-macs--strict (not (boundp name)) "%s already defined" name) + (compat-macs--assert (not (and constant local)) "Both :constant and :local") + (compat-macs--assert (not (and local risky)) "Both :risky and :local") + ;; The boundp check is performed at runtime to make sure that we never + ;; redefine an existing definition if Compat is loaded on a newer Emacs + ;; version. + `((defvar ,name) + (unless (boundp ',name) + (,(if constant 'defconst 'defvar) + ,name ,initval + ,(compat-macs--docstring 'variable name docstring)) + ,@(when obsolete + `((make-obsolete-variable + ',name ,(if (stringp obsolete) obsolete "No substitute") + ,compat-macs--version)))) + ,@(and local `((make-variable-buffer-local ',name))) + ,@(and risky `((put ',name 'risky-local-variable t))) + ,@(and (eq local 'permanent) `((put ',name 'permanent-local t))))))) + +(defmacro compat-version (version) + "Set the Emacs version that is currently being handled to VERSION." + (setq compat-macs--version version) + nil) + +(defmacro compat-require (feature version) + "Require FEATURE if the Emacs version is less than VERSION." + (when (version< emacs-version version) + (require feature) + `(require ',feature))) + +(provide 'compat-macs) +;;; compat-macs.el ends here diff --git a/.config/emacs/lisp/libs/compat.el b/.config/emacs/lisp/libs/compat.el new file mode 100644 index 0000000..deec131 --- /dev/null +++ b/.config/emacs/lisp/libs/compat.el @@ -0,0 +1,93 @@ +;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2026 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic , Daniel Mendler +;; Maintainer: Philip Kaludercic , Daniel Mendler +;; Version: 31.0.0.1 +;; URL: https://github.com/emacs-compat/compat +;; Package-Requires: ((emacs "25.1")) +;; Keywords: lisp, maint + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Compat is the Elisp forwards compatibility library, which provides +;; definitions introduced in newer Emacs versions. The definitions +;; are only installed if necessary for your current Emacs version. If +;; Compat is compiled on a recent version of Emacs, all of the +;; definitions are disabled at compile time, such that no negative +;; performance impact is incurred. The provided compatibility +;; implementations of functions and macros are at least subsets of the +;; actual implementations. Be sure to read the documentation string +;; and the Compat manual. +;; +;; Not every function provided in newer versions of Emacs is provided +;; here. Some depend on new features from the C core, others cannot +;; be implemented to a meaningful degree. Please consult the Compat +;; manual for details regarding the usage of the Compat library and +;; the provided functionality. + +;; The main audience for this library are not regular users, but +;; package maintainers. Therefore no commands, user-facing modes or +;; user options are implemented here. + +;;; Code: + +;; Ensure that the newest compatibility layer is required at compile +;; time and runtime, but only if needed. +(eval-when-compile + (defmacro compat--maybe-require () + (when (< emacs-major-version 31) + (require 'compat-31) + '(require 'compat-31)))) +(compat--maybe-require) + +;;;; Macros for extended compatibility function calls + +(defmacro compat-function (fun) + "Return compatibility function symbol for FUN. + +If the Emacs version provides a sufficiently recent version of +FUN, the symbol FUN is returned itself. Otherwise the macro +returns the symbol of a compatibility function which supports the +behavior and calling convention of the current stable Emacs +version. For example Compat 29.1 will provide compatibility +functions which implement the behavior and calling convention of +Emacs 29.1. + +See also `compat-call' to directly call compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `#',(if (fboundp compat) compat fun))) + +(defmacro compat-call (fun &rest args) + "Call compatibility function or macro FUN with ARGS. + +A good example function is `plist-get' which was extended with an +additional predicate argument in Emacs 29.1. The compatibility +function, which supports this additional argument, can be +obtained via (compat-function plist-get) and called +via (compat-call plist-get plist prop predicate). It is not +possible to directly call (plist-get plist prop predicate) on +Emacs older than 29.1, since the original `plist-get' function +does not yet support the predicate argument. Note that the +Compat library never overrides existing functions. + +See also `compat-function' to lookup compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `(,(if (fboundp compat) compat fun) ,@args))) + +(provide 'compat) +;;; compat.el ends here diff --git a/.config/emacs/lisp/libs/cond-let.el b/.config/emacs/lisp/libs/cond-let.el new file mode 100644 index 0000000..825705c --- /dev/null +++ b/.config/emacs/lisp/libs/cond-let.el @@ -0,0 +1,567 @@ +;;; cond-let.el --- Additional and improved binding conditionals -*- lexical-binding:t -*- + +;; Copyright (C) 2025-2026 Jonas Bernoulli + +;; May contain traces of Emacs, which is +;; Copyright (C) 1985-2025 Free Software Foundation, Inc. + +;; Author: Jonas Bernoulli +;; Homepage: https://github.com/tarsius/cond-let +;; Keywords: extensions + +;; Package-Version: 1.1.2 +;; Package-Requires: ((emacs "28.1")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; Emacs provides the binding conditionals `if-let', `if-let*', +;; `when-let', `when-let*', `and-let*' and `while-let'. + +;; This package implements the missing `and-let' and `while-let*'; +;; and the original `cond-let', `cond-let*', `when$', `and$' and +;; `thread$'. + +;; This package additionally provides more consistent and improved +;; implementations of the binding conditionals already provided by +;; Emacs. Merely loading this library does not shadow the built-in +;; implementations; this can optionally be done in the context of +;; an individual library, as described below. + +;; `cond-let' and `cond-let*' are provided exactly under these names. +;; The names of all other macros implemented by this package begin +;; with `cond-let--', the package's prefix for private symbol. + +;; Users of this package are not expected to use these unwieldy +;; names. Instead one should use Emacs' shorthand feature to use +;; all or some of these macros by their conceptual names. E.g., if +;; you want to use all of the available macros, add this at the end +;; of a library. + +;; Local Variables: +;; read-symbol-shorthands: ( +;; ("and$" . "cond-let--and$") +;; ("thread$" . "cond-let--thread$") +;; ("when$" . "cond-let--when$") +;; ("and-let*" . "cond-let--and-let*") +;; ("and-let" . "cond-let--and-let") +;; ("if-let*" . "cond-let--if-let*") +;; ("if-let" . "cond-let--if-let") +;; ("when-let*" . "cond-let--when-let*") +;; ("when-let" . "cond-let--when-let") +;; ("while-let*" . "cond-let--while-let*") +;; ("while-let" . "cond-let--while-let")) +;; End: + +;; You can think of these file-local settings as import statements of +;; sorts. If you do this, then this package's implementations shadow +;; the built-in implementations. Doing so does not affect any other +;; libraries, which continue to use the built-in implementations. + +;; Due to limitations of the shorthand implementation this has to be +;; done for each individual library. "dir-locals.el" cannot be used. + +;; If you use `when$', `and$' and `thread$', you might want to add +;; this to your configuration: + +;; (with-eval-after-load 'cond-let +;; (font-lock-add-keywords 'emacs-lisp-mode +;; cond-let-font-lock-keywords t)) + +;; For information about the individual macros, please refer to their +;; docstrings. + +;; See also https://github.com/tarsius/cond-let/wiki. + +;;; Code: +;;; Cond + +(defun cond-let--prepare-clauses (tag sequential clauses) + "Used by macros `cond-let*' and `cond-let'." + (let (body) + (dolist (clause (nreverse clauses)) + (cond + ((vectorp clause) + (setq body + `((,(if (and sequential (length> clause 1)) 'let* 'let) + ,(mapcar (lambda (vec) (append vec nil)) clause) + ,@body)))) + ((let (varlist) + (while (vectorp (car clause)) + (push (append (pop clause) nil) varlist)) + (push (cond + (varlist + `(,(pcase (list (and body t) + (and sequential (length> varlist 1))) + ('(t t ) 'cond-let--when-let*) + (`(t ,_) 'cond-let--when-let) + ('(nil t ) 'cond-let--and-let*) + (`(nil ,_) 'cond-let--and-let)) + ,(nreverse varlist) + ,(if body + `(throw ',tag ,(macroexp-progn clause)) + (macroexp-progn clause)))) + ((length= clause 1) + (if body + (let ((a (gensym "anon"))) + `(let ((,a ,(car clause))) + (when ,a (throw ',tag ,a)))) + (car clause))) + ((and (eq (car clause) t) (not body)) + (macroexp-progn (cdr clause))) + (t + `(when ,(pop clause) + (throw ',tag ,(macroexp-progn clause))))) + body))))) + body)) + +(defmacro cond-let* (&rest clauses) + "Try each clause until one succeeds. + +Each clause has one of these forms: +- a plain clause (CONDITION BODY...) +- a binding clause ([SYMBOL VALUEFORM]... BODY...) +- a binding vector [[SYMBOL VALUEFORM]...] + +A (CONDITION BODY...) clause works as for `cond'. Evaluate CONDITION, +and if it yields non-nil, the clause succeeds. Then evaluate BODY forms +sequentially and return the value of the last; or if there are no BODY +forms, return the value of CONDITION. If CONDITION yields nil, do not +evaluate the BODY forms and instead proceed to the next clause. + +A ([SYMBOL VALUEFORM]... BODY...) clause begins with one or more binding +vectors, followed by one or more BODY forms. Bind SYMBOL to the value +of VALUEFORM. Each VALUEFORM can refer to symbols already bound by this +VARLIST (as for `let*'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and return the value of the last form. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and proceed to the next clause. + +A [[SYMBOL VALUEFORM]...] form creates bindings, which extend to all +remaining clauses and binding vectors. Unlike for the previous form, +always bind all SYMBOLs, even if a VALUEFORM yields nil. Always proceed +to the next clause." + (declare (indent 0) + (debug (&rest [&or + (vector &rest (vector symbolp form)) + ([&rest (vector symbolp form)] body) + (form body)]))) + (let ((tag (gensym ":cond-let*"))) + `(catch ',tag + ,@(cond-let--prepare-clauses tag t clauses)))) + +(defmacro cond-let (&rest clauses) + "Try each clause until one succeeds. + +Each clause has one of these forms: +- a plain clause (CONDITION BODY...) +- a binding clause ([SYMBOL VALUEFORM]... BODY...) +- a binding vector [[SYMBOL VALUEFORM]...] + +A (CONDITION BODY...) clause works as for `cond'. Evaluate CONDITION, +and if it yields non-nil, the clause succeeds. Then evaluate BODY forms +sequentially and return the value of the last; or if there are no BODY +forms, return the value of CONDITION. If CONDITION yields nil, do not +evaluate the BODY forms and instead proceed to the next clause. + +A ([SYMBOL VALUEFORM]... BODY...) clause begins with one or more binding +vectors, followed by one or more BODY forms. Bind SYMBOL to the value +of VALUEFORM. Evaluate all VALUEFORMs before binding their respective +SYMBOLs (as for `let'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and return the value of the last form. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and proceed to the next clause. + +A [[SYMBOL VALUEFORM]...] form creates bindings, which extend to all +remaining clauses and binding vectors. Evaluate all VALUEFORMs before +binding their respective SYMBOLs. Unlike for the previous form, bind +all SYMBOLs, even if a VALUEFORM yields nil. Always proceed to the +next clause." + (declare (indent 0) + (debug cond-let*)) + (let ((tag (gensym ":cond-let"))) + `(catch ',tag + ,@(cond-let--prepare-clauses tag nil clauses)))) + +;;; Common + +(defun cond-let--prepare-varlist (varlist) + "Used by Cond-Let's `when-let*', `and-let*' and `while-let*'. +Also used by other macros via `cond-let--prepare-varforms'. +Return (VARLIST LASTVAR)." + (let (prevvar) + (list (mapcar (lambda (binding) + (unless (length= binding 2) + (signal 'error (cons "Invalid binding" binding))) + (pcase-let ((`(,var ,form) binding)) + (when (string-prefix-p "_" (symbol-name var)) + (setq var (gensym "anon"))) + (prog1 (if prevvar + `(,var (and ,prevvar ,form)) + (list var form)) + (setq prevvar var)))) + varlist) + prevvar))) + +(defun cond-let--prepare-varforms (varlist &optional if-let) + "Used by Cond-Let's `when-let', `and-let', `while-let' and `if-let'. +Return (ANON-VARLIST ANON-SETQ VARLIST LASTVAR), or if the length of +VARLIST is 1 and IF-LET is nil, return (nil nil VARLIST LASTVAR)." + (if (and (not if-let) + (length= varlist 1)) + `(nil nil ,@(cond-let--prepare-varlist varlist)) + (let ((triples + (mapcar (lambda (binding) + (unless (length= binding 2) + (signal 'error (cons "Invalid binding" binding))) + (pcase-let ((`(,var ,form) binding)) + (when (string-prefix-p "_" (symbol-name var)) + (setq var nil)) + (list (and var (gensym "anon")) + var + form))) + varlist))) + (list (mapcan (pcase-lambda (`(,anon ,_ ,_)) + (and anon (list anon))) + triples) + (mapcar (pcase-lambda (`(,anon ,_ ,form)) + (if anon + `(setq ,anon ,form) + form)) + triples) + (mapcan (pcase-lambda (`(,anon ,var ,_)) + (and var `((,var ,anon)))) + triples) + (cadr (car (last triples))))))) + +;;; And + +(defmacro cond-let--and-let* (varlist &optional bodyform) + "Bind according to VARLIST until one yields nil, else evaluate BODYFORM. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Each VALUEFORM can refer to symbols already +bound by this VARLIST (as for `let*'). + +Evaluate VALUEFORMs until on of them yields nil. If that happens return +nil, and evaluate neither the remaining VALUEFORMs nor BODYFORM. If all +VALUEFORMs yield non-nil, evaluate BODYFORM with the bindings in effect, +and return its value; or if there is no BODYFORM, the value of the last +VALUEFORM." + (declare (indent 1) + (debug ((&rest (symbolp form)) form))) + (pcase-let ((`(,varlist ,lastvar) + (cond-let--prepare-varlist varlist))) + `(let* ,varlist + ,(if bodyform + `(and ,lastvar ,bodyform) + lastvar)))) + +(defmacro cond-let--and-let (varlist &optional bodyform) + "Bind according to VARLIST until one yields nil, else evaluate BODYFORM. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Evaluate all VALUEFORMs before binding their +respective SYMBOLs (as for `let'). + +Evaluate VALUEFORMs until on of them yields nil. If that happens return +nil, and evaluate neither the remaining VALUEFORMs nor BODYFORM. If all +VALUEFORMs yield non-nil, evaluate BODYFORM with the bindings in effect, +and return its value; or if there is no BODYFORM, the value of the last +VALUEFORM." + (declare (indent 1) + (debug cond-let--and-let*)) + (pcase-let ((`(,anon ,set ,bind ,lastvar) + (cond-let--prepare-varforms varlist))) + (cond (anon + `(let ,anon + (and ,@set + (let ,bind + ,(or bodyform lastvar))))) + (t + `(let ,bind + ,(if bodyform + `(and ,lastvar ,bodyform) + lastvar)))))) + +;;; Thread + +(defmacro cond-let--and$ (form form2 &rest forms) + "Bind variables according to each FORM until one of them yields nil. + +Evaluate the first FORM and if that yields a non-nil value, bind the +symbol `$' to that value, and evaluate the next FORM with that binding +in effect. Repeat this process with subsequent FORMs until one yields +nil, then return nil without evaluate the remaining FORMs. If all +FORMs yield non-nil, return the value of the last FORM. + +\(fn FORM FORM...)" + (declare (indent 0) + (debug t)) + `(,(if forms 'let* 'let) + (($ ,form) + ,@(and forms + (mapcar (lambda (form) + `($ (and $ ,form))) + (cons form2 (butlast forms))))) + (and $ + ,(or (car (last forms)) + form2)))) + +(defmacro cond-let--thread$ (form form2 &rest forms) + "Bind variable `$' to value of nth FORM before evaluating nth+1 FORM. + +Evaluate the first FORM and bind the symbol `$' to its value. +Then evaluate the next FORM with that binding in effect. Repeat this +process with subsequent FORMs, and return the value of the last FORM. + +\(fn FORM FORM...)" + (declare (indent 0) + (debug t)) + `(,(if forms 'let* 'let) + (($ ,form) + ,@(and forms + (mapcar (lambda (form) + `($ ,form)) + (cons form2 (butlast forms))))) + ,(or (car (last forms)) + form2))) + +;;; If + +(defmacro cond-let--if-let* (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Each VALUEFORM can refer to symbols already +bound by this VARLIST (as for `let*'). + +If all VALUEFORMs yield non-nil, evaluate THEN with VARLIST's bindings +in effect, and return its value. THEN must be one expression. + +If any VALUEFORM yields nil, evaluate ELSE sequentially and return the +value of the last form; or if there are no ELSE forms return nil. The +bindings from VARLIST do _not_ extend to the ELSE forms. + +\(fn VARLIST THEN [ELSE...])" + (declare (indent 2) + (debug ((&rest (symbolp form)) form body))) + (pcase-let ((`(,varlist ,lastvar) + (cond-let--prepare-varlist varlist)) + (tag (gensym ":if-let*"))) + `(catch ',tag + (let* ,varlist + (when ,lastvar + (throw ',tag ,then))) + ,@else))) + +(defmacro cond-let--if-let (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Evaluate all VALUEFORMs before binding their +respective SYMBOLs (as for `let'). + +If all VALUEFORMs yield non-nil, evaluate THEN with VARLIST's bindings +in effect, and return its value. THEN must be one expression. + +If any VALUEFORM yields nil, evaluate ELSE sequentially and return the +value of the last form; or if there are no ELSE forms return nil. The +bindings from VARLIST do _not_ extend to the ELSE forms. + +\(fn VARLIST THEN [ELSE...])" + (declare (indent 2) + (debug cond-let--if-let*)) + (pcase-let* ((`(,anon ,set ,bind ,_) + (cond-let--prepare-varforms varlist t)) + (set (if (length= set 1) (car set) (cons 'and set)))) + `(let ,anon + (if ,set + (let ,bind + ,then) + ,@else)))) + +;;; When + +(defmacro cond-let--when-let* (varlist bodyform &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Each VALUEFORM can refer to symbols already +bound by this VARLIST (as for `let*'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and return the value of the last form. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and instead return nil. + +BODY must be one or more expressions. If VARLIST is empty, do nothing +and return nil. + +\(fn VARLIST BODY...)" + (declare (indent 1) + (debug ((&rest (symbolp form)) form body))) + (pcase-let ((`(,varlist ,lastvar) + (cond-let--prepare-varlist varlist))) + `(let* ,varlist + (when ,lastvar + ,bodyform ,@body)))) + +(defmacro cond-let--when-let (varlist bodyform &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Evaluate all VALUEFORMs before binding their +respective SYMBOLs (as for `let'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and return the value of the last form. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and instead return nil. + +BODY must be one or more expressions. If VARLIST is empty, do nothing +and return nil. + +\(fn VARLIST BODY...)" + (declare (indent 1) + (debug cond-let--when-let*)) + (pcase-let ((`(,anon ,set ,bind ,lastvar) + (cond-let--prepare-varforms varlist))) + (cond (anon + `(let ,anon + (when (and ,@set) + (let ,bind + ,bodyform ,@body)))) + (t + `(let ,bind + (when ,lastvar + ,bodyform ,@body)))))) + +(defmacro cond-let--when$ (varform bodyform &rest body) + "Bind variable `$' to value of VARFORM and conditionally evaluate BODY. + +If VARFORM yields a non-nil value, bind the symbol `$' to that value, +evaluate BODY with that binding in effect, and return the value of the +last form. If VARFORM yields nil, do not evaluate BODY, and return nil. +BODY must be one or more expressions. If VARLIST is empty, do nothing +and return nil. + +\(fn VARFORM BODY...)" + (declare (indent 1) + (debug t)) + `(let (($ ,varform)) + (when $ + ,bodyform ,@body))) + +;;; While + +(defmacro cond-let--while-let* (varlist &rest body) + "Bind variables according to VARLIST, conditionally evaluate BODY, and repeat. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Each VALUEFORM can refer to symbols already +bound by this VARLIST (as for `let*'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and repeat the loop. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and instead return, always yielding nil. + +BODY can be zero or more expressions. + +\(fn VARLIST [BODY...])" + (declare (indent 1) + (debug ((&rest (symbolp form)) body))) + (pcase-let ((`(,varlist ,lastvar) + (cond-let--prepare-varlist varlist)) + (tag (gensym ":while-let*"))) + `(catch ',tag + (while t + (let* ,varlist + (if ,lastvar + ,(macroexp-progn body) + (throw ',tag nil))))))) + +(defmacro cond-let--while-let (varlist bodyform &rest body) + "Bind variables according to VARLIST, conditionally evaluate BODY, and repeat. + +Each element of VARLIST is a list (SYMBOL VALUEFORM), which binds SYMBOL +to the value of VALUEFORM. Evaluate all VALUEFORMs before binding their +respective SYMBOLs (as for `let'). + +If all VALUEFORMs yield non-nil, evaluate BODY forms sequentially, with +VARLIST's bindings in effect, and repeat the loop. + +If any VALUEFORM yields nil, evaluate neither the remaining VALUEFORMs +nor the BODY forms, and instead return, always yielding nil. + +BODY can be one or more expressions. + +\(fn VARLIST BODY...)" + (declare (indent 1) + (debug ((&rest (symbolp form)) form body))) + (pcase-let ((`(,anon ,set ,bind ,lastvar) + (cond-let--prepare-varforms varlist)) + (tag (gensym ":while-let"))) + (cond (anon + `(catch ',tag + (while t + (let ,anon + (if (and ,@set) + (let ,bind + ,bodyform ,@body) + (throw ',tag nil)))))) + (t + `(catch ',tag + (while t + (let ,bind + (if ,lastvar + ,(macroexp-progn (cons bodyform body)) + (throw ',tag nil))))))))) + +;;; Font-Lock + +(defvar cond-let-font-lock-keywords + '(("\\_<\\$\\_>" 0 'font-lock-variable-name-face)) + "Highlight `$' using `font-lock-variable-name-face'. +To add these keywords, add this to your configuration: +\(font-lock-add-keywords \\='emacs-lisp-mode cond-let-font-lock-keywords t)") + +;;; Compatibility + +(defalias 'cond-let--and> #'cond-let--and$ + "Instead of this alias, use `cond-let--and$' via `and$' shorthand. + +This alias will likely be declared obsolete in 2027. If you would like +to continue to use it, please get in contact before then. This alias +might eventually be removed altogether; again subject to user feedback. + +If you do not care about the symbol `cond-let--and>', but want to keep +using the respective `and>' shorthand, you can future-proof that now, +by changing the shorthand definition to (\"and>\" . \"cond-let--and$\").") + +(provide 'cond-let) +;;; cond-let.el ends here diff --git a/.config/emacs/lisp/libs/cond-let.elc b/.config/emacs/lisp/libs/cond-let.elc new file mode 100644 index 0000000..bb18a18 Binary files /dev/null and b/.config/emacs/lisp/libs/cond-let.elc differ diff --git a/.config/emacs/lisp/libs/dash.el b/.config/emacs/lisp/libs/dash.el new file mode 100644 index 0000000..41d1e53 --- /dev/null +++ b/.config/emacs/lisp/libs/dash.el @@ -0,0 +1,4176 @@ +;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2026 Free Software Foundation, Inc. + +;; Author: Magnar Sveen +;; Maintainer: Basil L. Contovounesios +;; Version: 2.20.0 +;; Package-Requires: ((emacs "24")) +;; Keywords: extensions, lisp +;; URL: https://github.com/magnars/dash.el + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; A modern list API for Emacs. +;; +;; Dash is a utility library that affords functional programming +;; patterns inspired by Clojure, particularly in the realm of list +;; manipulation. Examples include higher-order functions (map, reduce, +;; filter) and derivatives (drop, flatten, sum); function combinators +;; (partial application, argument flipping, composition); and threading +;; and anaphoric macros with destructuring support. +;; +;; Dash is particularly useful in providing a broad and consistent API +;; across many Emacs versions. +;; +;; Documentation and examples are in the manual at Info node `(dash) Top' +;; and on the web at https://elpa.gnu.org/packages/doc/dash.html, as well +;; as in the project’s README.md file. + +;;; Code: + +(eval-when-compile + (unless (fboundp 'static-if) + (defmacro static-if (condition then-form &rest else-forms) + "Expand to THEN-FORM or ELSE-FORMS based on compile-time CONDITION. +Polyfill for Emacs 30 `static-if'." + (declare (debug (sexp sexp &rest sexp)) (indent 2)) + (if (eval condition lexical-binding) + then-form + (cons 'progn else-forms)))) + + ;; TODO: Emacs 24.3 first introduced `gv', so remove this and all + ;; calls to `defsetf' when support for earlier versions is dropped. + (unless (fboundp 'gv-define-setter) + (require 'cl)) + + ;; - 24.3 started complaining about unknown `declare' props. + ;; - 25 introduced `pure' and `side-effect-free'. + ;; - 30 introduced `important-return-value'. + (when (boundp 'defun-declarations-alist) + (dolist (prop '(important-return-value pure side-effect-free)) + (unless (assq prop defun-declarations-alist) + (push (list prop #'ignore) defun-declarations-alist))))) + +(defgroup dash () + "Customize group for Dash, a modern list library." + :group 'extensions + :group 'lisp + :prefix "dash-") + +(defmacro !cons (car cdr) + "Destructive: Set CDR to the cons of CAR and CDR." + (declare (debug (form symbolp))) + `(setq ,cdr (cons ,car ,cdr))) + +(defmacro !cdr (list) + "Destructive: Set LIST to the cdr of LIST." + (declare (debug (symbolp))) + `(setq ,list (cdr ,list))) + +(defmacro --each (list &rest body) + "Evaluate BODY for each element of LIST and return nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating BODY. +This is the anaphoric counterpart to `-each'." + (declare (debug (form body)) (indent 1)) + (let ((l (make-symbol "list")) + (i (make-symbol "i"))) + `(let ((,l ,list) + (,i 0)) + (while ,l + (let ((it (pop ,l)) (it-index ,i)) + (ignore it it-index) + ,@body) + (setq ,i (1+ ,i)))))) + +(defun -each (list fn) + "Call FN on each element of LIST. +Return nil; this function is intended for side effects. + +Its anaphoric counterpart is `--each'. + +For access to the current element's index in LIST, see +`-each-indexed'." + (declare (indent 1)) + (ignore (mapc fn list))) + +(defalias '--each-indexed '--each) + +(defun -each-indexed (list fn) + "Call FN on each index and element of LIST. +For each ITEM at INDEX in LIST, call (funcall FN INDEX ITEM). +Return nil; this function is intended for side effects. + +See also: `-map-indexed'." + (declare (indent 1)) + (--each list (funcall fn it-index it))) + +(defmacro --each-while (list pred &rest body) + "Evaluate BODY for each item in LIST, while PRED evaluates to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating PRED or BODY. Once +an element is reached for which PRED evaluates to nil, no further +BODY is evaluated. The return value is always nil. +This is the anaphoric counterpart to `-each-while'." + (declare (debug (form form body)) (indent 2)) + (let ((l (make-symbol "list")) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) + `(let ((,l ,list) + (,i 0) + ,elt) + (while (when ,l + (setq ,elt (car-safe ,l)) + (let ((it ,elt) (it-index ,i)) + (ignore it it-index) + ,pred)) + (let ((it ,elt) (it-index ,i)) + (ignore it it-index) + ,@body) + (setq ,i (1+ ,i) ,l (cdr ,l)))))) + +(defun -each-while (list pred fn) + "Call FN on each ITEM in LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. + +Its anaphoric counterpart is `--each-while'." + (declare (indent 2)) + (--each-while list (funcall pred it) (funcall fn it))) + +(defmacro --each-r (list &rest body) + "Evaluate BODY for each element of LIST in reversed order. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +BODY. The return value is always nil. +This is the anaphoric counterpart to `-each-r'." + (declare (debug (form body)) (indent 1)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i"))) + ;; Implementation note: building a vector is considerably faster + ;; than building a reversed list (vector takes less memory, so + ;; there is less GC), plus `length' comes naturally. In-place + ;; `nreverse' would be faster still, but BODY would be able to see + ;; that, even if the modification was undone before we return. + `(let* ((,v (vconcat ,list)) + (,i (length ,v)) + it it-index) + (ignore it it-index) + (while (> ,i 0) + (setq ,i (1- ,i) it-index ,i it (aref ,v ,i)) + ,@body)))) + +(defun -each-r (list fn) + "Call FN on each element of LIST in reversed order. +Return nil; this function is intended for side effects. + +Its anaphoric counterpart is `--each-r'." + (--each-r list (funcall fn it))) + +(defmacro --each-r-while (list pred &rest body) + "Eval BODY for each item in reversed LIST, while PRED evals to non-nil. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +PRED or BODY. Once an element is reached for which PRED +evaluates to nil, no further BODY is evaluated. The return value +is always nil. +This is the anaphoric counterpart to `-each-r-while'." + (declare (debug (form form body)) (indent 2)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) + `(let* ((,v (vconcat ,list)) + (,i (length ,v)) + ,elt it it-index) + (ignore it it-index) + (while (when (> ,i 0) + (setq ,i (1- ,i) it-index ,i) + (setq ,elt (aref ,v ,i) it ,elt) + ,pred) + (setq it-index ,i it ,elt) + ,@body)))) + +(defun -each-r-while (list pred fn) + "Call FN on each ITEM in reversed LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. + +Its anaphoric counterpart is `--each-r-while'." + (--each-r-while list (funcall pred it) (funcall fn it))) + +(defmacro --dotimes (num &rest body) + "Evaluate BODY NUM times, presumably for side effects. +BODY is evaluated with the local variable `it' temporarily bound +to successive integers running from 0, inclusive, to NUM, +exclusive. BODY is not evaluated if NUM is less than 1. +This is the anaphoric counterpart to `-dotimes'." + (declare (debug (form body)) (indent 1)) + (let ((n (make-symbol "num")) + (i (make-symbol "i"))) + `(let ((,n ,num) + (,i 0) + it) + (ignore it) + (while (< ,i ,n) + (setq it ,i ,i (1+ ,i)) + ,@body)))) + +(defun -dotimes (num fn) + "Call FN NUM times, presumably for side effects. +FN is called with a single argument on successive integers +running from 0, inclusive, to NUM, exclusive. FN is not called +if NUM is less than 1. + +This function's anaphoric counterpart is `--dotimes'." + (declare (indent 1)) + (--dotimes num (funcall fn it))) + +(defun -map (fn list) + "Apply FN to each item in LIST and return the list of results. + +This function's anaphoric counterpart is `--map'." + (declare (important-return-value t)) + (mapcar fn list)) + +(defmacro --map (form list) + "Eval FORM for each item in LIST and return the list of results. +Each element of LIST in turn is bound to `it' before evaluating +FORM. +This is the anaphoric counterpart to `-map'." + (declare (debug (def-form form))) + `(mapcar (lambda (it) (ignore it) ,form) ,list)) + +(defmacro --reduce-from (form init list) + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--each' (which see), but it additionally +provides an accumulator variable `acc' which it successively +binds to the result of evaluating FORM for the current LIST +element before processing the next element. For the first +element, `acc' is initialized with the result of evaluating INIT. +The return value is the resulting value of `acc'. If LIST is +empty, FORM is not evaluated, and the return value is the result +of INIT. +This is the anaphoric counterpart to `-reduce-from'." + (declare (debug (form form form))) + `(let ((acc ,init)) + (--each ,list (setq acc ,form)) + acc)) + +(defun -reduce-from (fn init list) + "Reduce the function FN across LIST, starting with INIT. +Return the result of applying FN to INIT and the first element of +LIST, then applying FN to that result and the second element, +etc. If LIST is empty, return INIT without calling FN. + +This function's anaphoric counterpart is `--reduce-from'. + +For other folds, see also `-reduce' and `-reduce-r'." + (declare (important-return-value t)) + (--reduce-from (funcall fn acc it) init list)) + +(defmacro --reduce (form list) + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--reduce-from' (which see), except the first +element of LIST is taken as INIT. Thus if LIST contains a single +item, it is returned without evaluating FORM. If LIST is empty, +FORM is evaluated with `it' and `acc' bound to nil. +This is the anaphoric counterpart to `-reduce'." + (declare (debug (form form))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv ,list)) + (if ,lv + (--reduce-from ,form (car ,lv) (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + ,form))))) + +(defun -reduce (fn list) + "Reduce the function FN across LIST. +Return the result of applying FN to the first two elements of +LIST, then applying FN to that result and the third element, etc. +If LIST contains a single element, return it without calling FN. +If LIST is empty, return the result of calling FN with no +arguments. + +This function's anaphoric counterpart is `--reduce'. + +For other folds, see also `-reduce-from' and `-reduce-r'." + (declare (important-return-value t)) + (if list + (-reduce-from fn (car list) (cdr list)) + (funcall fn))) + +(defmacro --reduce-r-from (form init list) + "Accumulate a value by evaluating FORM across LIST in reverse. +This macro is like `--reduce-from', except it starts from the end +of LIST. +This is the anaphoric counterpart to `-reduce-r-from'." + (declare (debug (form form form))) + `(let ((acc ,init)) + (--each-r ,list (setq acc ,form)) + acc)) + +(defun -reduce-r-from (fn init list) + "Reduce the function FN across LIST in reverse, starting with INIT. +Return the result of applying FN to the last element of LIST and +INIT, then applying FN to the second-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST is empty, return INIT without calling FN. + +This function is like `-reduce-from' but the operation associates +from the right rather than left. In other words, it starts from +the end of LIST and flips the arguments to FN. Conceptually, it +is like replacing the conses in LIST with applications of FN, and +its last link with INIT, and evaluating the resulting expression. + +This function's anaphoric counterpart is `--reduce-r-from'. + +For other folds, see also `-reduce-r' and `-reduce'." + (declare (important-return-value t)) + (--reduce-r-from (funcall fn it acc) init list)) + +(defmacro --reduce-r (form list) + "Accumulate a value by evaluating FORM across LIST in reverse order. +This macro is like `--reduce', except it starts from the end of +LIST. +This is the anaphoric counterpart to `-reduce-r'." + (declare (debug (form form))) + `(--reduce ,form (reverse ,list))) + +(defun -reduce-r (fn list) + "Reduce the function FN across LIST in reverse. +Return the result of applying FN to the last two elements of +LIST, then applying FN to the third-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST contains a single element, return it without +calling FN. If LIST is empty, return the result of calling FN +with no arguments. + +This function is like `-reduce' but the operation associates from +the right rather than left. In other words, it starts from the +end of LIST and flips the arguments to FN. Conceptually, it is +like replacing the conses in LIST with applications of FN, +ignoring its last link, and evaluating the resulting expression. + +This function's anaphoric counterpart is `--reduce-r'. + +For other folds, see also `-reduce-r-from' and `-reduce'." + (declare (important-return-value t)) + (if list + (--reduce-r (funcall fn it acc) list) + (funcall fn))) + +(defmacro --reductions-from (form init list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-from'." + (declare (debug (form form form))) + `(nreverse + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list))) + +(defun -reductions-from (fn init list) + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-from' (which see) is called with the same +arguments. + +This function's anaphoric counterpart is `--reductions-from'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (--reductions-from (funcall fn acc it) init list)) + +(defmacro --reductions (form list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions'." + (declare (debug (form form))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv ,list)) + (if ,lv + (--reductions-from ,form (car ,lv) (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + (list ,form)))))) + +(defun -reductions (fn list) + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce' (which see) is called with the same arguments. + +This function's anaphoric counterpart is `--reductions'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (if list + (--reductions-from (funcall fn acc it) (car list) (cdr list)) + (list (funcall fn)))) + +(defmacro --reductions-r-from (form init list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-r-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-r-from'." + (declare (debug (form form form))) + `(--reduce-r-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list)) + +(defun -reductions-r-from (fn init list) + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r-from' (which see) is called with the same +arguments. + +This function's anaphoric counterpart is `--reductions-r-from'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (--reductions-r-from (funcall fn it acc) init list)) + +(defmacro --reductions-r (form list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-re' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions-r'." + (declare (debug (form list))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv (reverse ,list))) + (if ,lv + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list (car ,lv)) + (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + (list ,form)))))) + +(defun -reductions-r (fn list) + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r' (which see) is called with the same arguments. + +This function's anaphoric counterpart is `--reductions-r'. + +For other folds, see also `-reductions-r-from' and +`-reductions'." + (declare (important-return-value t)) + (if list + (--reductions-r (funcall fn it acc) list) + (list (funcall fn)))) + +(defmacro --filter (form list) + "Return a new list of the items in LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-filter'. +For the opposite operation, see also `--remove'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list (when ,form (push it ,r))) + (nreverse ,r)))) + +(defun -filter (pred list) + "Return a new list of the items in LIST for which PRED returns non-nil. + +Alias: `-select'. + +This function's anaphoric counterpart is `--filter'. + +For similar operations, see also `-keep' and `-remove'." + (declare (important-return-value t)) + (--filter (funcall pred it) list)) + +(defalias '-select '-filter) +(defalias '--select '--filter) + +(defmacro --remove (form list) + "Return a new list of the items in LIST for which FORM evals to nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-remove'. +For the opposite operation, see also `--filter'." + (declare (debug (form form))) + `(--filter (not ,form) ,list)) + +(defun -remove (pred list) + "Return a new list of the items in LIST for which PRED returns nil. + +Alias: `-reject'. + +This function's anaphoric counterpart is `--remove'. + +For similar operations, see also `-keep' and `-filter'." + (declare (important-return-value t)) + (--remove (funcall pred it) list)) + +(defalias '-reject '-remove) +(defalias '--reject '--remove) + +(defmacro --remove-first (form list) + "Remove the first item from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. This is a +non-destructive operation, but only the front of LIST leading up +to the removed item is a copy; the rest is LIST's original tail. +If no item is removed, then the result is a complete copy. +This is the anaphoric counterpart to `-remove-first'." + (declare (debug (form form))) + (let ((front (make-symbol "front")) + (tail (make-symbol "tail"))) + `(let ((,tail ,list) ,front) + (--each-while ,tail (not ,form) + (push (pop ,tail) ,front)) + (if ,tail + (nconc (nreverse ,front) (cdr ,tail)) + (nreverse ,front))))) + +(defun -remove-first (pred list) + "Remove the first item from LIST for which PRED returns non-nil. +This is a non-destructive operation, but only the front of LIST +leading up to the removed item is a copy; the rest is LIST's +original tail. If no item is removed, then the result is a +complete copy. + +Alias: `-reject-first'. + +This function's anaphoric counterpart is `--remove-first'. + +See also `-map-first', `-remove-item', and `-remove-last'." + (declare (important-return-value t)) + (--remove-first (funcall pred it) list)) + +;; TODO: #'-quoting the macro upsets Emacs 24. +(defalias '-reject-first #'-remove-first) +(defalias '--reject-first '--remove-first) + +(defmacro --remove-last (form list) + "Remove the last item from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' before evaluating +FORM. The result is a copy of LIST regardless of whether an +element is removed. +This is the anaphoric counterpart to `-remove-last'." + (declare (debug (form form))) + `(nreverse (--remove-first ,form (reverse ,list)))) + +(defun -remove-last (pred list) + "Remove the last item from LIST for which PRED returns non-nil. +The result is a copy of LIST regardless of whether an element is +removed. + +Alias: `-reject-last'. + +This function's anaphoric counterpart is `--remove-last'. + +See also `-map-last', `-remove-item', and `-remove-first'." + (declare (important-return-value t)) + (--remove-last (funcall pred it) list)) + +(defalias '-reject-last '-remove-last) +(defalias '--reject-last '--remove-last) + +(defalias '-remove-item #'remove + "Return a copy of LIST with all occurrences of ITEM removed. +The comparison is done with `equal'. +\n(fn ITEM LIST)") + +(defmacro --keep (form list) + "Eval FORM for each item in LIST and return the non-nil results. +Like `--filter', but returns the non-nil results of FORM instead +of the corresponding elements of LIST. Each element of LIST in +turn is bound to `it' and its index within LIST to `it-index' +before evaluating FORM. +This is the anaphoric counterpart to `-keep'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (m (make-symbol "mapped"))) + `(let (,r) + (--each ,list (let ((,m ,form)) (when ,m (push ,m ,r)))) + (nreverse ,r)))) + +(defun -keep (fn list) + "Return a new list of the non-nil results of applying FN to each item in LIST. +Like `-filter', but returns the non-nil results of FN instead of +the corresponding elements of LIST. + +Its anaphoric counterpart is `--keep'." + (declare (important-return-value t)) + (--keep (funcall fn it) list)) + +(defun -non-nil (list) + "Return a copy of LIST with all nil items removed." + (declare (side-effect-free t)) + (--filter it list)) + +(defmacro --map-indexed (form list) + "Eval FORM for each item in LIST and return the list of results. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. This is like +`--map', but additionally makes `it-index' available to FORM. + +This is the anaphoric counterpart to `-map-indexed'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list + (push ,form ,r)) + (nreverse ,r)))) + +(defun -map-indexed (fn list) + "Apply FN to each index and item in LIST and return the list of results. +This is like `-map', but FN takes two arguments: the index of the +current element within LIST, and the element itself. + +This function's anaphoric counterpart is `--map-indexed'. + +For a side-effecting variant, see also `-each-indexed'." + (declare (important-return-value t)) + (--map-indexed (funcall fn it-index it) list)) + +(defmacro --map-when (pred rep list) + "Anaphoric form of `-map-when'." + (declare (debug (form form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list (!cons (if ,pred ,rep it) ,r)) + (nreverse ,r)))) + +(defun -map-when (pred rep list) + "Use PRED to conditionally apply REP to each item in LIST. +Return a copy of LIST where the items for which PRED returns nil +are unchanged, and the rest are mapped through the REP function. + +Alias: `-replace-where' + +See also: `-update-at'" + (declare (important-return-value t)) + (--map-when (funcall pred it) (funcall rep it) list)) + +(defalias '-replace-where '-map-when) +(defalias '--replace-where '--map-when) + +(defun -map-first (pred rep list) + "Use PRED to determine the first item in LIST to call REP on. +Return a copy of LIST where the first item for which PRED returns +non-nil is replaced with the result of calling REP on that item. + +See also: `-map-when', `-replace-first'" + (declare (important-return-value t)) + (let (front) + (while (and list (not (funcall pred (car list)))) + (push (car list) front) + (!cdr list)) + (if list + (-concat (nreverse front) (cons (funcall rep (car list)) (cdr list))) + (nreverse front)))) + +(defmacro --map-first (pred rep list) + "Anaphoric form of `-map-first'." + (declare (debug (def-form def-form form))) + `(-map-first (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,rep) + ,list)) + +(defun -map-last (pred rep list) + "Use PRED to determine the last item in LIST to call REP on. +Return a copy of LIST where the last item for which PRED returns +non-nil is replaced with the result of calling REP on that item. + +See also: `-map-when', `-replace-last'" + (declare (important-return-value t)) + (nreverse (-map-first pred rep (reverse list)))) + +(defmacro --map-last (pred rep list) + "Anaphoric form of `-map-last'." + (declare (debug (def-form def-form form))) + `(-map-last (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,rep) + ,list)) + +(defun -replace (old new list) + "Replace all OLD items in LIST with NEW. + +Elements are compared using `equal'. + +See also: `-replace-at'" + (declare (pure t) (side-effect-free t)) + (--map-when (equal it old) new list)) + +(defun -replace-first (old new list) + "Replace the first occurrence of OLD with NEW in LIST. + +Elements are compared using `equal'. + +See also: `-map-first'" + (declare (pure t) (side-effect-free t)) + (--map-first (equal old it) new list)) + +(defun -replace-last (old new list) + "Replace the last occurrence of OLD with NEW in LIST. + +Elements are compared using `equal'. + +See also: `-map-last'" + (declare (pure t) (side-effect-free t)) + (--map-last (equal old it) new list)) + +(defmacro --mapcat (form list) + "Anaphoric form of `-mapcat'." + (declare (debug (form form))) + `(apply #'append (--map ,form ,list))) + +(defun -mapcat (fn list) + "Return the concatenation of the result of mapping FN over LIST. +Thus function FN should return a list." + (declare (important-return-value t)) + (--mapcat (funcall fn it) list)) + +(defmacro --iterate (form init n) + "Anaphoric version of `-iterate'." + (declare (debug (form form form))) + (let ((res (make-symbol "result")) + (len (make-symbol "n"))) + `(let ((,len ,n)) + (when (> ,len 0) + (let* ((it ,init) + (,res (list it))) + (dotimes (_ (1- ,len)) + (push (setq it ,form) ,res)) + (nreverse ,res)))))) + +(defun -iterate (fun init n) + "Return a list of iterated applications of FUN to INIT. + +This means a list of the form: + + (INIT (FUN INIT) (FUN (FUN INIT)) ...) + +N is the length of the returned list." + (declare (important-return-value t)) + (--iterate (funcall fun it) init n)) + +(defun -flatten (l) + "Take a nested list L and return its contents as a single, flat list. + +Note that because nil represents a list of zero elements (an +empty list), any mention of nil in L will disappear after +flattening. If you need to preserve nils, consider `-flatten-n' +or map them to some unique symbol and then map them back. + +Conses of two atoms are considered \"terminals\", that is, they +aren't flattened further. + +See also: `-flatten-n'" + (declare (pure t) (side-effect-free t)) + (if (and (listp l) (listp (cdr l))) + (-mapcat '-flatten l) + (list l))) + +(defun -flatten-n (num list) + "Flatten NUM levels of a nested LIST. + +See also: `-flatten'" + (declare (pure t) (side-effect-free t)) + (dotimes (_ num) + (setq list (apply #'append (mapcar #'-list list)))) + list) + +(defalias '-concat #'append + "Concatenate all SEQUENCES and make the result a list. +The result is a list whose elements are the elements of all the arguments. +Each argument may be a list, vector or string. + +All arguments except the last argument are copied. The last argument +is just used as the tail of the new list. If the last argument is not +a list, this results in a dotted list. + +As an exception, if all the arguments except the last are nil, and the +last argument is not a list, the return value is that last argument +unaltered, not a list. + +\(fn &rest SEQUENCES)") + +(defalias '-copy #'copy-sequence + "Create a shallow copy of LIST. +The elements of LIST are not copied; they are shared with the original. +\n(fn LIST)") + +(defmacro --splice (pred form list) + "Splice lists generated by FORM in place of items satisfying PRED in LIST. + +Evaluate PRED for each element of LIST in turn bound to `it'. +Whenever the result of PRED is nil, leave that `it' is-is. +Otherwise, evaluate FORM with the same `it' binding still in +place. The result should be a (possibly empty) list of items to +splice in place of `it' in LIST. + +This can be useful as an alternative to the `,@' construct in a +`\\=`' structure, in case you need to splice several lists at +marked positions (for example with keywords). + +This is the anaphoric counterpart to `-splice'." + (declare (debug (form form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list + (if ,pred + (--each ,form (push it ,r)) + (push it ,r))) + (nreverse ,r)))) + +(defun -splice (pred fun list) + "Splice lists generated by FUN in place of items satisfying PRED in LIST. + +Call PRED on each element of LIST. Whenever the result of PRED +is nil, leave that `it' as-is. Otherwise, call FUN on the same +`it' that satisfied PRED. The result should be a (possibly +empty) list of items to splice in place of `it' in LIST. + +This can be useful as an alternative to the `,@' construct in a +`\\=`' structure, in case you need to splice several lists at +marked positions (for example with keywords). + +This function's anaphoric counterpart is `--splice'. + +See also: `-splice-list', `-insert-at'." + (declare (important-return-value t)) + (--splice (funcall pred it) (funcall fun it) list)) + +(defun -splice-list (pred new-list list) + "Splice NEW-LIST in place of elements matching PRED in LIST. + +See also: `-splice', `-insert-at'" + (declare (important-return-value t)) + (-splice pred (lambda (_) new-list) list)) + +(defmacro --splice-list (pred new-list list) + "Anaphoric form of `-splice-list'." + (declare (debug (def-form form form))) + `(-splice-list (lambda (it) (ignore it) ,pred) ,new-list ,list)) + +(defun -cons* (&rest args) + "Make a new list from the elements of ARGS. +The last 2 elements of ARGS are used as the final cons of the +result, so if the final element of ARGS is not a list, the result +is a dotted list. With no ARGS, return nil." + (declare (side-effect-free t)) + (let* ((len (length args)) + (tail (nthcdr (- len 2) args)) + (last (cdr tail))) + (if (null last) + (car args) + (setcdr tail (car last)) + args))) + +(defun -snoc (list elem &rest elements) + "Append ELEM to the end of the list. + +This is like `cons', but operates on the end of list. + +If any ELEMENTS are given, append them to the list as well." + (declare (side-effect-free t)) + (-concat list (list elem) elements)) + +(defmacro --first (form list) + "Return the first item in LIST for which FORM evals to non-nil. +Return nil if no such element is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-first'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each-while ,list (or (not ,form) + (ignore (setq ,n it)))) + ,n))) + +(defun -first (pred list) + "Return the first item in LIST for which PRED returns non-nil. +Return nil if no such element is found. + +To get the first item in the list no questions asked, +use `-first-item'. + +Alias: `-find'. + +This function's anaphoric counterpart is `--first'." + (declare (important-return-value t)) + (--first (funcall pred it) list)) + +(defalias '-find #'-first) +(defalias '--find '--first) + +(defmacro --some (form list) + "Return non-nil if FORM evals to non-nil for at least one item in LIST. +If so, return the first such result of FORM. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-some'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each-while ,list (not (setq ,n ,form))) + ,n))) + +(defun -some (pred list) + "Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil. + +Alias: `-any'. + +This function's anaphoric counterpart is `--some'." + (declare (important-return-value t)) + (--some (funcall pred it) list)) + +(defalias '-any '-some) +(defalias '--any '--some) + +(defmacro --every (form list) + "Return non-nil if FORM evals to non-nil for all items in LIST. +If so, return the last such result of FORM. Otherwise, once an +item is reached for which FORM yields nil, return nil without +evaluating FORM for any further LIST elements. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. + +This macro is like `--every-p', but on success returns the last +non-nil result of FORM instead of just t. + +This is the anaphoric counterpart to `-every'." + (declare (debug (form form))) + (let ((a (make-symbol "all"))) + `(let ((,a t)) + (--each-while ,list (setq ,a ,form)) + ,a))) + +(defun -every (pred list) + "Return non-nil if PRED returns non-nil for all items in LIST. +If so, return the last such result of PRED. Otherwise, once an +item is reached for which PRED returns nil, return nil without +calling PRED on any further LIST elements. + +This function is like `-every-p', but on success returns the last +non-nil result of PRED instead of just t. + +This function's anaphoric counterpart is `--every'." + (declare (important-return-value t)) + (--every (funcall pred it) list)) + +(defmacro --last (form list) + "Anaphoric form of `-last'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each ,list + (when ,form (setq ,n it))) + ,n))) + +(defun -last (pred list) + "Return the last x in LIST where (PRED x) is non-nil, else nil." + (declare (important-return-value t)) + (--last (funcall pred it) list)) + +(defalias '-first-item #'car + "Return the first item of LIST, or nil on an empty list. + +See also: `-second-item', `-last-item', etc. + +\(fn LIST)") + +;; Ensure that calls to `-first-item' are compiled to a single opcode, +;; just like `car'. +(put '-first-item 'byte-opcode 'byte-car) +(put '-first-item 'byte-compile 'byte-compile-one-arg) +(put '-first-item 'pure t) +(put '-first-item 'side-effect-free t) + +(defalias '-second-item #'cadr + "Return the second item of LIST, or nil if LIST is too short. + +See also: `-first-item', `-third-item', etc. + +\(fn LIST)") + +(put '-second-item 'pure t) +(put '-second-item 'side-effect-free t) + +(defalias '-third-item + (if (fboundp 'caddr) + #'caddr + (lambda (list) (car (cddr list)))) + "Return the third item of LIST, or nil if LIST is too short. + +See also: `-second-item', `-fourth-item', etc. + +\(fn LIST)") + +(put '-third-item 'pure t) +(put '-third-item 'side-effect-free t) + +(defalias '-fourth-item + (if (fboundp 'cadddr) + #'cadddr + (lambda (list) (cadr (cddr list)))) + "Return the fourth item of LIST, or nil if LIST is too short. + +See also: `-third-item', `-fifth-item', etc. + +\(fn LIST)") + +(put '-fourth-item 'pure t) +(put '-fourth-item 'side-effect-free t) + +(defun -fifth-item (list) + "Return the fifth item of LIST, or nil if LIST is too short. + +See also: `-fourth-item', `-last-item', etc." + (declare (pure t) (side-effect-free t)) + (car (cddr (cddr list)))) + +(defun -last-item (list) + "Return the last item of LIST, or nil on an empty list. + +See also: `-first-item', etc." + (declare (pure t) (side-effect-free t)) + (car (last list))) + +(static-if (fboundp 'gv-define-setter) + (gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) + (defsetf -last-item (x) (val) `(setcar (last ,x) ,val))) + +(defun -butlast (list) + "Return a list of all items in list except for the last." + ;; no alias as we don't want magic optional argument + (declare (pure t) (side-effect-free t)) + (butlast list)) + +(defmacro --count (pred list) + "Anaphoric form of `-count'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let ((,r 0)) + (--each ,list (when ,pred (setq ,r (1+ ,r)))) + ,r))) + +(defun -count (pred list) + "Counts the number of items in LIST where (PRED item) is non-nil." + (declare (important-return-value t)) + (--count (funcall pred it) list)) + +(defun ---truthy? (obj) + "Return OBJ as a boolean value (t or nil)." + (declare (pure t) (side-effect-free error-free)) + (and obj t)) + +(defmacro --any? (form list) + "Anaphoric form of `-any?'." + (declare (debug (form form))) + `(and (--some ,form ,list) t)) + +(defun -any? (pred list) + "Return t if (PRED X) is non-nil for any X in LIST, else nil. + +Alias: `-any-p', `-some?', `-some-p'" + (declare (important-return-value t)) + (--any? (funcall pred it) list)) + +(defalias '-some? '-any?) +(defalias '--some? '--any?) +(defalias '-any-p '-any?) +(defalias '--any-p '--any?) +(defalias '-some-p '-any?) +(defalias '--some-p '--any?) + +(defmacro --all? (form list) + "Return t if FORM evals to non-nil for all items in LIST. +Otherwise, once an item is reached for which FORM yields nil, +return nil without evaluating FORM for any further LIST elements. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. + +The similar macro `--every' is more widely useful, since it +returns the last non-nil result of FORM instead of just t on +success. + +Alias: `--all-p', `--every-p', `--every?'. + +This is the anaphoric counterpart to `-all?'." + (declare (debug (form form))) + `(and (--every ,form ,list) t)) + +(defun -all? (pred list) + "Return t if (PRED X) is non-nil for all X in LIST, else nil. +In the latter case, stop after the first X for which (PRED X) is +nil, without calling PRED on any subsequent elements of LIST. + +The similar function `-every' is more widely useful, since it +returns the last non-nil result of PRED instead of just t on +success. + +Alias: `-all-p', `-every-p', `-every?'. + +This function's anaphoric counterpart is `--all?'." + (declare (important-return-value t)) + (--all? (funcall pred it) list)) + +(defalias '-every? '-all?) +(defalias '--every? '--all?) +(defalias '-all-p '-all?) +(defalias '--all-p '--all?) +(defalias '-every-p '-all?) +(defalias '--every-p '--all?) + +(defmacro --none? (form list) + "Anaphoric form of `-none?'." + (declare (debug (form form))) + `(--all? (not ,form) ,list)) + +(defun -none? (pred list) + "Return t if (PRED X) is nil for all X in LIST, else nil. + +Alias: `-none-p'" + (declare (important-return-value t)) + (--none? (funcall pred it) list)) + +(defalias '-none-p '-none?) +(defalias '--none-p '--none?) + +(defmacro --only-some? (form list) + "Anaphoric form of `-only-some?'." + (declare (debug (form form))) + (let ((y (make-symbol "yes")) + (n (make-symbol "no"))) + `(let (,y ,n) + (--each-while ,list (not (and ,y ,n)) + (if ,form (setq ,y t) (setq ,n t))) + (---truthy? (and ,y ,n))))) + +(defun -only-some? (pred list) + "Return t if different LIST items both satisfy and do not satisfy PRED. +That is, if PRED returns both nil for at least one item, and +non-nil for at least one other item in LIST. Return nil if all +items satisfy the predicate or none of them do. + +Alias: `-only-some-p'" + (declare (important-return-value t)) + (--only-some? (funcall pred it) list)) + +(defalias '-only-some-p '-only-some?) +(defalias '--only-some-p '--only-some?) + +(defun -slice (list from &optional to step) + "Return copy of LIST, starting from index FROM to index TO. + +FROM or TO may be negative. These values are then interpreted +modulo the length of the list. + +If STEP is a number, only each STEPth item in the resulting +section is returned. Defaults to 1." + (declare (side-effect-free t)) + (let ((length (length list)) + (new-list nil)) + ;; to defaults to the end of the list + (setq to (or to length)) + (setq step (or step 1)) + ;; handle negative indices + (when (< from 0) + (setq from (mod from length))) + (when (< to 0) + (setq to (mod to length))) + + ;; iterate through the list, keeping the elements we want + (--each-while list (< it-index to) + (when (and (>= it-index from) + (= (mod (- from it-index) step) 0)) + (push it new-list))) + (nreverse new-list))) + +(defmacro --take-while (form list) + "Take successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return a new +list of the successive elements from the start of LIST for which +FORM evaluates to non-nil. +This is the anaphoric counterpart to `-take-while'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each-while ,list ,form (push it ,r)) + (nreverse ,r)))) + +(defun -take-while (pred list) + "Take successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return a new list of the +successive elements from the start of LIST for which PRED returns +non-nil. + +This function's anaphoric counterpart is `--take-while'. + +For another variant, see also `-drop-while'." + (declare (important-return-value t)) + (--take-while (funcall pred it) list)) + +(defmacro --drop-while (form list) + "Drop successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return the +tail (not a copy) of LIST starting from its first element for +which FORM evaluates to nil. +This is the anaphoric counterpart to `-drop-while'." + (declare (debug (form form))) + (let ((l (make-symbol "list"))) + `(let ((,l ,list)) + (--each-while ,l ,form (pop ,l)) + ,l))) + +(defun -drop-while (pred list) + "Drop successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return the tail (not a copy) +of LIST starting from its first element for which PRED returns +nil. + +This function's anaphoric counterpart is `--drop-while'. + +For another variant, see also `-take-while'." + (declare (important-return-value t)) + (--drop-while (funcall pred it) list)) + +;; Added in Emacs 29. +(static-if (fboundp 'take) + (defun dash--take (n list) + "Return the first N elements of LIST. +Like `take', but ensure result is fresh." + (let ((prefix (take n list))) + (if (eq prefix list) + ;; If same list is returned, make a copy. + (copy-sequence prefix) + prefix)))) + +(defun -take (n list) + "Return a copy of the first N items in LIST. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take-last'." + (declare (side-effect-free t)) + (static-if (fboundp 'dash--take) + (dash--take n list) + (--take-while (< it-index n) list))) + +(defun -take-last (n list) + "Return a copy of the last N items of LIST in order. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take'." + (declare (side-effect-free t)) + (copy-sequence (last list n))) + +(defalias '-drop #'nthcdr + "Return the tail (not a copy) of LIST without the first N items. +Return nil if LIST contains N items or fewer. +Return LIST if N is zero or less. + +For another variant, see also `-drop-last'. +\n(fn N LIST)") + +(defun -drop-last (n list) + "Return a copy of LIST without its last N items. +Return a copy of LIST if N is zero or less. +Return nil if LIST contains N items or fewer. + +See also: `-drop'." + (declare (side-effect-free t)) + (static-if (fboundp 'dash--take) + (dash--take (- (length list) n) list) + (nbutlast (copy-sequence list) n))) + +(defun -split-at (n list) + "Split LIST into two sublists after the Nth element. +The result is a list of two elements (TAKE DROP) where TAKE is a +new list of the first N elements of LIST, and DROP is the +remaining elements of LIST (not a copy). TAKE and DROP are like +the results of `-take' and `-drop', respectively, but the split +is done in a single list traversal." + (declare (side-effect-free t)) + (let (result) + (--each-while list (< it-index n) + (push (pop list) result)) + (list (nreverse result) list))) + +(defun -rotate (n list) + "Rotate LIST N places to the right (left if N is negative). +The time complexity is O(n)." + (declare (pure t) (side-effect-free t)) + (cond ((null list) ()) + ((zerop n) (copy-sequence list)) + ((let* ((len (length list)) + (n-mod-len (mod n len)) + (new-tail-len (- len n-mod-len))) + (append (nthcdr new-tail-len list) (-take new-tail-len list)))))) + +(defun -insert-at (n x list) + "Return a list with X inserted into LIST at position N. + +See also: `-splice', `-splice-list'" + (declare (pure t) (side-effect-free t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) (cons x (cadr split-list))))) + +(defun -replace-at (n x list) + "Return a list with element at Nth position in LIST replaced with X. + +See also: `-replace'" + (declare (pure t) (side-effect-free t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) (cons x (cdr (cadr split-list)))))) + +(defun -update-at (n func list) + "Use FUNC to update the Nth element of LIST. +Return a copy of LIST where the Nth element is replaced with the +result of calling FUNC on it. + +See also: `-map-when'" + (declare (important-return-value t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) + (cons (funcall func (car (cadr split-list))) + (cdr (cadr split-list)))))) + +(defmacro --update-at (n form list) + "Anaphoric version of `-update-at'." + (declare (debug (form def-form form))) + `(-update-at ,n (lambda (it) (ignore it) ,form) ,list)) + +(defun -remove-at (n list) + "Return LIST with its element at index N removed. +That is, remove any element selected as (nth N LIST) from LIST +and return the result. + +This is a non-destructive operation: parts of LIST (but not +necessarily all of it) are copied as needed to avoid +destructively modifying it. + +See also: `-remove-at-indices', `-remove'." + (declare (pure t) (side-effect-free t)) + (if (zerop n) + (cdr list) + (--remove-first (= it-index n) list))) + +(defun -remove-at-indices (indices list) + "Return LIST with its elements at INDICES removed. +That is, for each index I in INDICES, remove any element selected +as (nth I LIST) from LIST. + +This is a non-destructive operation: parts of LIST (but not +necessarily all of it) are copied as needed to avoid +destructively modifying it. + +See also: `-remove-at', `-remove'." + (declare (pure t) (side-effect-free t)) + (setq indices (--drop-while (< it 0) (-sort #'< indices))) + (let ((i (pop indices)) res) + (--each-while list i + (pop list) + (if (/= it-index i) + (push it res) + (while (and indices (= (car indices) i)) + (pop indices)) + (setq i (pop indices)))) + (nconc (nreverse res) list))) + +(defmacro --split-with (pred list) + "Anaphoric form of `-split-with'." + (declare (debug (form form))) + (let ((l (make-symbol "list")) + (r (make-symbol "result")) + (c (make-symbol "continue"))) + `(let ((,l ,list) + (,r nil) + (,c t)) + (while (and ,l ,c) + (let ((it (car ,l))) + (if (not ,pred) + (setq ,c nil) + (!cons it ,r) + (!cdr ,l)))) + (list (nreverse ,r) ,l)))) + +(defun -split-with (pred list) + "Split LIST into a prefix satisfying PRED, and the rest. +The first sublist is the prefix of LIST with successive elements +satisfying PRED, and the second sublist is the remaining elements +that do not. The result is like performing + + ((-take-while PRED LIST) (-drop-while PRED LIST)) + +but in no more than a single pass through LIST." + (declare (important-return-value t)) + (--split-with (funcall pred it) list)) + +(defmacro -split-on (item list) + "Split the LIST each time ITEM is found. + +Unlike `-partition-by', the ITEM is discarded from the results. +Empty lists are also removed from the result. + +Comparison is done by `equal'. + +See also `-split-when'" + (declare (debug (def-form form))) + `(-split-when (lambda (it) (equal it ,item)) ,list)) + +(defmacro --split-when (form list) + "Anaphoric version of `-split-when'." + (declare (debug (def-form form))) + `(-split-when (lambda (it) (ignore it) ,form) ,list)) + +(defun -split-when (fn list) + "Split the LIST on each element where FN returns non-nil. + +Unlike `-partition-by', the \"matched\" element is discarded from +the results. Empty lists are also removed from the result. + +This function can be thought of as a generalization of +`split-string'." + (declare (important-return-value t)) + (let (r s) + (while list + (if (not (funcall fn (car list))) + (push (car list) s) + (when s (push (nreverse s) r)) + (setq s nil)) + (!cdr list)) + (when s (push (nreverse s) r)) + (nreverse r))) + +(defmacro --separate (form list) + "Anaphoric form of `-separate'." + (declare (debug (form form))) + (let ((y (make-symbol "yes")) + (n (make-symbol "no"))) + `(let (,y ,n) + (--each ,list (if ,form (!cons it ,y) (!cons it ,n))) + (list (nreverse ,y) (nreverse ,n))))) + +(defun -separate (pred list) + "Split LIST into two sublists based on whether items satisfy PRED. +The result is like performing + + ((-filter PRED LIST) (-remove PRED LIST)) + +but in a single pass through LIST." + (declare (important-return-value t)) + (--separate (funcall pred it) list)) + +(defun dash--partition-all-in-steps-reversed (n step list) + "Like `-partition-all-in-steps', but the result is reversed." + (when (< step 1) + (signal 'wrong-type-argument + `("Step size < 1 results in juicy infinite loops" ,step))) + (let (result) + (while list + (push (-take n list) result) + (setq list (nthcdr step list))) + result)) + +(defun -partition-all-in-steps (n step list) + "Partition LIST into sublists of length N that are STEP items apart. +Adjacent groups may overlap if N exceeds the STEP stride. +Trailing groups may contain less than N items." + (declare (pure t) (side-effect-free t)) + (nreverse (dash--partition-all-in-steps-reversed n step list))) + +(defun -partition-in-steps (n step list) + "Partition LIST into sublists of length N that are STEP items apart. +Like `-partition-all-in-steps', but if there are not enough items +to make the last group N-sized, those items are discarded." + (declare (pure t) (side-effect-free t)) + (let ((result (dash--partition-all-in-steps-reversed n step list))) + (while (and result (< (length (car result)) n)) + (pop result)) + (nreverse result))) + +(defun -partition-all (n list) + "Return a new list with the items in LIST grouped into N-sized sublists. +The last group may contain less than N items." + (declare (pure t) (side-effect-free t)) + (-partition-all-in-steps n n list)) + +(defun -partition (n list) + "Return a new list with the items in LIST grouped into N-sized sublists. +If there are not enough items to make the last group N-sized, +those items are discarded." + (declare (pure t) (side-effect-free t)) + (-partition-in-steps n n list)) + +(defmacro --partition-by (form list) + "Anaphoric form of `-partition-by'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (s (make-symbol "sublist")) + (v (make-symbol "value")) + (n (make-symbol "new-value")) + (l (make-symbol "list"))) + `(let ((,l ,list)) + (when ,l + (let* ((,r nil) + (it (car ,l)) + (,s (list it)) + (,v ,form) + (,l (cdr ,l))) + (while ,l + (let* ((it (car ,l)) + (,n ,form)) + (unless (equal ,v ,n) + (!cons (nreverse ,s) ,r) + (setq ,s nil) + (setq ,v ,n)) + (!cons it ,s) + (!cdr ,l))) + (!cons (nreverse ,s) ,r) + (nreverse ,r)))))) + +(defun -partition-by (fn list) + "Apply FN to each item in LIST, splitting it each time FN returns a new value." + (declare (important-return-value t)) + (--partition-by (funcall fn it) list)) + +(defmacro --partition-by-header (form list) + "Anaphoric form of `-partition-by-header'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (s (make-symbol "sublist")) + (h (make-symbol "header-value")) + (b (make-symbol "seen-body?")) + (n (make-symbol "new-value")) + (l (make-symbol "list"))) + `(let ((,l ,list)) + (when ,l + (let* ((,r nil) + (it (car ,l)) + (,s (list it)) + (,h ,form) + (,b nil) + (,l (cdr ,l))) + (while ,l + (let* ((it (car ,l)) + (,n ,form)) + (if (equal ,h ,n) + (when ,b + (!cons (nreverse ,s) ,r) + (setq ,s nil) + (setq ,b nil)) + (setq ,b t)) + (!cons it ,s) + (!cdr ,l))) + (!cons (nreverse ,s) ,r) + (nreverse ,r)))))) + +(defun -partition-by-header (fn list) + "Apply FN to the first item in LIST. That is the header +value. Apply FN to each item in LIST, splitting it each time FN +returns the header value, but only after seeing at least one +other value (the body)." + (declare (important-return-value t)) + (--partition-by-header (funcall fn it) list)) + +(defmacro --partition-after-pred (form list) + "Partition LIST after each element for which FORM evaluates to non-nil. +Each element of LIST in turn is bound to `it' before evaluating +FORM. + +This is the anaphoric counterpart to `-partition-after-pred'." + (let ((l (make-symbol "list")) + (r (make-symbol "result")) + (s (make-symbol "sublist"))) + `(let ((,l ,list) ,r ,s) + (when ,l + (--each ,l + (push it ,s) + (when ,form + (push (nreverse ,s) ,r) + (setq ,s ()))) + (when ,s + (push (nreverse ,s) ,r)) + (nreverse ,r))))) + +(defun -partition-after-pred (pred list) + "Partition LIST after each element for which PRED returns non-nil. + +This function's anaphoric counterpart is `--partition-after-pred'." + (declare (important-return-value t)) + (--partition-after-pred (funcall pred it) list)) + +(defun -partition-before-pred (pred list) + "Partition directly before each time PRED is true on an element of LIST." + (declare (important-return-value t)) + (nreverse (-map #'reverse + (-partition-after-pred pred (reverse list))))) + +(defun -partition-after-item (item list) + "Partition directly after each time ITEM appears in LIST." + (declare (pure t) (side-effect-free t)) + (-partition-after-pred (lambda (ele) (equal ele item)) + list)) + +(defun -partition-before-item (item list) + "Partition directly before each time ITEM appears in LIST." + (declare (pure t) (side-effect-free t)) + (-partition-before-pred (lambda (ele) (equal ele item)) + list)) + +(defmacro --group-by (form list) + "Anaphoric form of `-group-by'." + (declare (debug t)) + (let ((n (make-symbol "n")) + (k (make-symbol "k")) + (grp (make-symbol "grp"))) + `(nreverse + (-map + (lambda (,n) + (cons (car ,n) + (nreverse (cdr ,n)))) + (--reduce-from + (let* ((,k (,@form)) + (,grp (assoc ,k acc))) + (if ,grp + (setcdr ,grp (cons it (cdr ,grp))) + (push + (list ,k it) + acc)) + acc) + nil ,list))))) + +(defun -group-by (fn list) + "Separate LIST into an alist whose keys are FN applied to the +elements of LIST. Keys are compared by `equal'." + (declare (important-return-value t)) + (--group-by (funcall fn it) list)) + +(defun -interpose (sep list) + "Return a new list of all elements in LIST separated by SEP." + (declare (side-effect-free t)) + (let (result) + (when list + (!cons (car list) result) + (!cdr list)) + (while list + (setq result (cons (car list) (cons sep result))) + (!cdr list)) + (nreverse result))) + +(defun -interleave (&rest lists) + "Return a new list of the first item in each list, then the second etc." + (declare (side-effect-free t)) + (when lists + (let (result) + (while (-none? 'null lists) + (--each lists (!cons (car it) result)) + (setq lists (-map 'cdr lists))) + (nreverse result)))) + +(defmacro --zip-with (form list1 list2) + "Zip LIST1 and LIST2 into a new list according to FORM. +That is, evaluate FORM for each item pair from the two lists, and +return the list of results. The result is as long as the shorter +list. + +Each element of LIST1 and each element of LIST2 in turn are bound +pairwise to `it' and `other', respectively, and their index +within the list to `it-index', before evaluating FORM. + +This is the anaphoric counterpart to `-zip-with'." + (declare (debug (form form form))) + (let ((r (make-symbol "result")) + (l2 (make-symbol "list2"))) + `(let ((,l2 ,list2) ,r) + (--each-while ,list1 ,l2 + (let ((other (pop ,l2))) + (ignore other) + (push ,form ,r))) + (nreverse ,r)))) + +(defun -zip-with (fn list1 list2) + "Zip LIST1 and LIST2 into a new list using the function FN. +That is, apply FN pairwise taking as first argument the next +element of LIST1 and as second argument the next element of LIST2 +at the corresponding position. The result is as long as the +shorter list. + +This function's anaphoric counterpart is `--zip-with'. + +For other zips, see also `-zip-lists' and `-zip-fill'." + (declare (important-return-value t)) + (--zip-with (funcall fn it other) list1 list2)) + +(defun -zip-lists (&rest lists) + "Zip LISTS together. + +Group the head of each list, followed by the second element of +each list, and so on. The number of returned groupings is equal +to the length of the shortest input list, and the length of each +grouping is equal to the number of input LISTS. + +The return value is always a list of proper lists, in contrast to +`-zip' which returns a list of dotted pairs when only two input +LISTS are provided. + +See also: `-zip-pair'." + (declare (pure t) (side-effect-free t)) + (when lists + (let (results) + (while (--every it lists) + (push (mapcar #'car lists) results) + (setq lists (mapcar #'cdr lists))) + (nreverse results)))) + +(defun -zip-lists-fill (fill-value &rest lists) + "Zip LISTS together, padding shorter lists with FILL-VALUE. +This is like `-zip-lists' (which see), except it retains all +elements at positions beyond the end of the shortest list. The +number of returned groupings is equal to the length of the +longest input list, and the length of each grouping is equal to +the number of input LISTS." + (declare (pure t) (side-effect-free t)) + (when lists + (let (results) + (while (--some it lists) + (push (--map (if it (car it) fill-value) lists) results) + (setq lists (mapcar #'cdr lists))) + (nreverse results)))) + +(defun -unzip-lists (lists) + "Unzip LISTS. + +This works just like `-zip-lists' (which see), but takes a list +of lists instead of a variable number of arguments, such that + + (-unzip-lists (-zip-lists ARGS...)) + +is identity (given that the lists comprising ARGS are of the same +length)." + (declare (pure t) (side-effect-free t)) + (apply #'-zip-lists lists)) + +(defalias 'dash--length= + (if (fboundp 'length=) + #'length= + (lambda (list length) + (cond ((< length 0) nil) + ((zerop length) (null list)) + ((let ((last (nthcdr (1- length) list))) + (and last (null (cdr last)))))))) + "Return non-nil if LIST is of LENGTH. +This is a compatibility shim for `length=' in Emacs 28. +\n(fn LIST LENGTH)") + +(defun dash--zip-lists-or-pair (_form &rest lists) + "Return a form equivalent to applying `-zip' to LISTS. +This `compiler-macro' warns about discouraged `-zip' usage and +delegates to `-zip-lists' or `-zip-pair' depending on the number +of LISTS." + (if (not (dash--length= lists 2)) + (cons #'-zip-lists lists) + (let ((pair (cons #'-zip-pair lists)) + (msg "Use -zip-pair instead of -zip to get a list of pairs")) + (if (fboundp 'macroexp-warn-and-return) + (macroexp-warn-and-return msg pair) + (message msg) + pair)))) + +(defun -zip (&rest lists) + "Zip LISTS together. + +Group the head of each list, followed by the second element of +each list, and so on. The number of returned groupings is equal +to the length of the shortest input list, and the number of items +in each grouping is equal to the number of input LISTS. + +If only two LISTS are provided as arguments, return the groupings +as a list of dotted pairs. Otherwise, return the groupings as a +list of proper lists. + +Since the return value changes form depending on the number of +arguments, it is generally recommended to use `-zip-lists' +instead, or `-zip-pair' if a list of dotted pairs is desired. + +See also: `-unzip'." + (declare (compiler-macro dash--zip-lists-or-pair) + (pure t) (side-effect-free t)) + ;; For backward compatibility, return a list of dotted pairs if two + ;; arguments were provided. + (apply (if (dash--length= lists 2) #'-zip-pair #'-zip-lists) lists)) + +(defun -zip-pair (&rest lists) + "Zip LIST1 and LIST2 together. + +Make a pair with the head of each list, followed by a pair with +the second element of each list, and so on. The number of pairs +returned is equal to the length of the shorter input list. + +See also: `-zip-lists'." + (declare (advertised-calling-convention (list1 list2) "2.20.0") + (pure t) (side-effect-free t)) + (if (dash--length= lists 2) + (--zip-with (cons it other) (car lists) (cadr lists)) + (apply #'-zip-lists lists))) + +(defun -zip-fill (fill-value &rest lists) + "Zip LISTS together, padding shorter lists with FILL-VALUE. +This is like `-zip' (which see), except it retains all elements +at positions beyond the end of the shortest list. The number of +returned groupings is equal to the length of the longest input +list, and the length of each grouping is equal to the number of +input LISTS. + +Since the return value changes form depending on the number of +arguments, it is generally recommended to use `-zip-lists-fill' +instead, unless a list of dotted pairs is explicitly desired." + (declare (pure t) (side-effect-free t)) + (cond ((null lists) ()) + ((dash--length= lists 2) + (let ((list1 (car lists)) + (list2 (cadr lists)) + results) + (while (or list1 list2) + (push (cons (if list1 (pop list1) fill-value) + (if list2 (pop list2) fill-value)) + results)) + (nreverse results))) + ((apply #'-zip-lists-fill fill-value lists)))) + +(defun -unzip (lists) + "Unzip LISTS. + +This works just like `-zip' (which see), but takes a list of +lists instead of a variable number of arguments, such that + + (-unzip (-zip L1 L2 L3 ...)) + +is identity (given that the lists are of the same length, and +that `-zip' is not called with two arguments, because of the +caveat described in its docstring). + +Note in particular that calling `-unzip' on a list of two lists +will return a list of dotted pairs. + +Since the return value changes form depending on the number of +LISTS, it is generally recommended to use `-unzip-lists' instead." + (declare (pure t) (side-effect-free t)) + (apply #'-zip lists)) + +(defun -cycle (list) + "Return an infinite circular copy of LIST. +The returned list cycles through the elements of LIST and repeats +from the beginning." + (declare (side-effect-free t)) + ;; Also works with sequences that aren't lists. + (let ((newlist (append list ()))) + (nconc newlist newlist))) + +(defun -pad (fill-value &rest lists) + "Pad each of LISTS with FILL-VALUE until they all have equal lengths. + +Ensure all LISTS are as long as the longest one by repeatedly +appending FILL-VALUE to the shorter lists, and return the +resulting LISTS." + (declare (pure t) (side-effect-free t)) + (let* ((lens (mapcar #'length lists)) + (maxlen (apply #'max 0 lens))) + (--map (append it (make-list (- maxlen (pop lens)) fill-value)) lists))) + +(defmacro --annotate (form list) + "Pair each item in LIST with the result of evaluating FORM. + +Return an alist of (RESULT . ITEM), where each ITEM is the +corresponding element of LIST, and RESULT is the value obtained +by evaluating FORM with ITEM bound to `it'. + +This is the anaphoric counterpart to `-annotate'." + (declare (debug (form form))) + `(--map (cons ,form it) ,list)) + +(defun -annotate (fn list) + "Pair each item in LIST with the result of passing it to FN. + +Return an alist of (RESULT . ITEM), where each ITEM is the +corresponding element of LIST, and RESULT is the value obtained +by calling FN on ITEM. + +This function's anaphoric counterpart is `--annotate'." + (declare (important-return-value t)) + (--annotate (funcall fn it) list)) + +(defun dash--table-carry (lists restore-lists &optional re) + "Helper for `-table' and `-table-flat'. + +If a list overflows, carry to the right and reset the list." + (while (not (or (car lists) + (equal lists '(nil)))) + (setcar lists (car restore-lists)) + (pop (cadr lists)) + (!cdr lists) + (!cdr restore-lists) + (when re + (push (nreverse (car re)) (cadr re)) + (setcar re nil) + (!cdr re)))) + +(defun -table (fn &rest lists) + "Compute outer product of LISTS using function FN. + +The function FN should have the same arity as the number of +supplied lists. + +The outer product is computed by applying fn to all possible +combinations created by taking one element from each list in +order. The dimension of the result is (length lists). + +See also: `-table-flat'" + (declare (important-return-value t)) + (let ((restore-lists (copy-sequence lists)) + (last-list (last lists)) + (re (make-list (length lists) nil))) + (while (car last-list) + (let ((item (apply fn (-map 'car lists)))) + (push item (car re)) + (setcar lists (cdar lists)) ;; silence byte compiler + (dash--table-carry lists restore-lists re))) + (nreverse (car (last re))))) + +(defun -table-flat (fn &rest lists) + "Compute flat outer product of LISTS using function FN. + +The function FN should have the same arity as the number of +supplied lists. + +The outer product is computed by applying fn to all possible +combinations created by taking one element from each list in +order. The results are flattened, ignoring the tensor structure +of the result. This is equivalent to calling: + + (-flatten-n (1- (length lists)) (apply \\='-table fn lists)) + +but the implementation here is much more efficient. + +See also: `-flatten-n', `-table'" + (declare (important-return-value t)) + (let ((restore-lists (copy-sequence lists)) + (last-list (last lists)) + re) + (while (car last-list) + (let ((item (apply fn (-map 'car lists)))) + (push item re) + (setcar lists (cdar lists)) ;; silence byte compiler + (dash--table-carry lists restore-lists))) + (nreverse re))) + +(defmacro --find-index (form list) + "Return the first index in LIST for which FORM evals to non-nil. +Return nil if no such index is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-index'." + (declare (debug (form form))) + `(--some (and ,form it-index) ,list)) + +(defun -find-index (pred list) + "Return the index of the first item satisfying PRED in LIST. +Return nil if no such item is found. + +PRED is called with one argument, the current list element, until +it returns non-nil, at which point the search terminates. + +This function's anaphoric counterpart is `--find-index'. + +See also: `-first', `-find-last-index'." + (declare (important-return-value t)) + (--find-index (funcall pred it) list)) + +(defun -elem-index (elem list) + "Return the first index of ELEM in LIST. +That is, the index within LIST of the first element that is +`equal' to ELEM. Return nil if there is no such element. + +See also: `-find-index'." + (declare (pure t) (side-effect-free t)) + (--find-index (equal elem it) list)) + +(defmacro --find-indices (form list) + "Return the list of indices in LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-indices'." + (declare (debug (form form))) + `(--keep (and ,form it-index) ,list)) + +(defun -find-indices (pred list) + "Return the list of indices in LIST satisfying PRED. + +Each element of LIST in turn is passed to PRED. If the result is +non-nil, the index of that element in LIST is included in the +result. The returned indices are in ascending order, i.e., in +the same order as they appear in LIST. + +This function's anaphoric counterpart is `--find-indices'. + +See also: `-find-index', `-elem-indices'." + (declare (important-return-value t)) + (--find-indices (funcall pred it) list)) + +(defun -elem-indices (elem list) + "Return the list of indices at which ELEM appears in LIST. +That is, the indices of all elements of LIST `equal' to ELEM, in +the same ascending order as they appear in LIST." + (declare (pure t) (side-effect-free t)) + (--find-indices (equal elem it) list)) + +(defmacro --find-last-index (form list) + "Return the last index in LIST for which FORM evals to non-nil. +Return nil if no such index is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-last-index'." + (declare (debug (form form))) + (let ((i (make-symbol "index"))) + `(let (,i) + (--each ,list + (when ,form (setq ,i it-index))) + ,i))) + +(defun -find-last-index (pred list) + "Return the index of the last item satisfying PRED in LIST. +Return nil if no such item is found. + +Predicate PRED is called with one argument each time, namely the +current list element. + +This function's anaphoric counterpart is `--find-last-index'. + +See also: `-last', `-find-index'." + (declare (important-return-value t)) + (--find-last-index (funcall pred it) list)) + +(defun -select-by-indices (indices list) + "Return a list whose elements are elements from LIST selected +as `(nth i list)` for all i from INDICES." + (declare (pure t) (side-effect-free t)) + (let (r) + (--each indices + (!cons (nth it list) r)) + (nreverse r))) + +(defun -select-columns (columns table) + "Select COLUMNS from TABLE. + +TABLE is a list of lists where each element represents one row. +It is assumed each row has the same length. + +Each row is transformed such that only the specified COLUMNS are +selected. + +See also: `-select-column', `-select-by-indices'" + (declare (pure t) (side-effect-free t)) + (--map (-select-by-indices columns it) table)) + +(defun -select-column (column table) + "Select COLUMN from TABLE. + +TABLE is a list of lists where each element represents one row. +It is assumed each row has the same length. + +The single selected column is returned as a list. + +See also: `-select-columns', `-select-by-indices'" + (declare (pure t) (side-effect-free t)) + (--mapcat (-select-by-indices (list column) it) table)) + +(defmacro -> (x &optional form &rest more) + "Thread the expr through the forms. Insert X as the second item +in the first form, making a list of it if it is not a list +already. If there are more forms, insert the first form as the +second item in second form, etc." + (declare (debug (form &rest [&or symbolp (sexp &rest form)]))) + (cond + ((null form) x) + ((null more) (if (listp form) + `(,(car form) ,x ,@(cdr form)) + (list form x))) + (:else `(-> (-> ,x ,form) ,@more)))) + +(defmacro ->> (x &optional form &rest more) + "Thread the expr through the forms. Insert X as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, insert the first form as the +last item in second form, etc." + (declare (debug ->)) + (cond + ((null form) x) + ((null more) (if (listp form) + `(,@form ,x) + (list form x))) + (:else `(->> (->> ,x ,form) ,@more)))) + +(defmacro --> (x &rest forms) + "Starting with the value of X, thread each expression through FORMS. + +Insert X at the position signified by the symbol `it' in the first +form. If there are more forms, insert the first form at the position +signified by `it' in the second form, etc." + (declare (debug (form body))) + `(-as-> ,x it ,@forms)) + +(defmacro -as-> (value variable &rest forms) + "Starting with VALUE, thread VARIABLE through FORMS. + +In the first form, bind VARIABLE to VALUE. In the second form, bind +VARIABLE to the result of the first form, and so forth." + (declare (debug (form symbolp body))) + (if (null forms) + `,value + `(let ((,variable ,value)) + (-as-> ,(if (symbolp (car forms)) + (list (car forms) variable) + (car forms)) + ,variable + ,@(cdr forms))))) + +(defmacro -some-> (x &optional form &rest more) + "When expr is non-nil, thread it through the first form (via `->'), +and when that result is non-nil, through the next form, etc." + (declare (debug ->) + (indent 1)) + (if (null form) x + (let ((result (make-symbol "result"))) + `(-some-> (-when-let (,result ,x) + (-> ,result ,form)) + ,@more)))) + +(defmacro -some->> (x &optional form &rest more) + "When expr is non-nil, thread it through the first form (via `->>'), +and when that result is non-nil, through the next form, etc." + (declare (debug ->) + (indent 1)) + (if (null form) x + (let ((result (make-symbol "result"))) + `(-some->> (-when-let (,result ,x) + (->> ,result ,form)) + ,@more)))) + +(defmacro -some--> (expr &rest forms) + "Thread EXPR through FORMS via `-->', while the result is non-nil. +When EXPR evaluates to non-nil, thread the result through the +first of FORMS, and when that result is non-nil, thread it +through the next form, etc." + (declare (debug (form &rest &or symbolp consp)) (indent 1)) + (if (null forms) expr + (let ((result (make-symbol "result"))) + `(-some--> (-when-let (,result ,expr) + (--> ,result ,(car forms))) + ,@(cdr forms))))) + +(defmacro -doto (init &rest forms) + "Evaluate INIT and pass it as argument to FORMS with `->'. +The RESULT of evaluating INIT is threaded through each of FORMS +individually using `->', which see. The return value is RESULT, +which FORMS may have modified by side effect." + (declare (debug (form &rest &or symbolp consp)) (indent 1)) + (let ((retval (make-symbol "result"))) + `(let ((,retval ,init)) + ,@(mapcar (lambda (form) `(-> ,retval ,form)) forms) + ,retval))) + +(defmacro --doto (init &rest forms) + "Anaphoric form of `-doto'. +This just evaluates INIT, binds the result to `it', evaluates +FORMS, and returns the final value of `it'. +Note: `it' need not be used in each form." + (declare (debug (form body)) (indent 1)) + `(let ((it ,init)) + ,@forms + it)) + +(defun -grade-up (comparator list) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in ascending order." + (declare (important-return-value t)) + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car it) (car other)))) + (mapcar #'cdr))) + +(defun -grade-down (comparator list) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in descending order." + (declare (important-return-value t)) + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car other) (car it)))) + (mapcar #'cdr))) + +(defvar dash--source-counter 0 + "Monotonic counter for generated symbols.") + +(defun dash--match-make-source-symbol () + "Generate a new dash-source symbol. + +All returned symbols are guaranteed to be unique." + (prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter)) + (setq dash--source-counter (1+ dash--source-counter)))) + +(defun dash--match-ignore-place-p (symbol) + "Return non-nil if SYMBOL is a symbol and starts with _." + (and (symbolp symbol) + (eq (aref (symbol-name symbol) 0) ?_))) + +(defun dash--match-cons-skip-cdr (skip-cdr source) + "Helper function generating idiomatic shifting code." + (cond + ((= skip-cdr 0) + `(pop ,source)) + (t + `(prog1 ,(dash--match-cons-get-car skip-cdr source) + (setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source)))))) + +(defun dash--match-cons-get-car (skip-cdr source) + "Helper function generating idiomatic code to get nth car." + (cond + ((= skip-cdr 0) + `(car ,source)) + ((= skip-cdr 1) + `(cadr ,source)) + (t + `(nth ,skip-cdr ,source)))) + +(defun dash--match-cons-get-cdr (skip-cdr source) + "Helper function generating idiomatic code to get nth cdr." + (cond + ((= skip-cdr 0) + source) + ((= skip-cdr 1) + `(cdr ,source)) + (t + `(nthcdr ,skip-cdr ,source)))) + +(defun dash--match-cons (match-form source) + "Setup a cons matching environment and call the real matcher." + (let ((s (dash--match-make-source-symbol)) + (n 0) + (m match-form)) + (while (and (consp m) + (dash--match-ignore-place-p (car m))) + (setq n (1+ n)) (!cdr m)) + (cond + ;; when we only have one pattern in the list, we don't have to + ;; create a temporary binding (--dash-source--) for the source + ;; and just use the input directly + ((and (consp m) + (not (cdr m))) + (dash--match (car m) (dash--match-cons-get-car n source))) + ;; handle other special types + ((> n 0) + (dash--match m (dash--match-cons-get-cdr n source))) + ;; this is the only entry-point for dash--match-cons-1, that's + ;; why we can't simply use the above branch, it would produce + ;; infinite recursion + (t + (cons (list s source) (dash--match-cons-1 match-form s)))))) + +(defun dash--get-expand-function (type) + "Get expand function name for TYPE." + (intern-soft (format "dash-expand:%s" type))) + +(defun dash--match-cons-1 (match-form source &optional props) + "Match MATCH-FORM against SOURCE. + +MATCH-FORM is a proper or improper list. Each element of +MATCH-FORM is either a symbol, which gets bound to the respective +value in source or another match form which gets destructured +recursively. + +If the cdr of last cons cell in the list is nil, matching stops +there. + +SOURCE is a proper or improper list." + (let ((skip-cdr (or (plist-get props :skip-cdr) 0))) + (cond + ((consp match-form) + (cond + ((cdr match-form) + (cond + ((and (symbolp (car match-form)) + (functionp (dash--get-expand-function (car match-form)))) + (dash--match-kv (dash--match-kv-normalize-match-form match-form) (dash--match-cons-get-cdr skip-cdr source))) + ((dash--match-ignore-place-p (car match-form)) + (dash--match-cons-1 (cdr match-form) source + (plist-put props :skip-cdr (1+ skip-cdr)))) + (t + (-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source)) + (dash--match-cons-1 (cdr match-form) source))))) + (t ;; Last matching place, no need for shift + (dash--match (car match-form) (dash--match-cons-get-car skip-cdr source))))) + ((eq match-form nil) + nil) + (t ;; Handle improper lists. Last matching place, no need for shift + (dash--match match-form (dash--match-cons-get-cdr skip-cdr source)))))) + +(defun dash--match-vector (match-form source) + "Setup a vector matching environment and call the real matcher." + (let ((s (dash--match-make-source-symbol))) + (cond + ;; don't bind `s' if we only have one sub-pattern + ((= (length match-form) 1) + (dash--match (aref match-form 0) `(aref ,source 0))) + ;; if the source is a symbol, we don't need to re-bind it + ((symbolp source) + (dash--match-vector-1 match-form source)) + ;; don't bind `s' if we only have one sub-pattern which is not ignored + ((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form)) + (ignored-places-n (length (-remove 'null ignored-places)))) + (when (= ignored-places-n (1- (length match-form))) + (let ((n (-find-index 'null ignored-places))) + (dash--match (aref match-form n) `(aref ,source ,n)))))) + (t + (cons (list s source) (dash--match-vector-1 match-form s)))))) + +(defun dash--match-vector-1 (match-form source) + "Match MATCH-FORM against SOURCE. + +MATCH-FORM is a vector. Each element of MATCH-FORM is either a +symbol, which gets bound to the respective value in source or +another match form which gets destructured recursively. + +If second-from-last place in MATCH-FORM is the symbol &rest, the +next element of the MATCH-FORM is matched against the tail of +SOURCE, starting at index of the &rest symbol. This is +conceptually the same as the (head . tail) match for improper +lists, where dot plays the role of &rest. + +SOURCE is a vector. + +If the MATCH-FORM vector is shorter than SOURCE vector, only +the (length MATCH-FORM) places are bound, the rest of the SOURCE +is discarded." + (let ((i 0) + (l (length match-form)) + (re)) + (while (< i l) + (let ((m (aref match-form i))) + (push (cond + ((and (symbolp m) + (eq m '&rest)) + (prog1 (dash--match + (aref match-form (1+ i)) + `(substring ,source ,i)) + (setq i l))) + ((and (symbolp m) + ;; do not match symbols starting with _ + (not (eq (aref (symbol-name m) 0) ?_))) + (list (list m `(aref ,source ,i)))) + ((not (symbolp m)) + (dash--match m `(aref ,source ,i)))) + re) + (setq i (1+ i)))) + (-flatten-n 1 (nreverse re)))) + +(defun dash--match-kv-normalize-match-form (pattern) + "Normalize kv PATTERN. + +This method normalizes PATTERN to the format expected by +`dash--match-kv'. See `-let' for the specification." + (let ((normalized (list (car pattern))) + (skip nil) + (fill-placeholder (make-symbol "--dash-fill-placeholder--"))) + (-each (-zip-fill fill-placeholder (cdr pattern) (cddr pattern)) + (lambda (pair) + (let ((current (car pair)) + (next (cdr pair))) + (if skip + (setq skip nil) + (if (or (eq fill-placeholder next) + (not (or (and (symbolp next) + (not (keywordp next)) + (not (eq next t)) + (not (eq next nil))) + (and (consp next) + (not (eq (car next) 'quote))) + (vectorp next)))) + (progn + (cond + ((keywordp current) + (push current normalized) + (push (intern (substring (symbol-name current) 1)) normalized)) + ((stringp current) + (push current normalized) + (push (intern current) normalized)) + ((and (consp current) + (eq (car current) 'quote)) + (push current normalized) + (push (cadr current) normalized)) + (t (error "-let: found key `%s' in kv destructuring but its pattern `%s' is invalid and can not be derived from the key" current next))) + (setq skip nil)) + (push current normalized) + (push next normalized) + (setq skip t)))))) + (nreverse normalized))) + +(defun dash--match-kv (match-form source) + "Setup a kv matching environment and call the real matcher. + +kv can be any key-value store, such as plist, alist or hash-table." + (let ((s (dash--match-make-source-symbol))) + (cond + ;; don't bind `s' if we only have one sub-pattern (&type key val) + ((= (length match-form) 3) + (dash--match-kv-1 (cdr match-form) source (car match-form))) + ;; if the source is a symbol, we don't need to re-bind it + ((symbolp source) + (dash--match-kv-1 (cdr match-form) source (car match-form))) + (t + (cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form))))))) + +(defun dash-expand:&hash (key source) + "Generate extracting KEY from SOURCE for &hash destructuring." + `(gethash ,key ,source)) + +(defun dash-expand:&plist (key source) + "Generate extracting KEY from SOURCE for &plist destructuring." + `(plist-get ,source ,key)) + +(defun dash-expand:&alist (key source) + "Generate extracting KEY from SOURCE for &alist destructuring." + `(cdr (assoc ,key ,source))) + +(defun dash-expand:&hash? (key source) + "Generate extracting KEY from SOURCE for &hash? destructuring. +Similar to &hash but check whether the map is not nil." + (let ((src (make-symbol "src"))) + `(let ((,src ,source)) + (when ,src (gethash ,key ,src))))) + +(defalias 'dash-expand:&keys #'dash-expand:&plist) + +(defun dash--match-kv-1 (match-form source type) + "Match MATCH-FORM against SOURCE of type TYPE. + +MATCH-FORM is a proper list of the form (key1 place1 ... keyN +placeN). Each placeK is either a symbol, which gets bound to the +value of keyK retrieved from the key-value store, or another +match form which gets destructured recursively. + +SOURCE is a key-value store of type TYPE, which can be a plist, +an alist or a hash table. + +TYPE is a token specifying the type of the key-value store. +Valid values are &plist, &alist and &hash." + (-flatten-n 1 (-map + (lambda (kv) + (let* ((k (car kv)) + (v (cadr kv)) + (getter + (funcall (dash--get-expand-function type) k source))) + (cond + ((symbolp v) + (list (list v getter))) + (t (dash--match v getter))))) + (-partition 2 match-form)))) + +(defun dash--match-symbol (match-form source) + "Bind a symbol. + +This works just like `let', there is no destructuring." + (list (list match-form source))) + +(defun dash--match (match-form source) + "Match MATCH-FORM against SOURCE. + +This function tests the MATCH-FORM and dispatches to specific +matchers based on the type of the expression. + +Key-value stores are disambiguated by placing a token &plist, +&alist or &hash as a first item in the MATCH-FORM." + (cond + ((and (symbolp match-form) + ;; Don't bind things like &keys as if they were vars (#395). + (not (functionp (dash--get-expand-function match-form)))) + (dash--match-symbol match-form source)) + ((consp match-form) + (cond + ;; Handle the "x &as" bindings first. + ((and (consp (cdr match-form)) + (symbolp (car match-form)) + (eq '&as (cadr match-form))) + (let ((s (car match-form))) + (cons (list s source) + (dash--match (cddr match-form) s)))) + ((functionp (dash--get-expand-function (car match-form))) + (dash--match-kv (dash--match-kv-normalize-match-form match-form) source)) + (t (dash--match-cons match-form source)))) + ((vectorp match-form) + ;; We support the &as binding in vectors too + (cond + ((and (> (length match-form) 2) + (symbolp (aref match-form 0)) + (eq '&as (aref match-form 1))) + (let ((s (aref match-form 0))) + (cons (list s source) + (dash--match (substring match-form 2) s)))) + (t (dash--match-vector match-form source)))))) + +(defun dash--normalize-let-varlist (varlist) + "Normalize VARLIST so that every binding is a list. + +`let' allows specifying a binding which is not a list but simply +the place which is then automatically bound to nil, such that all +three of the following are identical and evaluate to nil. + + (let (a) a) + (let ((a)) a) + (let ((a nil)) a) + +This function normalizes all of these to the last form." + (--map (if (consp it) it (list it nil)) varlist)) + +(defmacro -let* (varlist &rest body) + "Bind variables according to VARLIST then eval BODY. + +VARLIST is a list of lists of the form (PATTERN SOURCE). Each +PATTERN is matched against the SOURCE structurally. SOURCE is +only evaluated once for each PATTERN. + +Each SOURCE can refer to the symbols already bound by this +VARLIST. This is useful if you want to destructure SOURCE +recursively but also want to name the intermediate structures. + +See `-let' for the list of all possible patterns." + (declare (debug ((&rest [&or (sexp form) sexp]) body)) + (indent 1)) + (let* ((varlist (dash--normalize-let-varlist varlist)) + (bindings (--mapcat (dash--match (car it) (cadr it)) varlist))) + `(let* ,bindings + ,@body))) + +(defmacro -let (varlist &rest body) + "Bind variables according to VARLIST then eval BODY. + +VARLIST is a list of lists of the form (PATTERN SOURCE). Each +PATTERN is matched against the SOURCE \"structurally\". SOURCE +is only evaluated once for each PATTERN. Each PATTERN is matched +recursively, and can therefore contain sub-patterns which are +matched against corresponding sub-expressions of SOURCE. + +All the SOURCEs are evalled before any symbols are +bound (i.e. \"in parallel\"). + +If VARLIST only contains one (PATTERN SOURCE) element, you can +optionally specify it using a vector and discarding the +outer-most parens. Thus + + (-let ((PATTERN SOURCE)) ...) + +becomes + + (-let [PATTERN SOURCE] ...). + +`-let' uses a convention of not binding places (symbols) starting +with _ whenever it's possible. You can use this to skip over +entries you don't care about. However, this is not *always* +possible (as a result of implementation) and these symbols might +get bound to undefined values. + +Following is the overview of supported patterns. Remember that +patterns can be matched recursively, so every a, b, aK in the +following can be a matching construct and not necessarily a +symbol/variable. + +Symbol: + + a - bind the SOURCE to A. This is just like regular `let'. + +Conses and lists: + + (a) - bind `car' of cons/list to A + + (a . b) - bind car of cons to A and `cdr' to B + + (a b) - bind car of list to A and `cadr' to B + + (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3... + + (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST. + +Vectors: + + [a] - bind 0th element of a non-list sequence to A (works with + vectors, strings, bit arrays...) + + [a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to + A1, 2nd to A2, ... + If the PATTERN is shorter than SOURCE, the values at + places not in PATTERN are ignored. + If the PATTERN is longer than SOURCE, an `error' is + thrown. + + [a1 a2 a3 ... &rest rest] - as above, but bind the rest of + the sequence to REST. This is + conceptually the same as improper list + matching (a1 a2 ... aN . rest) + +Key/value stores: + + (&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE plist to aK. If the + value is not found, aK is nil. + Uses `plist-get' to fetch values. + + (&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE alist to aK. If the + value is not found, aK is nil. + Uses `assoc' to fetch values. + + (&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE hash table to aK. If the + value is not found, aK is nil. + Uses `gethash' to fetch values. + +Further, special keyword &keys supports \"inline\" matching of +plist-like key-value pairs, similarly to &keys keyword of +`cl-defun'. + + (a1 a2 ... aN &keys key1 b1 ... keyN bK) + +This binds N values from the list to a1 ... aN, then interprets +the cdr as a plist (see key/value matching above). + +A shorthand notation for kv-destructuring exists which allows the +patterns be optionally left out and derived from the key name in +the following fashion: + +- a key :foo is converted into `foo' pattern, +- a key \\='bar is converted into `bar' pattern, +- a key \"baz\" is converted into `baz' pattern. + +That is, the entire value under the key is bound to the derived +variable without any further destructuring. + +This is possible only when the form following the key is not a +valid pattern (i.e. not a symbol, a cons cell or a vector). +Otherwise the matching proceeds as usual and in case of an +invalid spec fails with an error. + +Thus the patterns are normalized as follows: + + ;; derive all the missing patterns + (&plist :foo \\='bar \"baz\") => (&plist :foo foo \\='bar bar \"baz\" baz) + + ;; we can specify some but not others + (&plist :foo \\='bar explicit-bar) => (&plist :foo foo \\='bar explicit-bar) + + ;; nothing happens, we store :foo in x + (&plist :foo x) => (&plist :foo x) + + ;; nothing happens, we match recursively + (&plist :foo (a b c)) => (&plist :foo (a b c)) + +You can name the source using the syntax SYMBOL &as PATTERN. +This syntax works with lists (proper or improper), vectors and +all types of maps. + + (list &as a b c) (list 1 2 3) + +binds A to 1, B to 2, C to 3 and LIST to (1 2 3). + +Similarly: + + (bounds &as beg . end) (cons 1 2) + +binds BEG to 1, END to 2 and BOUNDS to (1 . 2). + + (items &as first . rest) (list 1 2 3) + +binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3) + + [vect &as _ b c] [1 2 3] + +binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual). + + (plist &as &plist :b b) (list :a 1 :b 2 :c 3) + +binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash. + +This is especially useful when we want to capture the result of a +computation and destructure at the same time. Consider the +form (function-returning-complex-structure) returning a list of +two vectors with two items each. We want to capture this entire +result and pass it to another computation, but at the same time +we want to get the second item from each vector. We can achieve +it with pattern + + (result &as [_ a] [_ b]) (function-returning-complex-structure) + +Note: Clojure programmers may know this feature as the \":as +binding\". The difference is that we put the &as at the front +because we need to support improper list binding." + (declare (debug ([&or (&rest [&or (sexp form) sexp]) + (vector [&rest [sexp form]])] + body)) + (indent 1)) + (if (vectorp varlist) + `(let* ,(dash--match (aref varlist 0) (aref varlist 1)) + ,@body) + (let* ((varlist (dash--normalize-let-varlist varlist)) + (inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist)) + (new-varlist (--zip-with (list (car it) (car other)) + varlist inputs))) + `(let ,inputs + (-let* ,new-varlist ,@body))))) + +(defmacro -lambda (match-form &rest body) + "Return a lambda which destructures its input as MATCH-FORM and executes BODY. + +Note that you have to enclose the MATCH-FORM in a pair of parens, +such that: + + (-lambda (x) body) + (-lambda (x y ...) body) + +has the usual semantics of `lambda'. Furthermore, these get +translated into normal `lambda', so there is no performance +penalty. + +See `-let' for a description of the destructuring mechanism." + (declare (doc-string 2) (indent defun) + (debug (&define sexp + [&optional stringp] + [&optional ("interactive" interactive)] + def-body))) + (cond + ((nlistp match-form) + (signal 'wrong-type-argument (list #'listp match-form))) + ;; No destructuring, so just return regular `lambda' for speed. + ((-all? #'symbolp match-form) + `(lambda ,match-form ,@body)) + ((let ((inputs (--map-indexed + (list it (make-symbol (format "input%d" it-index))) + match-form))) + ;; TODO: because inputs to the `lambda' are evaluated only once, + ;; `-let*' need not create the extra bindings to ensure that. + ;; We should find a way to optimize that. Not critical however. + `(lambda ,(mapcar #'cadr inputs) + (-let* ,inputs ,@body)))))) + +(defmacro -setq (&rest forms) + "Bind each MATCH-FORM to the value of its VAL. + +MATCH-FORM destructuring is done according to the rules of `-let'. + +This macro allows you to bind multiple variables by destructuring +the value, so for example: + + (-setq (a b) x + (&plist :c c) plist) + +expands roughly speaking to the following code + + (setq a (car x) + b (cadr x) + c (plist-get plist :c)) + +Care is taken to only evaluate each VAL once so that in case of +multiple assignments it does not cause unexpected side effects. + +\(fn [MATCH-FORM VAL]...)" + (declare (debug (&rest sexp form)) + (indent 1)) + (when (= (mod (length forms) 2) 1) + (signal 'wrong-number-of-arguments (list '-setq (1+ (length forms))))) + (let* ((forms-and-sources + ;; First get all the necessary mappings with all the + ;; intermediate bindings. + (-map (lambda (x) (dash--match (car x) (cadr x))) + (-partition 2 forms))) + ;; To preserve the logic of dynamic scoping we must ensure + ;; that we `setq' the variables outside of the `let*' form + ;; which holds the destructured intermediate values. For + ;; this we generate for each variable a placeholder which is + ;; bound to (lexically) the result of the destructuring. + ;; Then outside of the helper `let*' form we bind all the + ;; original variables to their respective placeholders. + ;; TODO: There is a lot of room for possible optimization, + ;; for start playing with `special-variable-p' to eliminate + ;; unnecessary re-binding. + (variables-to-placeholders + (-mapcat + (lambda (bindings) + (-map + (lambda (binding) + (let ((var (car binding))) + (list var (make-symbol (concat "--dash-binding-" (symbol-name var) "--"))))) + (--filter (not (string-prefix-p "--" (symbol-name (car it)))) bindings))) + forms-and-sources))) + `(let ,(-map 'cadr variables-to-placeholders) + (let* ,(-flatten-n 1 forms-and-sources) + (setq ,@(-flatten (-map 'reverse variables-to-placeholders)))) + (setq ,@(-flatten variables-to-placeholders))))) + +(defmacro -if-let* (vars-vals then &rest else) + "If all VALS evaluate to true, bind them to their corresponding +VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list +of (VAR VAL) pairs. + +Note: binding is done according to `-let*'. VALS are evaluated +sequentially, and evaluation stops after the first nil VAL is +encountered." + (declare (debug ((&rest (sexp form)) form body)) + (indent 2)) + (->> vars-vals + (--mapcat (dash--match (car it) (cadr it))) + (--reduce-r-from + (let ((var (car it)) + (val (cadr it))) + `(let ((,var ,val)) + (if ,var ,acc ,@else))) + then))) + +(defmacro -if-let (var-val then &rest else) + "If VAL evaluates to non-nil, bind it to VAR and do THEN, +otherwise do ELSE. + +Note: binding is done according to `-let'. + +\(fn (VAR VAL) THEN &rest ELSE)" + (declare (debug ((sexp form) form body)) + (indent 2)) + `(-if-let* (,var-val) ,then ,@else)) + +(defmacro --if-let (val then &rest else) + "If VAL evaluates to non-nil, bind it to symbol `it' and do THEN, +otherwise do ELSE." + (declare (debug (form form body)) + (indent 2)) + `(-if-let (it ,val) ,then ,@else)) + +(defmacro -when-let* (vars-vals &rest body) + "If all VALS evaluate to true, bind them to their corresponding +VARS and execute body. VARS-VALS should be a list of (VAR VAL) +pairs. + +Note: binding is done according to `-let*'. VALS are evaluated +sequentially, and evaluation stops after the first nil VAL is +encountered." + (declare (debug ((&rest (sexp form)) body)) + (indent 1)) + `(-if-let* ,vars-vals (progn ,@body))) + +(defmacro -when-let (var-val &rest body) + "If VAL evaluates to non-nil, bind it to VAR and execute body. + +Note: binding is done according to `-let'. + +\(fn (VAR VAL) &rest BODY)" + (declare (debug ((sexp form) body)) + (indent 1)) + `(-if-let ,var-val (progn ,@body))) + +(defmacro --when-let (val &rest body) + "If VAL evaluates to non-nil, bind it to symbol `it' and +execute body." + (declare (debug (form body)) + (indent 1)) + `(--if-let ,val (progn ,@body))) + +;; TODO: Get rid of this dynamic variable, passing it as an argument +;; instead? +(defvar -compare-fn nil + "Tests for equality use this function, or `equal' if this is nil. + +As a dynamic variable, this should be temporarily bound around +the relevant operation, rather than permanently modified. For +example: + + (let ((-compare-fn #\\='=)) + (-union \\='(1 2 3) \\='(2 3 4)))") + +(defun dash--member-fn () + "Return the flavor of `member' that goes best with `-compare-fn'." + (declare (side-effect-free error-free)) + (let ((cmp -compare-fn)) + (cond ((memq cmp '(nil equal)) #'member) + ((eq cmp #'eq) #'memq) + ((eq cmp #'eql) #'memql) + ((lambda (elt list) + (while (and list (not (funcall cmp elt (car list)))) + (pop list)) + list))))) + +(defun dash--assoc-fn () + "Return the flavor of `assoc' that goes best with `-compare-fn'." + (declare (side-effect-free error-free)) + (let ((cmp -compare-fn)) + (cond ((memq cmp '(nil equal)) #'assoc) + ((eq cmp #'eq) #'assq) + ((lambda (key alist) + ;; Since Emacs 26, `assoc' accepts a custom `testfn'. + ;; Version testing would be simpler here, but feature + ;; testing gets more brownie points, I guess. + (static-if (condition-case nil + (assoc nil () #'eql) + (wrong-number-of-arguments t)) + (--first (and (consp it) (funcall cmp (car it) key)) alist) + (assoc key alist cmp))))))) + +(defun dash--hash-test-fn () + "Return the hash table test function corresponding to `-compare-fn'. +Return nil if `-compare-fn' is not a known test function." + (declare (side-effect-free error-free)) + ;; In theory this could also recognize values that are custom + ;; `hash-table-test's, but too often the :test name is different + ;; from the equality function, so it doesn't seem worthwhile. + (car (memq (or -compare-fn #'equal) '(equal eq eql)))) + +(defvar dash--short-list-length 32 + "Maximum list length considered short, for optimizations. +For example, the speedup afforded by hash table lookup may start +to outweigh its runtime and memory overhead for problem sizes +greater than this value. See also the discussion in PR #305.") + +(defun -distinct (list) + "Return a copy of LIST with all duplicate elements removed. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. + +Alias: `-uniq'." + (declare (important-return-value t)) + (let (test len) + (cond ((null list) ()) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the list is long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (--filter (unless (gethash it ht) (puthash it t ht)) list))) + ((let ((member (dash--member-fn)) uniq) + (--each list (unless (funcall member it uniq) (push it uniq))) + (nreverse uniq)))))) + +(defalias '-uniq #'-distinct) + +(defun dash--size+ (size1 size2) + "Return the sum of nonnegative fixnums SIZE1 and SIZE2. +Return `most-positive-fixnum' on overflow. This ensures the +result is a valid size, particularly for allocating hash tables, +even in the presence of bignum support." + (declare (side-effect-free t)) + (if (< size1 (- most-positive-fixnum size2)) + (+ size1 size2) + most-positive-fixnum)) + +(defun -union (list1 list2) + "Return a new list of distinct elements appearing in either LIST1 or LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let ((lists (list list1 list2)) test len union) + (cond ((null (or list1 list2))) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the lists are long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (dash--size+ (length list1) (length list2))) + dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (dolist (l lists) + (--each l (unless (gethash it ht) + (puthash it t ht) + (push it union)))))) + ((let ((member (dash--member-fn))) + (dolist (l lists) + (--each l (unless (funcall member it union) (push it union))))))) + (nreverse union))) + +(defun -intersection (list1 list2) + "Return a new list of distinct elements appearing in both LIST1 and LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let (test len) + (cond ((null (and list1 list2)) ()) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and either list is long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list2)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (--each list2 (puthash it t ht)) + ;; Remove visited elements to avoid duplicates. + (--filter (when (gethash it ht) (remhash it ht) t) list1))) + ((let ((member (dash--member-fn)) intersection) + (--each list1 (and (funcall member it list2) + (not (funcall member it intersection)) + (push it intersection))) + (nreverse intersection)))))) + +(defun -difference (list1 list2) + "Return a new list with the distinct members of LIST1 that are not in LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let (test len1 len2) + (cond ((null list1) ()) + ((null list2) (-distinct list1)) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the subtrahend is long enough. + ((and (setq test (dash--hash-test-fn)) + (setq len1 (length list1)) + (setq len2 (length list2)) + (> (max len1 len2) dash--short-list-length)) + (let ((ht1 (make-hash-table :test test :size len1)) + (ht2 (make-hash-table :test test :size len2))) + (--each list2 (puthash it t ht2)) + ;; Avoid duplicates by tracking visited items in `ht1'. + (--filter (unless (or (gethash it ht2) (gethash it ht1)) + (puthash it t ht1)) + list1))) + ((let ((member (dash--member-fn)) difference) + (--each list1 + (unless (or (funcall member it list2) + (funcall member it difference)) + (push it difference))) + (nreverse difference)))))) + +(defun -powerset (list) + "Return the power set of LIST." + (declare (pure t) (side-effect-free t)) + (if (null list) (list ()) + (let ((last (-powerset (cdr list)))) + (nconc (mapcar (lambda (x) (cons (car list) x)) last) + last)))) + +(defun -frequencies (list) + "Count the occurrences of each distinct element of LIST. + +Return an alist of (ELEMENT . N), where each ELEMENT occurs N +times in LIST. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. + +See also `-count' and `-group-by'." + (declare (important-return-value t)) + (let (test len freqs) + (cond ((null list)) + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + ;; Share structure between hash table and returned list. + ;; This affords a single pass that preserves the input + ;; order, conses less garbage, and is faster than a + ;; second traversal (e.g., with `maphash'). + (--each list + (let ((freq (gethash it ht))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (puthash it (cons it 1) ht) freqs)))))) + ((let ((assoc (dash--assoc-fn))) + (--each list + (let ((freq (funcall assoc it freqs))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (cons it 1) freqs))))))) + (nreverse freqs))) + +(defun dash--numbers<= (nums) + "Return non-nil if NUMS is a list of non-decreasing numbers." + (declare (pure t) (side-effect-free t)) + (or (null nums) + (let ((prev (pop nums))) + (and (numberp prev) + (--every (and (numberp it) (<= prev (setq prev it))) nums))))) + +(defun dash--next-lex-perm (array n) + "Update ARRAY of N numbers with its next lexicographic permutation. +Return nil if there is no such successor. N should be nonzero. + +This implements the salient steps of Algorithm L (Lexicographic +permutation generation) as described in DE Knuth's The Art of +Computer Programming, Volume 4A / Combinatorial Algorithms, +Part I, Addison-Wesley, 2011, § 7.2.1.2, p. 319." + (setq n (1- n)) + (let* ((l n) + (j (1- n)) + (al (aref array n)) + (aj al)) + ;; L2. [Find j]. + ;; Decrement j until a[j] < a[j+1]. + (while (and (<= 0 j) + (<= aj (setq aj (aref array j)))) + (setq j (1- j))) + ;; Terminate algorithm if j not found. + (when (>= j 0) + ;; L3. [Increase a[j]]. + ;; Decrement l until a[j] < a[l]. + (while (>= aj al) + (setq l (1- l) al (aref array l))) + ;; Swap a[j] and a[l]. + (aset array j al) + (aset array l aj) + ;; L4. [Reverse a[j+1]...a[n]]. + (setq l n) + (while (< (setq j (1+ j)) l) + (setq aj (aref array j)) + (aset array j (aref array l)) + (aset array l aj) + (setq l (1- l))) + array))) + +(defun dash--lex-perms (vec &optional original) + "Return a list of permutations of VEC in lexicographic order. +Specifically, return only the successors of VEC in lexicographic +order. Each returned permutation is a list. VEC should comprise +one or more numbers, and may be destructively modified. + +If ORIGINAL is a vector, then VEC is interpreted as a set of +indices into ORIGINAL. In this case, the indices are permuted, +and the resulting index permutations are used to dereference +elements of ORIGINAL." + (let ((len (length vec)) perms) + (while vec + (push (if original + (--map (aref original it) vec) + (append vec ())) + perms) + (setq vec (dash--next-lex-perm vec len))) + (nreverse perms))) + +(defun dash--uniq-perms (list) + "Return a list of permutations of LIST. +LIST is treated as if all its elements are distinct." + (let* ((vec (vconcat list)) + (idxs (copy-sequence vec))) + ;; Just construct a vector of the list's indices and permute that. + (dotimes (i (length idxs)) + (aset idxs i i)) + (dash--lex-perms idxs vec))) + +(defun dash--multi-perms (list freqs) + "Return a list of permutations of the multiset LIST. +FREQS should be an alist describing the frequency of each element +in LIST, as returned by `-frequencies'." + (let (;; Distinct items in `list', aka the cars of `freqs'. + (uniq (make-vector (length freqs) nil)) + ;; Indices into `uniq'. + (idxs (make-vector (length list) nil)) + ;; Current index into `idxs'. + (i 0)) + (--each freqs + (aset uniq it-index (car it)) + ;; Populate `idxs' with as many copies of each `it-index' as + ;; there are corresponding duplicates. + (dotimes (_ (cdr it)) + (aset idxs i it-index) + (setq i (1+ i)))) + (dash--lex-perms idxs uniq))) + +(defun -permutations (list) + "Return the distinct permutations of LIST. + +Duplicate elements of LIST are determined by `equal', or by +`-compare-fn' if that is non-nil." + (declare (important-return-value t)) + (cond ((null list) (list ())) + ;; Optimization: a traversal of `list' is faster than the + ;; round trip via `dash--uniq-perms' or `dash--multi-perms'. + ((dash--numbers<= list) + (dash--lex-perms (vconcat list))) + ((let ((freqs (-frequencies list))) + ;; Is each element distinct? + (unless (--every (= (cdr it) 1) freqs) + (dash--multi-perms list freqs)))) + ((dash--uniq-perms list)))) + +(defun -inits (list) + "Return all prefixes of LIST." + (declare (pure t) (side-effect-free t)) + (let ((res (list list))) + (setq list (reverse list)) + (while list + (push (reverse (!cdr list)) res)) + res)) + +(defun -tails (list) + "Return all suffixes of LIST." + (declare (pure t) (side-effect-free t)) + (-reductions-r-from #'cons nil list)) + +(defun -common-prefix (&rest lists) + "Return the longest common prefix of LISTS." + (declare (pure t) (side-effect-free t)) + (--reduce (--take-while (and acc (equal (pop acc) it)) it) + lists)) + +(defun -common-suffix (&rest lists) + "Return the longest common suffix of LISTS." + (declare (pure t) (side-effect-free t)) + (nreverse (apply #'-common-prefix (mapcar #'reverse lists)))) + +(defun -contains? (list element) + "Return non-nil if LIST contains ELEMENT. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. As with `member', the return value is +actually the tail of LIST whose car is ELEMENT. + +Alias: `-contains-p'." + (declare (important-return-value t)) + (funcall (dash--member-fn) element list)) + +(defalias '-contains-p #'-contains?) + +(defun -same-items? (list1 list2) + "Return non-nil if LIST1 and LIST2 have the same distinct elements. + +The order of the elements in the lists does not matter. The +lists may be of different lengths, i.e., contain duplicate +elements. The test for equality is done with `equal', or with +`-compare-fn' if that is non-nil. + +Alias: `-same-items-p'." + (declare (important-return-value t)) + (let (test len1 len2) + (cond ((null (or list1 list2))) + ((null (and list1 list2)) nil) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and either list is long enough. + ((and (setq test (dash--hash-test-fn)) + (setq len1 (length list1)) + (setq len2 (length list2)) + (> (max len1 len2) dash--short-list-length)) + (let ((ht1 (make-hash-table :test test :size len1)) + (ht2 (make-hash-table :test test :size len2))) + (--each list1 (puthash it t ht1)) + ;; Move visited elements from `ht1' to `ht2'. This way, + ;; if visiting all of `list2' leaves `ht1' empty, then + ;; all elements from both lists have been accounted for. + (and (--every (cond ((gethash it ht1) + (remhash it ht1) + (puthash it t ht2)) + ((gethash it ht2))) + list2) + (zerop (hash-table-count ht1))))) + ((let ((member (dash--member-fn))) + (and (--all? (funcall member it list2) list1) + (--all? (funcall member it list1) list2))))))) + +(defalias '-same-items-p #'-same-items?) + +(defun -is-prefix? (prefix list) + "Return non-nil if PREFIX is a prefix of LIST. + +Alias: `-is-prefix-p'." + (declare (pure t) (side-effect-free t)) + (--each-while list (and (equal (car prefix) it) + (!cdr prefix))) + (null prefix)) + +(defun -is-suffix? (suffix list) + "Return non-nil if SUFFIX is a suffix of LIST. + +Alias: `-is-suffix-p'." + (declare (pure t) (side-effect-free t)) + (equal suffix (last list (length suffix)))) + +(defun -is-infix? (infix list) + "Return non-nil if INFIX is infix of LIST. + +This operation runs in O(n^2) time + +Alias: `-is-infix-p'" + (declare (pure t) (side-effect-free t)) + (let (done) + (while (and (not done) list) + (setq done (-is-prefix? infix list)) + (!cdr list)) + done)) + +(defalias '-is-prefix-p '-is-prefix?) +(defalias '-is-suffix-p '-is-suffix?) +(defalias '-is-infix-p '-is-infix?) + +(defun -sort (comparator list) + "Sort LIST, stably, comparing elements using COMPARATOR. +Return the sorted list. LIST is NOT modified by side effects. +COMPARATOR is called with two elements of LIST, and should return non-nil +if the first element should sort before the second." + (declare (important-return-value t)) + (static-if (condition-case nil (sort []) (wrong-number-of-arguments)) + ;; Since Emacs 30. + (sort list :lessp comparator) + (sort (copy-sequence list) comparator))) + +(defmacro --sort (form list) + "Anaphoric form of `-sort'." + (declare (debug (def-form form))) + `(-sort (lambda (it other) (ignore it other) ,form) ,list)) + +(defun -list (&optional arg &rest args) + "Ensure ARG is a list. +If ARG is already a list, return it as is (not a copy). +Otherwise, return a new list with ARG as its only element. + +Another supported calling convention is (-list &rest ARGS). +In this case, if ARG is not a list, a new list with all of +ARGS as elements is returned. This use is supported for +backward compatibility and is otherwise deprecated." + (declare (advertised-calling-convention (arg) "2.18.0") + (pure t) (side-effect-free error-free)) + (if (listp arg) arg (cons arg args))) + +(defun -repeat (n x) + "Return a new list of length N with each element being X. +Return nil if N is less than 1." + (declare (side-effect-free t)) + (and (>= n 0) (make-list n x))) + +(defun -sum (list) + "Return the sum of LIST." + (declare (pure t) (side-effect-free t)) + (apply #'+ list)) + +(defun -running-sum (list) + "Return a list with running sums of items in LIST. +LIST must be non-empty." + (declare (pure t) (side-effect-free t)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'+ list)) + +(defun -product (list) + "Return the product of LIST." + (declare (pure t) (side-effect-free t)) + (apply #'* list)) + +(defun -running-product (list) + "Return a list with running products of items in LIST. +LIST must be non-empty." + (declare (pure t) (side-effect-free t)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'* list)) + +(defun -max (list) + "Return the largest value from LIST of numbers or markers." + (declare (pure t) (side-effect-free t)) + (apply #'max list)) + +(defun -min (list) + "Return the smallest value from LIST of numbers or markers." + (declare (pure t) (side-effect-free t)) + (apply #'min list)) + +(defun -max-by (comparator list) + "Take a comparison function COMPARATOR and a LIST and return +the greatest element of the list by the comparison function. + +See also combinator `-on' which can transform the values before +comparing them." + (declare (important-return-value t)) + (--reduce (if (funcall comparator it acc) it acc) list)) + +(defun -min-by (comparator list) + "Take a comparison function COMPARATOR and a LIST and return +the least element of the list by the comparison function. + +See also combinator `-on' which can transform the values before +comparing them." + (declare (important-return-value t)) + (--reduce (if (funcall comparator it acc) acc it) list)) + +(defmacro --max-by (form list) + "Anaphoric version of `-max-by'. + +The items for the comparator form are exposed as \"it\" and \"other\"." + (declare (debug (def-form form))) + `(-max-by (lambda (it other) (ignore it other) ,form) ,list)) + +(defmacro --min-by (form list) + "Anaphoric version of `-min-by'. + +The items for the comparator form are exposed as \"it\" and \"other\"." + (declare (debug (def-form form))) + `(-min-by (lambda (it other) (ignore it other) ,form) ,list)) + +(defun -iota (count &optional start step) + "Return a list containing COUNT numbers. +Starts from START and adds STEP each time. The default START is +zero, the default STEP is 1. +This function takes its name from the corresponding primitive in +the APL language." + (declare (side-effect-free t)) + (unless (natnump count) + (signal 'wrong-type-argument (list #'natnump count))) + (or start (setq start 0)) + (or step (setq step 1)) + (if (zerop step) + (make-list count start) + (--iterate (+ it step) start count))) + +(defun -fix (fn list) + "Compute the (least) fixpoint of FN with initial input LIST. + +FN is called at least once, results are compared with `equal'." + (declare (important-return-value t)) + (let ((re (funcall fn list))) + (while (not (equal list re)) + (setq list re) + (setq re (funcall fn re))) + re)) + +(defmacro --fix (form list) + "Anaphoric form of `-fix'." + (declare (debug (def-form form))) + `(-fix (lambda (it) (ignore it) ,form) ,list)) + +(defun -unfold (fun seed) + "Build a list from SEED using FUN. + +This is \"dual\" operation to `-reduce-r': while -reduce-r +consumes a list to produce a single value, `-unfold' takes a +seed value and builds a (potentially infinite!) list. + +FUN should return nil to stop the generating process, or a +cons (A . B), where A will be prepended to the result and B is +the new seed." + (declare (important-return-value t)) + (let ((last (funcall fun seed)) r) + (while last + (push (car last) r) + (setq last (funcall fun (cdr last)))) + (nreverse r))) + +(defmacro --unfold (form seed) + "Anaphoric version of `-unfold'." + (declare (debug (def-form form))) + `(-unfold (lambda (it) (ignore it) ,form) ,seed)) + +(defun -cons-pair? (obj) + "Return non-nil if OBJ is a true cons pair. +That is, a cons (A . B) where B is not a list. + +Alias: `-cons-pair-p'." + (declare (pure t) (side-effect-free error-free)) + (nlistp (cdr-safe obj))) + +(defalias '-cons-pair-p '-cons-pair?) + +(defun -cons-to-list (con) + "Convert a cons pair to a list with `car' and `cdr' of the pair respectively." + (declare (pure t) (side-effect-free t)) + (list (car con) (cdr con))) + +(defun -value-to-list (val) + "Convert a value to a list. + +If the value is a cons pair, make a list with two elements, `car' +and `cdr' of the pair respectively. + +If the value is anything else, wrap it in a list." + (declare (pure t) (side-effect-free t)) + (if (-cons-pair? val) (-cons-to-list val) (list val))) + +(defun -tree-mapreduce-from (fn folder init-value tree) + "Apply FN to each element of TREE, and make a list of the results. +If elements of TREE are lists themselves, apply FN recursively to +elements of these nested lists. + +Then reduce the resulting lists using FOLDER and initial value +INIT-VALUE. See `-reduce-r-from'. + +This is the same as calling `-tree-reduce-from' after `-tree-map' +but is twice as fast as it only traverse the structure once." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (-reduce-r-from + folder init-value + (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree))) + ((funcall fn tree)))) + +(defmacro --tree-mapreduce-from (form folder init-value tree) + "Anaphoric form of `-tree-mapreduce-from'." + (declare (debug (def-form def-form form form))) + `(-tree-mapreduce-from (lambda (it) (ignore it) ,form) + (lambda (it acc) (ignore it acc) ,folder) + ,init-value + ,tree)) + +(defun -tree-mapreduce (fn folder tree) + "Apply FN to each element of TREE, and make a list of the results. +If elements of TREE are lists themselves, apply FN recursively to +elements of these nested lists. + +Then reduce the resulting lists using FOLDER and initial value +INIT-VALUE. See `-reduce-r-from'. + +This is the same as calling `-tree-reduce' after `-tree-map' +but is twice as fast as it only traverse the structure once." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree))) + ((funcall fn tree)))) + +(defmacro --tree-mapreduce (form folder tree) + "Anaphoric form of `-tree-mapreduce'." + (declare (debug (def-form def-form form))) + `(-tree-mapreduce (lambda (it) (ignore it) ,form) + (lambda (it acc) (ignore it acc) ,folder) + ,tree)) + +(defun -tree-map (fn tree) + "Apply FN to each element of TREE while preserving the tree structure." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (mapcar (lambda (x) (-tree-map fn x)) tree)) + ((funcall fn tree)))) + +(defmacro --tree-map (form tree) + "Anaphoric form of `-tree-map'." + (declare (debug (def-form form))) + `(-tree-map (lambda (it) (ignore it) ,form) ,tree)) + +(defun -tree-reduce-from (fn init-value tree) + "Use FN to reduce elements of list TREE. +If elements of TREE are lists themselves, apply the reduction recursively. + +FN is first applied to INIT-VALUE and first element of the list, +then on this result and second element from the list etc. + +The initial value is ignored on cons pairs as they always contain +two elements." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) tree) + ((consp tree) + (-reduce-r-from + fn init-value + (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree))) + (tree))) + +(defmacro --tree-reduce-from (form init-value tree) + "Anaphoric form of `-tree-reduce-from'." + (declare (debug (def-form form form))) + `(-tree-reduce-from (lambda (it acc) (ignore it acc) ,form) + ,init-value ,tree)) + +(defun -tree-reduce (fn tree) + "Use FN to reduce elements of list TREE. +If elements of TREE are lists themselves, apply the reduction recursively. + +FN is first applied to first element of the list and second +element, then on this result and third element from the list etc. + +See `-reduce-r' for how exactly are lists of zero or one element handled." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) tree) + ((consp tree) + (-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree))) + (tree))) + +(defmacro --tree-reduce (form tree) + "Anaphoric form of `-tree-reduce'." + (declare (debug (def-form form))) + `(-tree-reduce (lambda (it acc) (ignore it acc) ,form) ,tree)) + +(defun -tree-map-nodes (pred fun tree) + "Call FUN on each node of TREE that satisfies PRED. + +If PRED returns nil, continue descending down this node. If PRED +returns non-nil, apply FUN to this node and do not descend +further." + (cond ((funcall pred tree) (funcall fun tree)) + ((and (listp tree) (listp (cdr tree))) + (-map (lambda (x) (-tree-map-nodes pred fun x)) tree)) + (tree))) + +(defmacro --tree-map-nodes (pred form tree) + "Anaphoric form of `-tree-map-nodes'." + (declare (debug (def-form def-form form))) + `(-tree-map-nodes (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,form) + ,tree)) + +(defun -tree-seq (branch children tree) + "Return a sequence of the nodes in TREE, in depth-first search order. + +BRANCH is a predicate of one argument that returns non-nil if the +passed argument is a branch, that is, a node that can have children. + +CHILDREN is a function of one argument that returns the children +of the passed branch node. + +Non-branch nodes are simply copied." + (declare (important-return-value t)) + (cons tree + (and (funcall branch tree) + (-mapcat (lambda (x) (-tree-seq branch children x)) + (funcall children tree))))) + +(defmacro --tree-seq (branch children tree) + "Anaphoric form of `-tree-seq'." + (declare (debug (def-form def-form form))) + `(-tree-seq (lambda (it) (ignore it) ,branch) + (lambda (it) (ignore it) ,children) + ,tree)) + +(defun -clone (list) + "Create a deep copy of LIST. +The new list has the same elements and structure but all cons are +replaced with new ones. This is useful when you need to clone a +structure such as plist or alist." + (declare (side-effect-free t)) + (-tree-map #'identity list)) + +;;; Combinators + +(defalias '-partial #'apply-partially + "Return a function that is a partial application of FUN to ARGS. +ARGS is a list of the first N arguments to pass to FUN. +The result is a new function which does the same as FUN, except that +the first N arguments are fixed at the values with which this function +was called. +\n(fn FUN &rest ARGS)") + +(defun -rpartial (fn &rest args) + "Return a function that is a partial application of FN to ARGS. +ARGS is a list of the last N arguments to pass to FN. The result +is a new function which does the same as FN, except that the last +N arguments are fixed at the values with which this function was +called. This is like `-partial', except the arguments are fixed +starting from the right rather than the left." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args-before) (apply fn (append args-before args)))) + +(defun -juxt (&rest fns) + "Return a function that is the juxtaposition of FNS. +The returned function takes a variable number of ARGS, applies +each of FNS in turn to ARGS, and returns the list of results." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) (mapcar (lambda (x) (apply x args)) fns))) + +(defun -compose (&rest fns) + "Compose FNS into a single composite function. +Return a function that takes a variable number of ARGS, applies +the last function in FNS to ARGS, and returns the result of +calling each remaining function on the result of the previous +function, right-to-left. If no FNS are given, return a variadic +`identity' function." + (declare (pure t) (side-effect-free error-free)) + (let* ((fns (nreverse fns)) + (head (car fns)) + (tail (cdr fns))) + (cond (tail + (lambda (&rest args) + (--reduce-from (funcall it acc) (apply head args) tail))) + (fns head) + ((lambda (&optional arg &rest _) arg))))) + +(defun -applify (fn) + "Return a function that applies FN to a single list of args. +This changes the arity of FN from taking N distinct arguments to +taking 1 argument which is a list of N arguments." + (declare (pure t) (side-effect-free error-free)) + (lambda (args) (apply fn args))) + +(defun -on (op trans) + "Return a function that calls TRANS on each arg and OP on the results. +The returned function takes a variable number of arguments, calls +the function TRANS on each one in turn, and then passes those +results as the list of arguments to OP, in the same order. + +For example, the following pairs of expressions are morally +equivalent: + + (funcall (-on #\\='+ #\\='1+) 1 2 3) = (+ (1+ 1) (1+ 2) (1+ 3)) + (funcall (-on #\\='+ #\\='1+)) = (+)" + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) + ;; This unrolling seems to be a relatively cheap way to keep the + ;; overhead of `mapcar' + `apply' in check. + (cond ((cddr args) + (apply op (mapcar trans args))) + ((cdr args) + (funcall op (funcall trans (car args)) (funcall trans (cadr args)))) + (args + (funcall op (funcall trans (car args)))) + ((funcall op))))) + +(defun -flip (fn) + "Return a function that calls FN with its arguments reversed. +The returned function takes the same number of arguments as FN. + +For example, the following two expressions are morally +equivalent: + + (funcall (-flip #\\='-) 1 2) = (- 2 1) + +See also: `-rotate-args'." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) ;; Open-code for speed. + (cond ((cddr args) (apply fn (nreverse args))) + ((cdr args) (funcall fn (cadr args) (car args))) + (args (funcall fn (car args))) + ((funcall fn))))) + +(defun -rotate-args (n fn) + "Return a function that calls FN with args rotated N places to the right. +The returned function takes the same number of arguments as FN, +rotates the list of arguments N places to the right (left if N is +negative) just like `-rotate', and applies FN to the result. + +See also: `-flip'." + (declare (pure t) (side-effect-free t)) + (if (zerop n) + fn + (let ((even (= (% n 2) 0))) + (lambda (&rest args) + (cond ((cddr args) ;; Open-code for speed. + (apply fn (-rotate n args))) + ((cdr args) + (let ((fst (car args)) + (snd (cadr args))) + (funcall fn (if even fst snd) (if even snd fst)))) + (args + (funcall fn (car args))) + ((funcall fn))))))) + +(defun -const (c) + "Return a function that returns C ignoring any additional arguments. + +In types: a -> b -> a" + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest _) c)) + +(defmacro -cut (&rest params) + "Take n-ary function and n arguments and specialize some of them. +Arguments denoted by <> will be left unspecialized. + +See SRFI-26 for detailed description." + (declare (debug (&optional sexp &rest &or "<>" form))) + (let* ((i 0) + (args (--keep (when (eq it '<>) + (setq i (1+ i)) + (make-symbol (format "D%d" i))) + params))) + `(lambda ,args + ,(let ((body (--map (if (eq it '<>) (pop args) it) params))) + (if (eq (car params) '<>) + (cons #'funcall body) + body))))) + +(defun -not (pred) + "Return a predicate that negates the result of PRED. +The returned predicate passes its arguments to PRED. If PRED +returns nil, the result is non-nil; otherwise the result is nil. + +See also: `-andfn' and `-orfn'." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) (not (apply pred args)))) + +(defun -orfn (&rest preds) + "Return a predicate that returns the first non-nil result of PREDS. +The returned predicate takes a variable number of arguments, +passes them to each predicate in PREDS in turn until one of them +returns non-nil, and returns that non-nil result without calling +the remaining PREDS. If all PREDS return nil, or if no PREDS are +given, the returned predicate returns nil. + +See also: `-andfn' and `-not'." + (declare (pure t) (side-effect-free error-free)) + ;; Open-code for speed. + (cond ((cdr preds) (lambda (&rest args) (--some (apply it args) preds))) + (preds (car preds)) + (#'ignore))) + +(defun -andfn (&rest preds) + "Return a predicate that returns non-nil if all PREDS do so. +The returned predicate P takes a variable number of arguments and +passes them to each predicate in PREDS in turn. If any one of +PREDS returns nil, P also returns nil without calling the +remaining PREDS. If all PREDS return non-nil, P returns the last +such value. If no PREDS are given, P always returns non-nil. + +See also: `-orfn' and `-not'." + (declare (pure t) (side-effect-free error-free)) + ;; Open-code for speed. + (cond ((cdr preds) (lambda (&rest args) (--every (apply it args) preds))) + (preds (car preds)) + ((static-if (fboundp 'always) + #'always + (lambda (&rest _) t))))) + +(defun -iteratefn (fn n) + "Return a function FN composed N times with itself. + +FN is a unary function. If you need to use a function of higher +arity, use `-applify' first to turn it into a unary function. + +With n = 0, this acts as identity function. + +In types: (a -> a) -> Int -> a -> a. + +This function satisfies the following law: + + (funcall (-iteratefn fn n) init) = (-last-item (-iterate fn init (1+ n)))." + (declare (pure t) (side-effect-free error-free)) + (lambda (x) (--dotimes n (setq x (funcall fn x))) x)) + +(defun -counter (&optional beg end inc) + "Return a closure that counts from BEG to END, with increment INC. + +The closure will return the next value in the counting sequence +each time it is called, and nil after END is reached. BEG +defaults to 0, INC defaults to 1, and if END is nil, the counter +will increment indefinitely. + +The closure accepts any number of arguments, which are discarded." + (declare (pure t) (side-effect-free error-free)) + (let ((inc (or inc 1)) + (n (or beg 0))) + (lambda (&rest _) + (when (or (not end) (< n end)) + (prog1 n + (setq n (+ n inc))))))) + +(defvar -fixfn-max-iterations 1000 + "The default maximum number of iterations performed by `-fixfn' + unless otherwise specified.") + +(defun -fixfn (fn &optional equal-test halt-test) + "Return a function that computes the (least) fixpoint of FN. + +FN must be a unary function. The returned lambda takes a single +argument, X, the initial value for the fixpoint iteration. The +iteration halts when either of the following conditions is satisfied: + + 1. Iteration converges to the fixpoint, with equality being + tested using EQUAL-TEST. If EQUAL-TEST is not specified, + `equal' is used. For functions over the floating point + numbers, it may be necessary to provide an appropriate + approximate comparison test. + + 2. HALT-TEST returns a non-nil value. HALT-TEST defaults to a + simple counter that returns t after `-fixfn-max-iterations', + to guard against infinite iteration. Otherwise, HALT-TEST + must be a function that accepts a single argument, the + current value of X, and returns non-nil as long as iteration + should continue. In this way, a more sophisticated + convergence test may be supplied by the caller. + +The return value of the lambda is either the fixpoint or, if +iteration halted before converging, a cons with car `halted' and +cdr the final output from HALT-TEST. + +In types: (a -> a) -> a -> a." + (declare (important-return-value t)) + (let ((eqfn (or equal-test 'equal)) + (haltfn (or halt-test + (-not + (-counter 0 -fixfn-max-iterations))))) + (lambda (x) + (let ((re (funcall fn x)) + (halt? (funcall haltfn x))) + (while (and (not halt?) (not (funcall eqfn x re))) + (setq x re + re (funcall fn re) + halt? (funcall haltfn re))) + (if halt? (cons 'halted halt?) + re))))) + +(defun -prodfn (&rest fns) + "Return a function that applies each of FNS to each of a list of arguments. + +Takes a list of N functions and returns a function that takes a +list of length N, applying Ith function to Ith element of the +input list. Returns a list of length N. + +In types (for N=2): ((a -> b), (c -> d)) -> (a, c) -> (b, d) + +This function satisfies the following laws: + + (-compose (-prodfn f g ...) + (-prodfn f\\=' g\\=' ...)) + = (-prodfn (-compose f f\\=') + (-compose g g\\=') + ...) + + (-prodfn f g ...) + = (-juxt (-compose f (-partial #\\='nth 0)) + (-compose g (-partial #\\='nth 1)) + ...) + + (-compose (-prodfn f g ...) + (-juxt f\\=' g\\=' ...)) + = (-juxt (-compose f f\\=') + (-compose g g\\=') + ...) + + (-compose (-partial #\\='nth n) + (-prod f1 f2 ...)) + = (-compose fn (-partial #\\='nth n))" + (declare (pure t) (side-effect-free t)) + (lambda (x) (--zip-with (funcall it other) fns x))) + +;;; Font lock + +(defvar dash--keywords + `(;; TODO: Do not fontify the following automatic variables + ;; globally; detect and limit to their local anaphoric scope. + (,(rx symbol-start (| "acc" "it" "it-index" "other") symbol-end) + . 'font-lock-variable-name-face) + ;; Macros in dev/examples.el. Based on `lisp-mode-symbol-regexp'. + (,(rx ?\( (group (| "defexamples" "def-example-group")) symbol-end + (+ (in "\t ")) + (group (* (| (syntax word) (syntax symbol) (: ?\\ nonl))))) + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face)) + ;; Symbols in dev/examples.el. + ,(rx symbol-start (| "=>" "~>" "!!>") symbol-end) + ;; Elisp macro fontification was static prior to Emacs 25. + ,@(when (< emacs-major-version 25) + (let ((macs '("!cdr" + "!cons" + "-->" + "--all-p" + "--all?" + "--annotate" + "--any" + "--any-p" + "--any?" + "--count" + "--dotimes" + "--doto" + "--drop-while" + "--each" + "--each-indexed" + "--each-r" + "--each-r-while" + "--each-while" + "--every" + "--every-p" + "--every?" + "--filter" + "--find" + "--find-index" + "--find-indices" + "--find-last-index" + "--first" + "--fix" + "--group-by" + "--if-let" + "--iterate" + "--keep" + "--last" + "--map" + "--map-first" + "--map-indexed" + "--map-last" + "--map-when" + "--mapcat" + "--max-by" + "--min-by" + "--none-p" + "--none?" + "--only-some-p" + "--only-some?" + "--partition-after-pred" + "--partition-by" + "--partition-by-header" + "--reduce" + "--reduce-from" + "--reduce-r" + "--reduce-r-from" + "--reductions" + "--reductions-from" + "--reductions-r" + "--reductions-r-from" + "--reject" + "--reject-first" + "--reject-last" + "--remove" + "--remove-first" + "--remove-last" + "--replace-where" + "--select" + "--separate" + "--some" + "--some-p" + "--some?" + "--sort" + "--splice" + "--splice-list" + "--split-when" + "--split-with" + "--take-while" + "--tree-map" + "--tree-map-nodes" + "--tree-mapreduce" + "--tree-mapreduce-from" + "--tree-reduce" + "--tree-reduce-from" + "--tree-seq" + "--unfold" + "--update-at" + "--when-let" + "--zip-with" + "->" + "->>" + "-as->" + "-cut" + "-doto" + "-if-let" + "-if-let*" + "-lambda" + "-let" + "-let*" + "-setq" + "-some-->" + "-some->" + "-some->>" + "-split-on" + "-when-let" + "-when-let*"))) + `((,(concat "(" (regexp-opt macs 'symbols)) . 1))))) + "Font lock keywords for `dash-fontify-mode'.") + +(defcustom dash-fontify-mode-lighter nil + "Mode line lighter for `dash-fontify-mode'. +Either a string to display in the mode line when +`dash-fontify-mode' is on, or nil to display +nothing (the default)." + :package-version '(dash . "2.18.0") + :type '(choice (string :tag "Lighter" :value " Dash") + (const :tag "Nothing" nil))) + +;;;###autoload +(define-minor-mode dash-fontify-mode + "Toggle fontification of Dash special variables. + +Dash-Fontify mode is a buffer-local minor mode intended for Emacs +Lisp buffers. Enabling it causes the special variables bound in +anaphoric Dash macros to be fontified. These anaphoras include +`it', `it-index', `acc', and `other'. In older Emacs versions +which do not dynamically detect macros, Dash-Fontify mode +additionally fontifies Dash macro calls. + +See also `dash-fontify-mode-lighter' and +`global-dash-fontify-mode'." + :lighter dash-fontify-mode-lighter + (if dash-fontify-mode + (font-lock-add-keywords nil dash--keywords t) + (font-lock-remove-keywords nil dash--keywords)) + (static-if (fboundp 'font-lock-flush) + ;; Added in Emacs 25. + (font-lock-flush) + (when font-lock-mode + ;; Unconditionally enables `font-lock-mode' and is marked + ;; `interactive-only' in later Emacs versions which have + ;; `font-lock-flush'. + (font-lock-fontify-buffer)))) + +(defun dash--turn-on-fontify-mode () + "Enable `dash-fontify-mode' if in an Emacs Lisp buffer." + (when (derived-mode-p #'emacs-lisp-mode) + (dash-fontify-mode))) + +;;;###autoload +(define-globalized-minor-mode global-dash-fontify-mode + dash-fontify-mode dash--turn-on-fontify-mode) + +(defcustom dash-enable-fontlock nil + "If non-nil, fontify Dash macro calls and special variables." + :set (lambda (sym val) + (set-default sym val) + (global-dash-fontify-mode (if val 1 0))) + :type 'boolean) + +(make-obsolete-variable + 'dash-enable-fontlock #'global-dash-fontify-mode "2.18.0") + +(define-obsolete-function-alias + 'dash-enable-font-lock #'global-dash-fontify-mode "2.18.0") + +;;; Info + +(defvar dash--info-doc-spec '("(dash) Index" nil "^ -+ .*: " "\\( \\|$\\)") + "The Dash :doc-spec entry for `info-lookup-alist'. +It is based on that for `emacs-lisp-mode'.") + +(defun dash--info-elisp-docs () + "Return the `emacs-lisp-mode' symbol docs from `info-lookup-alist'. +Specifically, return the cons containing their +`info-lookup->doc-spec' so that we can modify it." + (defvar info-lookup-alist) + (nthcdr 3 (assq #'emacs-lisp-mode (cdr (assq 'symbol info-lookup-alist))))) + +;;;###autoload +(defun dash-register-info-lookup () + "Register the Dash Info manual with `info-lookup-symbol'. +This allows Dash symbols to be looked up with \\[info-lookup-symbol]." + (interactive) + (require 'info-look) + (let ((docs (dash--info-elisp-docs))) + (setcar docs (append (car docs) (list dash--info-doc-spec))) + (info-lookup-reset))) + +(defun dash-unload-function () + "Remove Dash from `info-lookup-alist'. +Used by `unload-feature', which see." + (let ((docs (and (featurep 'info-look) + (dash--info-elisp-docs)))) + (when (member dash--info-doc-spec (car docs)) + (setcar docs (remove dash--info-doc-spec (car docs))) + (info-lookup-reset))) + nil) + +(provide 'dash) +;;; dash.el ends here diff --git a/.config/emacs/lisp/libs/dash.elc b/.config/emacs/lisp/libs/dash.elc new file mode 100644 index 0000000..eb21655 Binary files /dev/null and b/.config/emacs/lisp/libs/dash.elc differ diff --git a/.config/emacs/lisp/libs/elisp-refs.el b/.config/emacs/lisp/libs/elisp-refs.el new file mode 100644 index 0000000..21b3546 --- /dev/null +++ b/.config/emacs/lisp/libs/elisp-refs.el @@ -0,0 +1,913 @@ +;;; elisp-refs.el --- find callers of elisp functions or macros -*- lexical-binding: t; -*- + +;; Copyright (C) 2016-2020 Wilfred Hughes + +;; Author: Wilfred Hughes +;; Version: 1.6 +;; Keywords: lisp +;; Package-Requires: ((dash "2.12.0") (s "1.11.0")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; elisp-refs.el is an Emacs package for finding references to +;; functions, macros or variables. Unlike a dumb text search, +;; elisp-refs.el actually parses the code, so it's never confused by +;; comments or `foo-bar' matching `foo'. +;; +;; See https://github.com/Wilfred/refs.el/blob/master/README.md for +;; more information. + +;;; Code: + +(require 'dash) +(require 's) +(require 'format) +(eval-when-compile (require 'cl-lib)) + +(defvar symbols-with-pos-enabled) +(declare-function symbol-with-pos-p nil (object)) +(declare-function symbol-with-pos-pos nil (ls)) + +;;; Internal + +(defvar elisp-refs-verbose t) + +(defun elisp-refs--format-int (integer) + "Format INTEGER as a string, with , separating thousands." + (let ((number (abs integer)) + (parts nil)) + (while (> number 999) + (push (format "%03d" (mod number 1000)) + parts) + (setq number (/ number 1000))) + (push (format "%d" number) parts) + (concat + (if (< integer 0) "-" "") + (s-join "," parts)))) + +(defsubst elisp-refs--start-pos (end-pos) + "Find the start position of form ending at END-POS +in the current buffer." + (let ((parse-sexp-ignore-comments t)) + (scan-sexps end-pos -1))) + +(defun elisp-refs--sexp-positions (buffer start-pos end-pos) + "Return a list of start and end positions of all the sexps +between START-POS and END-POS (inclusive) in BUFFER. + +Positions exclude quote characters, so given 'foo or `foo, we +report the position of the symbol foo. + +Not recursive, so we don't consider subelements of nested sexps." + (let ((positions nil)) + (with-current-buffer buffer + (condition-case _err + (catch 'done + (while t + (let* ((sexp-end-pos (let ((parse-sexp-ignore-comments t)) + (scan-sexps start-pos 1)))) + ;; If we've reached a sexp beyond the range requested, + ;; or if there are no sexps left, we're done. + (when (or (null sexp-end-pos) (> sexp-end-pos end-pos)) + (throw 'done nil)) + ;; Otherwise, this sexp is in the range requested. + (push (list (elisp-refs--start-pos sexp-end-pos) sexp-end-pos) + positions) + (setq start-pos sexp-end-pos)))) + ;; Terminate when we see "Containing expression ends prematurely" + (scan-error nil))) + (nreverse positions))) + +(defun elisp-refs--read-buffer-form (symbols-with-pos) + "Read a form from the current buffer, starting at point. +Returns a list: +\(form form-start-pos form-end-pos symbol-positions read-start-pos) + +In Emacs 28 and earlier, SYMBOL-POSITIONS is a list of 0-indexed +symbol positions relative to READ-START-POS, according to +`read-symbol-positions-list'. + +In Emacs 29+, SYMBOL-POSITIONS is nil. If SYMBOLS-WITH-POS is +non-nil, forms are read with `read-positioning-symbols'." + (let* ((read-with-symbol-positions t) + (read-start-pos (point)) + (form (if (and symbols-with-pos (fboundp 'read-positioning-symbols)) + (read-positioning-symbols (current-buffer)) + (read (current-buffer)))) + (symbols (if (boundp 'read-symbol-positions-list) + read-symbol-positions-list + nil)) + (end-pos (point)) + (start-pos (elisp-refs--start-pos end-pos))) + (list form start-pos end-pos symbols read-start-pos))) + +(defvar elisp-refs--path nil + "A buffer-local variable used by `elisp-refs--contents-buffer'. +Internal implementation detail.") + +(defun elisp-refs--read-all-buffer-forms (buffer symbols-with-pos) + "Read all the forms in BUFFER, along with their positions." + (with-current-buffer buffer + (goto-char (point-min)) + (let ((forms nil)) + (condition-case err + (while t + (push (elisp-refs--read-buffer-form symbols-with-pos) forms)) + (error + (if (or (equal (car err) 'end-of-file) + ;; TODO: this shouldn't occur in valid elisp files, + ;; but it's happening in helm-utils.el. + (equal (car err) 'scan-error)) + ;; Reached end of file, we're done. + (nreverse forms) + ;; Some unexpected error, propagate. + (error "Unexpected error whilst reading %s position %s: %s" + (abbreviate-file-name elisp-refs--path) (point) err))))))) + +(defun elisp-refs--proper-list-p (val) + "Is VAL a proper list?" + (if (fboundp 'proper-list-p) + ;; `proper-list-p' was added in Emacs 27.1. + ;; http://git.savannah.gnu.org/cgit/emacs.git/commit/?id=2fde6275b69fd113e78243790bf112bbdd2fe2bf + (with-no-warnings (proper-list-p val)) + ;; Earlier Emacs versions only had format-proper-list-p. + (with-no-warnings (format-proper-list-p val)))) + +(defun elisp-refs--walk (buffer form start-pos end-pos symbol match-p &optional path) + "Walk FORM, a nested list, and return a list of sublists (with +their positions) where MATCH-P returns t. FORM is traversed +depth-first (pre-order traversal, left-to-right). + +MATCH-P is called with three arguments: +\(SYMBOL CURRENT-FORM PATH). + +PATH is the first element of all the enclosing forms of +CURRENT-FORM, innermost first, along with the index of the +current form. + +For example if we are looking at h in (e f (g h)), PATH takes the +value ((g . 1) (e . 2)). + +START-POS and END-POS should be the position of FORM within BUFFER." + (cond + ((funcall match-p symbol form path) + ;; If this form matches, just return it, along with the position. + (list (list form start-pos end-pos))) + ;; Otherwise, recurse on the subforms. + ((consp form) + (let ((matches nil) + ;; Find the positions of the subforms. + (subforms-positions + (if (eq (car-safe form) '\`) + ;; Kludge: `elisp-refs--sexp-positions' excludes the ` when + ;; calculating positions. So, to find the inner + ;; positions when walking from `(...) to (...), we + ;; don't need to increment the start position. + (cons nil (elisp-refs--sexp-positions buffer start-pos end-pos)) + ;; Calculate the positions after the opening paren. + (elisp-refs--sexp-positions buffer (1+ start-pos) end-pos)))) + ;; For each subform, recurse if it's a list, or a matching symbol. + (--each (-zip-pair form subforms-positions) + (-let [(subform subform-start subform-end) it] + (when (or + (and (consp subform) (elisp-refs--proper-list-p subform)) + (and (symbolp subform) (eq subform symbol))) + (-when-let (subform-matches + (elisp-refs--walk + buffer subform + subform-start subform-end + symbol match-p + (cons (cons (car-safe form) it-index) path))) + (push subform-matches matches))))) + + ;; Concat the results from all the subforms. + (apply #'append (nreverse matches)))))) + +;; TODO: condition-case (condition-case ... (error ...)) is not a call +;; TODO: (cl-destructuring-bind (foo &rest bar) ...) is not a call +;; TODO: letf, cl-letf, -let, -let* +(defun elisp-refs--function-p (symbol form path) + "Return t if FORM looks like a function call to SYMBOL." + (cond + ((not (consp form)) + nil) + ;; Ignore (defun _ (SYMBOL ...) ...) + ((or (equal (car path) '(defsubst . 2)) + (equal (car path) '(defun . 2)) + (equal (car path) '(defmacro . 2)) + (equal (car path) '(cl-defun . 2))) + nil) + ;; Ignore (lambda (SYMBOL ...) ...) + ((equal (car path) '(lambda . 1)) + nil) + ;; Ignore (let (SYMBOL ...) ...) + ;; and (let* (SYMBOL ...) ...) + ((or + (equal (car path) '(let . 1)) + (equal (car path) '(let* . 1))) + nil) + ;; Ignore (let ((SYMBOL ...)) ...) + ((or + (equal (cl-second path) '(let . 1)) + (equal (cl-second path) '(let* . 1))) + nil) + ;; Ignore (declare-function NAME (ARGS...)) + ((equal (car path) '(declare-function . 3)) + nil) + ;; (SYMBOL ...) + ((eq (car form) symbol) + t) + ;; (foo ... #'SYMBOL ...) + ((--any-p (equal it (list 'function symbol)) form) + t) + ;; (funcall 'SYMBOL ...) + ((and (eq (car form) 'funcall) + (equal `',symbol (cl-second form))) + t) + ;; (apply 'SYMBOL ...) + ((and (eq (car form) 'apply) + (equal `',symbol (cl-second form))) + t))) + +(defun elisp-refs--macro-p (symbol form path) + "Return t if FORM looks like a macro call to SYMBOL." + (cond + ((not (consp form)) + nil) + ;; Ignore (defun _ (SYMBOL ...) ...) + ((or (equal (car path) '(defsubst . 2)) + (equal (car path) '(defun . 2)) + (equal (car path) '(defmacro . 2))) + nil) + ;; Ignore (lambda (SYMBOL ...) ...) + ((equal (car path) '(lambda . 1)) + nil) + ;; Ignore (let (SYMBOL ...) ...) + ;; and (let* (SYMBOL ...) ...) + ((or + (equal (car path) '(let . 1)) + (equal (car path) '(let* . 1))) + nil) + ;; Ignore (let ((SYMBOL ...)) ...) + ((or + (equal (cl-second path) '(let . 1)) + (equal (cl-second path) '(let* . 1))) + nil) + ;; (SYMBOL ...) + ((eq (car form) symbol) + t))) + +;; Looking for a special form is exactly the same as looking for a +;; macro. +(defalias 'elisp-refs--special-p 'elisp-refs--macro-p) + +(defun elisp-refs--variable-p (symbol form path) + "Return t if this looks like a variable reference to SYMBOL. +We consider parameters to be variables too." + (cond + ((consp form) + nil) + ;; Ignore (defun _ (SYMBOL ...) ...) + ((or (equal (car path) '(defsubst . 1)) + (equal (car path) '(defun . 1)) + (equal (car path) '(defmacro . 1)) + (equal (car path) '(cl-defun . 1))) + nil) + ;; (let (SYMBOL ...) ...) is a variable, not a function call. + ((or + (equal (cl-second path) '(let . 1)) + (equal (cl-second path) '(let* . 1))) + t) + ;; (lambda (SYMBOL ...) ...) is a variable + ((equal (cl-second path) '(lambda . 1)) + t) + ;; (let ((SYMBOL ...)) ...) is also a variable. + ((or + (equal (cl-third path) '(let . 1)) + (equal (cl-third path) '(let* . 1))) + t) + ;; Ignore (SYMBOL ...) otherwise, we assume it's a function/macro + ;; call. + ((equal (car path) (cons symbol 0)) + nil) + ((eq form symbol) + t))) + +;; TODO: benchmark building a list with `push' rather than using +;; mapcat. +(defun elisp-refs--read-and-find (buffer symbol match-p) + "Read all the forms in BUFFER, and return a list of all forms that +contain SYMBOL where MATCH-P returns t. + +For every matching form found, we return the form itself along +with its start and end position." + (-non-nil + (--mapcat + (-let [(form start-pos end-pos symbol-positions _read-start-pos) it] + ;; Optimisation: if we have a list of positions for the current + ;; form (Emacs 28 and earlier), and it doesn't contain the + ;; symbol we're looking for, don't bother walking the form. + (when (or (null symbol-positions) (assq symbol symbol-positions)) + (elisp-refs--walk buffer form start-pos end-pos symbol match-p))) + (elisp-refs--read-all-buffer-forms buffer nil)))) + +(defun elisp-refs--walk-positioned-symbols (forms symbol) + "Given a nested list of FORMS, return a list of all positions of SYMBOL. +Assumes `symbol-with-pos-pos' is defined (Emacs 29+)." + (cond + ((symbol-with-pos-p forms) + (let ((symbols-with-pos-enabled t)) + (if (eq forms symbol) + (list (list symbol + (symbol-with-pos-pos forms) + (+ (symbol-with-pos-pos forms) (length (symbol-name symbol)))))))) + ((elisp-refs--proper-list-p forms) + ;; Proper list, use `--mapcat` to reduce how much we recurse. + (--mapcat (elisp-refs--walk-positioned-symbols it symbol) forms)) + ((consp forms) + ;; Improper list, we have to recurse on head and tail. + (append (elisp-refs--walk-positioned-symbols (car forms) symbol) + (elisp-refs--walk-positioned-symbols (cdr forms) symbol))) + ((vectorp forms) + (--mapcat (elisp-refs--walk-positioned-symbols it symbol) forms)))) + +(defun elisp-refs--read-and-find-symbol (buffer symbol) + "Read all the forms in BUFFER, and return a list of all +positions of SYMBOL." + (let* ((symbols-with-pos (fboundp 'symbol-with-pos-pos)) + (forms (elisp-refs--read-all-buffer-forms buffer symbols-with-pos))) + + (if symbols-with-pos + (elisp-refs--walk-positioned-symbols forms symbol) + (-non-nil + (--mapcat + (-let [(_ _ _ symbol-positions read-start-pos) it] + (--map + (-let [(sym . offset) it] + (when (eq sym symbol) + (-let* ((start-pos (+ read-start-pos offset)) + (end-pos (+ start-pos (length (symbol-name sym))))) + (list sym start-pos end-pos)))) + symbol-positions)) + forms))))) + +(defun elisp-refs--filter-obarray (pred) + "Return a list of all the items in `obarray' where PRED returns t." + (let (symbols) + (mapatoms (lambda (symbol) + (when (and (funcall pred symbol) + (not (equal (symbol-name symbol) ""))) + (push symbol symbols)))) + symbols)) + +(defun elisp-refs--loaded-paths () + "Return a list of all files that have been loaded in Emacs. +Where the file was a .elc, return the path to the .el file instead." + (let ((elc-paths (-non-nil (mapcar #'-first-item load-history)))) + (-non-nil + (--map + (let ((el-name (format "%s.el" (file-name-sans-extension it))) + (el-gz-name (format "%s.el.gz" (file-name-sans-extension it)))) + (cond ((file-exists-p el-name) el-name) + ((file-exists-p el-gz-name) el-gz-name) + ;; Ignore files where we can't find a .el file. + (t nil))) + elc-paths)))) + +(defun elisp-refs--contents-buffer (path) + "Read PATH into a disposable buffer, and return it. +Works around the fact that Emacs won't allow multiple buffers +visiting the same file." + (let ((fresh-buffer (generate-new-buffer (format " *refs-%s*" path))) + ;; Be defensive against users overriding encoding + ;; configurations (Helpful bugs #75 and #147). + (coding-system-for-read nil) + (file-name-handler-alist + '(("\\(?:\\.dz\\|\\.txz\\|\\.xz\\|\\.lzma\\|\\.lz\\|\\.g?z\\|\\.\\(?:tgz\\|svgz\\|sifz\\)\\|\\.tbz2?\\|\\.bz2\\|\\.Z\\)\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)?\\'" . + jka-compr-handler) + ("\\(?:^/\\)\\(\\(?:\\(?:\\(-\\|[[:alnum:]]\\{2,\\}\\)\\(?::\\)\\(?:\\([^/:|[:blank:]]+\\)\\(?:@\\)\\)?\\(\\(?:[%._[:alnum:]-]+\\|\\(?:\\[\\)\\(?:\\(?:[[:alnum:]]*:\\)+[.[:alnum:]]*\\)?\\(?:]\\)\\)\\(?:\\(?:#\\)\\(?:[[:digit:]]+\\)\\)?\\)?\\)\\(?:|\\)\\)+\\)?\\(?:\\(-\\|[[:alnum:]]\\{2,\\}\\)\\(?::\\)\\(?:\\([^/:|[:blank:]]+\\)\\(?:@\\)\\)?\\(\\(?:[%._[:alnum:]-]+\\|\\(?:\\[\\)\\(?:\\(?:[[:alnum:]]*:\\)+[.[:alnum:]]*\\)?\\(?:]\\)\\)\\(?:\\(?:#\\)\\(?:[[:digit:]]+\\)\\)?\\)?\\)\\(?::\\)\\([^\n ]*\\'\\)" . tramp-file-name-handler) + ("\\`/:" . file-name-non-special)))) + (with-current-buffer fresh-buffer + (setq-local elisp-refs--path path) + (insert-file-contents path) + ;; We don't enable emacs-lisp-mode because it slows down this + ;; function significantly. We just need the syntax table for + ;; scan-sexps to do the right thing with comments. + (set-syntax-table emacs-lisp-mode-syntax-table)) + fresh-buffer)) + +(defvar elisp-refs--highlighting-buffer + nil + "A temporary buffer used for highlighting. +Since `elisp-refs--syntax-highlight' is a hot function, we +don't want to create lots of temporary buffers.") + +(defun elisp-refs--syntax-highlight (str) + "Apply font-lock properties to a string STR of Emacs lisp code." + ;; Ensure we have a highlighting buffer to work with. + (unless (and elisp-refs--highlighting-buffer + (buffer-live-p elisp-refs--highlighting-buffer)) + (setq elisp-refs--highlighting-buffer + (generate-new-buffer " *refs-highlighting*")) + (with-current-buffer elisp-refs--highlighting-buffer + (delay-mode-hooks (emacs-lisp-mode)))) + + (with-current-buffer elisp-refs--highlighting-buffer + (erase-buffer) + (insert str) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings + (font-lock-fontify-buffer))) + (buffer-string))) + +(defun elisp-refs--replace-tabs (string) + "Replace tabs in STRING with spaces." + ;; This is important for unindenting, as we may unindent by less + ;; than one whole tab. + (s-replace "\t" (s-repeat tab-width " ") string)) + +(defun elisp-refs--lines (string) + "Return a list of all the lines in STRING. +'a\nb' -> ('a\n' 'b')" + (let ((lines nil)) + (while (> (length string) 0) + (let ((index (s-index-of "\n" string))) + (if index + (progn + (push (substring string 0 (1+ index)) lines) + (setq string (substring string (1+ index)))) + (push string lines) + (setq string "")))) + (nreverse lines))) + +(defun elisp-refs--map-lines (string fn) + "Execute FN for each line in string, and join the result together." + (let ((result nil)) + (dolist (line (elisp-refs--lines string)) + (push (funcall fn line) result)) + (apply #'concat (nreverse result)))) + +(defun elisp-refs--unindent-rigidly (string) + "Given an indented STRING, unindent rigidly until +at least one line has no indent. + +STRING should have a 'elisp-refs-start-pos property. The returned +string will have this property updated to reflect the unindent." + (let* ((lines (s-lines string)) + ;; Get the leading whitespace for each line. + (indents (--map (car (s-match (rx bos (+ whitespace)) it)) + lines)) + (min-indent (-min (--map (length it) indents)))) + (propertize + (elisp-refs--map-lines + string + (lambda (line) (substring line min-indent))) + 'elisp-refs-unindented min-indent))) + +(defun elisp-refs--containing-lines (buffer start-pos end-pos) + "Return a string, all the lines in BUFFER that are between +START-POS and END-POS (inclusive). + +For the characters that are between START-POS and END-POS, +propertize them." + (let (expanded-start-pos expanded-end-pos) + (with-current-buffer buffer + ;; Expand START-POS and END-POS to line boundaries. + (goto-char start-pos) + (beginning-of-line) + (setq expanded-start-pos (point)) + (goto-char end-pos) + (end-of-line) + (setq expanded-end-pos (point)) + + ;; Extract the rest of the line before and after the section we're interested in. + (let* ((before-match (buffer-substring expanded-start-pos start-pos)) + (after-match (buffer-substring end-pos expanded-end-pos)) + ;; Concat the extra text with the actual match, ensuring we + ;; highlight the match as code, but highlight the rest as as + ;; comments. + (text (concat + (propertize before-match + 'face 'font-lock-comment-face) + (elisp-refs--syntax-highlight (buffer-substring start-pos end-pos)) + (propertize after-match + 'face 'font-lock-comment-face)))) + (-> text + (elisp-refs--replace-tabs) + (elisp-refs--unindent-rigidly) + (propertize 'elisp-refs-start-pos expanded-start-pos + 'elisp-refs-path elisp-refs--path)))))) + +(defun elisp-refs--find-file (button) + "Open the file referenced by BUTTON." + (find-file (button-get button 'path)) + (goto-char (point-min))) + +(define-button-type 'elisp-refs-path-button + 'action 'elisp-refs--find-file + 'follow-link t + 'help-echo "Open file") + +(defun elisp-refs--path-button (path) + "Return a button that navigates to PATH." + (with-temp-buffer + (insert-text-button + (abbreviate-file-name path) + :type 'elisp-refs-path-button + 'path path) + (buffer-string))) + +(defun elisp-refs--describe (button) + "Show *Help* for the symbol referenced by BUTTON." + (let ((symbol (button-get button 'symbol)) + (kind (button-get button 'kind))) + (cond ((eq kind 'symbol) + (describe-symbol symbol)) + ((eq kind 'variable) + (describe-variable symbol)) + (t + ;; Emacs uses `describe-function' for functions, macros and + ;; special forms. + (describe-function symbol))))) + +(define-button-type 'elisp-refs-describe-button + 'action 'elisp-refs--describe + 'follow-link t + 'help-echo "Describe") + +(defun elisp-refs--describe-button (symbol kind) + "Return a button that shows *Help* for SYMBOL. +KIND should be 'function, 'macro, 'variable, 'special or 'symbol." + (with-temp-buffer + (insert (symbol-name kind) " ") + (insert-text-button + (symbol-name symbol) + :type 'elisp-refs-describe-button + 'symbol symbol + 'kind kind) + (buffer-string))) + +(defun elisp-refs--pluralize (number thing) + "Human-friendly description of NUMBER occurrences of THING." + (format "%s %s%s" + (elisp-refs--format-int number) + thing + (if (equal number 1) "" "s"))) + +(defun elisp-refs--format-count (symbol ref-count file-count + searched-file-count prefix) + (let* ((file-str (if (zerop file-count) + "" + (format " in %s" (elisp-refs--pluralize file-count "file")))) + (found-str (format "Found %s to %s%s." + (elisp-refs--pluralize ref-count "reference") + symbol + file-str)) + (searched-str (if prefix + (format "Searched %s in %s." + (elisp-refs--pluralize searched-file-count "loaded file") + (elisp-refs--path-button (file-name-as-directory prefix))) + (format "Searched all %s loaded in Emacs." + (elisp-refs--pluralize searched-file-count "file"))))) + (s-word-wrap 70 (format "%s %s" found-str searched-str)))) + +;; TODO: if we have multiple matches on one line, we repeatedly show +;; that line. That's slightly confusing. +(defun elisp-refs--show-results (symbol description results + searched-file-count prefix) + "Given a RESULTS list where each element takes the form \(forms . buffer\), +render a friendly results buffer." + (let ((buf (get-buffer-create (format "*refs: %s*" symbol)))) + (switch-to-buffer buf) + (let ((inhibit-read-only t)) + (erase-buffer) + (save-excursion + ;; Insert the header. + (insert + (elisp-refs--format-count + description + (-sum (--map (length (car it)) results)) + (length results) + searched-file-count + prefix) + "\n\n") + ;; Insert the results. + (--each results + (-let* (((forms . buf) it) + (path (with-current-buffer buf elisp-refs--path))) + (insert + (propertize "File: " 'face 'bold) + (elisp-refs--path-button path) "\n") + (--each forms + (-let [(_ start-pos end-pos) it] + (insert (elisp-refs--containing-lines buf start-pos end-pos) + "\n"))) + (insert "\n"))) + ;; Prepare the buffer for the user. + (elisp-refs-mode))) + ;; Cleanup buffers created when highlighting results. + (when elisp-refs--highlighting-buffer + (kill-buffer elisp-refs--highlighting-buffer)))) + +(defun elisp-refs--loaded-bufs () + "Return a list of open buffers, one for each path in `load-path'." + (mapcar #'elisp-refs--contents-buffer (elisp-refs--loaded-paths))) + +(defun elisp-refs--search-1 (bufs match-fn) + "Call MATCH-FN on each buffer in BUFS, reporting progress +and accumulating results. + +BUFS should be disposable: we make no effort to preserve their +state during searching. + +MATCH-FN should return a list where each element takes the form: +\(form start-pos end-pos)." + (let* (;; Our benchmark suggests we spend a lot of time in GC, and + ;; performance improves if we GC less frequently. + (gc-cons-percentage 0.8) + (total-bufs (length bufs))) + (let ((searched 0) + (forms-and-bufs nil)) + (dolist (buf bufs) + (let* ((matching-forms (funcall match-fn buf))) + ;; If there were any matches in this buffer, push the + ;; matches along with the buffer into our results + ;; list. + (when matching-forms + (push (cons matching-forms buf) forms-and-bufs)) + ;; Give feedback to the user on our progress, because + ;; searching takes several seconds. + (when (and (zerop (mod searched 10)) + elisp-refs-verbose) + (message "Searched %s/%s files" searched total-bufs)) + (cl-incf searched))) + (when elisp-refs-verbose + (message "Searched %s/%s files" total-bufs total-bufs)) + forms-and-bufs))) + +(defun elisp-refs--search (symbol description match-fn &optional path-prefix) + "Find references to SYMBOL in all loaded files; call MATCH-FN on each buffer. +When PATH-PREFIX, limit to loaded files whose path starts with that prefix. + +Display the results in a hyperlinked buffer. + +MATCH-FN should return a list where each element takes the form: +\(form start-pos end-pos)." + (let* ((loaded-paths (elisp-refs--loaded-paths)) + (matching-paths (if path-prefix + (--filter (s-starts-with? path-prefix it) loaded-paths) + loaded-paths)) + (loaded-src-bufs (mapcar #'elisp-refs--contents-buffer matching-paths))) + ;; Use unwind-protect to ensure we always cleanup temporary + ;; buffers, even if the user hits C-g. + (unwind-protect + (progn + (let ((forms-and-bufs + (elisp-refs--search-1 loaded-src-bufs match-fn))) + (elisp-refs--show-results symbol description forms-and-bufs + (length loaded-src-bufs) path-prefix))) + ;; Clean up temporary buffers. + (--each loaded-src-bufs (kill-buffer it))))) + +(defun elisp-refs--completing-read-symbol (prompt &optional filter) + "Read an interned symbol from the minibuffer, +defaulting to the symbol at point. PROMPT is the string to prompt +with. + +If FILTER is given, only offer symbols where (FILTER sym) returns +t." + (let ((filter (or filter (lambda (_) t)))) + (read + (completing-read prompt + (elisp-refs--filter-obarray filter) + nil nil nil nil + (-if-let (sym (thing-at-point 'symbol)) + (when (funcall filter (read sym)) + sym)))))) + +;;; Commands + +;;;###autoload +(defun elisp-refs-function (symbol &optional path-prefix) + "Display all the references to function SYMBOL, in all loaded +elisp files. + +If called with a prefix, prompt for a directory to limit the search. + +This searches for functions, not macros. For that, see +`elisp-refs-macro'." + (interactive + (list (elisp-refs--completing-read-symbol "Function: " #'functionp) + (when current-prefix-arg + (read-directory-name "Limit search to loaded files in: ")))) + (when (not (functionp symbol)) + (if (macrop symbol) + (user-error "%s is a macro. Did you mean elisp-refs-macro?" + symbol) + (user-error "%s is not a function. Did you mean elisp-refs-symbol?" + symbol))) + (elisp-refs--search symbol + (elisp-refs--describe-button symbol 'function) + (lambda (buf) + (elisp-refs--read-and-find buf symbol #'elisp-refs--function-p)) + path-prefix)) + +;;;###autoload +(defun elisp-refs-macro (symbol &optional path-prefix) + "Display all the references to macro SYMBOL, in all loaded +elisp files. + +If called with a prefix, prompt for a directory to limit the search. + +This searches for macros, not functions. For that, see +`elisp-refs-function'." + (interactive + (list (elisp-refs--completing-read-symbol "Macro: " #'macrop) + (when current-prefix-arg + (read-directory-name "Limit search to loaded files in: ")))) + (when (not (macrop symbol)) + (if (functionp symbol) + (user-error "%s is a function. Did you mean elisp-refs-function?" + symbol) + (user-error "%s is not a function. Did you mean elisp-refs-symbol?" + symbol))) + (elisp-refs--search symbol + (elisp-refs--describe-button symbol 'macro) + (lambda (buf) + (elisp-refs--read-and-find buf symbol #'elisp-refs--macro-p)) + path-prefix)) + +;;;###autoload +(defun elisp-refs-special (symbol &optional path-prefix) + "Display all the references to special form SYMBOL, in all loaded +elisp files. + +If called with a prefix, prompt for a directory to limit the search." + (interactive + (list (elisp-refs--completing-read-symbol "Special form: " #'special-form-p) + (when current-prefix-arg + (read-directory-name "Limit search to loaded files in: ")))) + (elisp-refs--search symbol + (elisp-refs--describe-button symbol 'special-form) + (lambda (buf) + (elisp-refs--read-and-find buf symbol #'elisp-refs--special-p)) + path-prefix)) + +;;;###autoload +(defun elisp-refs-variable (symbol &optional path-prefix) + "Display all the references to variable SYMBOL, in all loaded +elisp files. + +If called with a prefix, prompt for a directory to limit the search." + (interactive + ;; This is awkward. We don't want to just offer defvar variables, + ;; because then we can't search for code which uses `let' to bind + ;; symbols. There doesn't seem to be a good way to only offer + ;; variables that have been bound at some point. + (list (elisp-refs--completing-read-symbol "Variable: " ) + (when current-prefix-arg + (read-directory-name "Limit search to loaded files in: ")))) + (elisp-refs--search symbol + (elisp-refs--describe-button symbol 'variable) + (lambda (buf) + (elisp-refs--read-and-find buf symbol #'elisp-refs--variable-p)) + path-prefix)) + +;;;###autoload +(defun elisp-refs-symbol (symbol &optional path-prefix) + "Display all the references to SYMBOL in all loaded elisp files. + +If called with a prefix, prompt for a directory to limit the +search." + (interactive + (list (elisp-refs--completing-read-symbol "Symbol: " ) + (when current-prefix-arg + (read-directory-name "Limit search to loaded files in: ")))) + (elisp-refs--search symbol + (elisp-refs--describe-button symbol 'symbol) + (lambda (buf) + (elisp-refs--read-and-find-symbol buf symbol)) + path-prefix)) + +;;; Mode + +(defvar elisp-refs-mode-map + (let ((map (make-sparse-keymap))) + ;; TODO: it would be nice for TAB to navigate to file buttons too, + ;; like *Help* does. + (set-keymap-parent map special-mode-map) + (define-key map (kbd "") #'elisp-refs-next-match) + (define-key map (kbd "") #'elisp-refs-prev-match) + (define-key map (kbd "n") #'elisp-refs-next-match) + (define-key map (kbd "p") #'elisp-refs-prev-match) + (define-key map (kbd "RET") #'elisp-refs-visit-match) + map) + "Keymap for `elisp-refs-mode'.") + +(define-derived-mode elisp-refs-mode special-mode "Refs" + "Major mode for refs results buffers.") + +(defun elisp--refs-visit-match (open-fn) + "Go to the search result at point. +Open file with function OPEN_FN. `find-file` or `find-file-other-window`" + (interactive) + (let* ((path (get-text-property (point) 'elisp-refs-path)) + (pos (get-text-property (point) 'elisp-refs-start-pos)) + (unindent (get-text-property (point) 'elisp-refs-unindented)) + (column-offset (current-column)) + (line-offset -1)) + (when (null path) + (user-error "No match here")) + + ;; If point is not on the first line of the match, work out how + ;; far away the first line is. + (save-excursion + (while (equal pos (get-text-property (point) 'elisp-refs-start-pos)) + (forward-line -1) + (cl-incf line-offset))) + + (funcall open-fn path) + (goto-char pos) + ;; Move point so we're on the same char in the buffer that we were + ;; on in the results buffer. + (forward-line line-offset) + (beginning-of-line) + (let ((target-offset (+ column-offset unindent)) + (i 0)) + (while (< i target-offset) + (if (looking-at "\t") + (cl-incf i tab-width) + (cl-incf i)) + (forward-char 1))))) + +(defun elisp-refs-visit-match () + "Goto the search result at point." + (interactive) + (elisp--refs-visit-match #'find-file)) + +(defun elisp-refs-visit-match-other-window () + "Goto the search result at point, opening in another window." + (interactive) + (elisp--refs-visit-match #'find-file-other-window)) + + +(defun elisp-refs--move-to-match (direction) + "Move point one match forwards. +If DIRECTION is -1, moves backwards instead." + (let* ((start-pos (point)) + (match-pos (get-text-property start-pos 'elisp-refs-start-pos)) + current-match-pos) + (condition-case _err + (progn + ;; Move forward/backwards until we're on the next/previous match. + (catch 'done + (while t + (setq current-match-pos + (get-text-property (point) 'elisp-refs-start-pos)) + (when (and current-match-pos + (not (equal match-pos current-match-pos))) + (throw 'done nil)) + (forward-char direction))) + ;; Move to the beginning of that match. + (while (equal (get-text-property (point) 'elisp-refs-start-pos) + (get-text-property (1- (point)) 'elisp-refs-start-pos)) + (forward-char -1)) + ;; Move forward until we're on the first char of match within that + ;; line. + (while (or + (looking-at " ") + (eq (get-text-property (point) 'face) + 'font-lock-comment-face)) + (forward-char 1))) + ;; If we're at the last result, don't move point. + (end-of-buffer + (progn + (goto-char start-pos) + (signal 'end-of-buffer nil)))))) + +(defun elisp-refs-prev-match () + "Move to the previous search result in the Refs buffer." + (interactive) + (elisp-refs--move-to-match -1)) + +(defun elisp-refs-next-match () + "Move to the next search result in the Refs buffer." + (interactive) + (elisp-refs--move-to-match 1)) + +(provide 'elisp-refs) +;;; elisp-refs.el ends here diff --git a/.config/emacs/lisp/libs/elisp-refs.elc b/.config/emacs/lisp/libs/elisp-refs.elc new file mode 100644 index 0000000..168e116 Binary files /dev/null and b/.config/emacs/lisp/libs/elisp-refs.elc differ diff --git a/.config/emacs/lisp/libs/f.el b/.config/emacs/lisp/libs/f.el new file mode 100644 index 0000000..1ab08d7 --- /dev/null +++ b/.config/emacs/lisp/libs/f.el @@ -0,0 +1,799 @@ +;;; f.el --- Modern API for working with files and directories -*- lexical-binding: t; -*- + +;; Copyright (C) 2013 Johan Andersson + +;; Author: Johan Andersson +;; Maintainer: Lucien Cartier-Tilet +;; Version: 0.21.0 +;; Package-Requires: ((emacs "24.1") (s "1.7.0") (dash "2.2.0")) +;; Keywords: files, directories +;; Homepage: http://github.com/rejeep/f.el + +;; This file is NOT part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; Much inspired by magnar's excellent s.el and dash.el, f.el is a +;; modern API for working with files and directories in Emacs. + +;;; Code: + + + +(require 's) +(require 'dash) +(when (version<= "28.1" emacs-version) + (when (< emacs-major-version 29) + (require 'f-shortdoc nil t))) + +(put 'f-guard-error 'error-conditions '(error f-guard-error)) +(put 'f-guard-error 'error-message "Destructive operation outside sandbox") + +(defvar f--guard-paths nil + "List of allowed paths to modify when guarded. + +Do not modify this variable.") + +(defmacro f--destructive (path &rest body) + "If PATH is allowed to be modified, yield BODY. + +If PATH is not allowed to be modified, throw error." + (declare (indent 1)) + `(if f--guard-paths + (if (--any? (or (f-same-p it ,path) + (f-ancestor-of-p it ,path)) f--guard-paths) + (progn ,@body) + (signal 'f-guard-error (list ,path f--guard-paths))) + ,@body)) + + +;;;; Paths + +(defun f-join (&rest args) + "Join ARGS to a single path. + +Be aware if one of the arguments is an absolute path, `f-join' +will discard all the preceeding arguments and make this absolute +path the new root of the generated path." + (let (path + (relative (f-relative-p (car args)))) + (mapc + (lambda (arg) + (setq path (cond ((not path) arg) + ((f-absolute-p arg) + (progn + (setq relative nil) + arg)) + (t (f-expand arg path))))) + args) + (if relative (f-relative path) path))) + +(defun f-split (path) + "Split PATH and return list containing parts." + (let ((parts (split-string path (f-path-separator) 'omit-nulls))) + (if (string= (s-left 1 path) (f-path-separator)) + (push (f-path-separator) parts) + parts))) + +(defun f-expand (path &optional dir) + "Expand PATH relative to DIR (or `default-directory'). +PATH and DIR can be either a directory names or directory file +names. Return a directory name if PATH is a directory name, and +a directory file name otherwise. File name handlers are +ignored." + (let (file-name-handler-alist) + (expand-file-name path dir))) + +(defun f-filename (path) + "Return the name of PATH." + (file-name-nondirectory (directory-file-name path))) + +(defalias 'f-parent 'f-dirname) + +(defun f-dirname (path) + "Return the parent directory to PATH." + (let ((parent (file-name-directory + (directory-file-name (f-expand path default-directory))))) + (unless (f-same-p path parent) + (if (f-relative-p path) + (f-relative parent) + (directory-file-name parent))))) + +(defun f-common-parent (paths) + "Return the deepest common parent directory of PATHS." + (cond + ((not paths) nil) + ((not (cdr paths)) (f-parent (car paths))) + (:otherwise + (let* ((paths (-map 'f-split paths)) + (common (caar paths)) + (re nil)) + (while (and (not (null (car paths))) (--all? (equal (car it) common) paths)) + (setq paths (-map 'cdr paths)) + (push common re) + (setq common (caar paths))) + (cond + ((null re) "") + ((and (= (length re) 1) (f-root-p (car re))) + (f-root)) + (:otherwise + (concat (apply 'f-join (nreverse re)) "/"))))))) + +(defalias 'f-ext 'file-name-extension) + +(defalias 'f-no-ext 'file-name-sans-extension) + +(defun f-swap-ext (path ext) + "Return PATH but with EXT as the new extension. +EXT must not be nil or empty." + (if (s-blank-p ext) + (error "Extension cannot be empty or nil") + (concat (f-no-ext path) "." ext))) + +(defun f-base (path) + "Return the name of PATH, excluding the extension of file." + (f-no-ext (f-filename path))) + +(defalias 'f-relative 'file-relative-name) + +(defalias 'f-short 'abbreviate-file-name) +(defalias 'f-abbrev 'abbreviate-file-name) + +(defun f-long (path) + "Return long version of PATH." + (f-expand path)) + +(defalias 'f-canonical 'file-truename) + +(defun f-slash (path) + "Append slash to PATH unless one already. + +Some functions, such as `call-process' requires there to be an +ending slash." + (if (f-dir-p path) + (file-name-as-directory path) + path)) + +(defun f-full (path) + "Return absolute path to PATH, with ending slash." + (f-slash (f-long path))) + +(defun f--uniquify (paths) + "Helper for `f-uniquify' and `f-uniquify-alist'." + (let* ((files-length (length paths)) + (uniq-filenames (--map (cons it (f-filename it)) paths)) + (uniq-filenames-next (-group-by 'cdr uniq-filenames))) + (while (/= files-length (length uniq-filenames-next)) + (setq uniq-filenames-next + (-group-by 'cdr + (--mapcat + (let ((conf-files (cdr it))) + (if (> (length conf-files) 1) + (--map (cons + (car it) + (concat + (f-filename (s-chop-suffix (cdr it) + (car it))) + (f-path-separator) (cdr it))) + conf-files) + conf-files)) + uniq-filenames-next)))) + uniq-filenames-next)) + +(defun f-uniquify (files) + "Return unique suffixes of FILES. + +This function expects no duplicate paths." + (-map 'car (f--uniquify files))) + +(defun f-uniquify-alist (files) + "Return alist mapping FILES to unique suffixes of FILES. + +This function expects no duplicate paths." + (-map 'cadr (f--uniquify files))) + + +;;;; I/O + +(defun f-read-bytes (path &optional beg end) + "Read binary data from PATH. + +Return the binary data as unibyte string. The optional second +and third arguments BEG and END specify what portion of the file +to read." + (with-temp-buffer + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (insert-file-contents-literally path nil beg end) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defalias 'f-read 'f-read-text) +(defun f-read-text (path &optional coding) + "Read text with PATH, using CODING. + +CODING defaults to `utf-8'. + +Return the decoded text as multibyte string." + (decode-coding-string (f-read-bytes path) (or coding 'utf-8))) + +(defalias 'f-write 'f-write-text) +(defun f-write-text (text coding path) + "Write TEXT with CODING to PATH. + +TEXT is a multibyte string. CODING is a coding system to encode +TEXT with. PATH is a file name to write to." + (f-write-bytes (encode-coding-string text coding) path)) + +(defun f-unibyte-string-p (s) + "Determine whether S is a unibyte string." + (not (multibyte-string-p s))) + +(defun f-write-bytes (data path) + "Write binary DATA to PATH. + +DATA is a unibyte string. PATH is a file name to write to." + (f--write-bytes data path nil)) + +(defalias 'f-append 'f-append-text) +(defun f-append-text (text coding path) + "Append TEXT with CODING to PATH. + +If PATH does not exist, it is created." + (f-append-bytes (encode-coding-string text coding) path)) + +(defun f-append-bytes (data path) + "Append binary DATA to PATH. + +If PATH does not exist, it is created." + (f--write-bytes data path :append)) + +(defun f--write-bytes (data filename append) + "Write binary DATA to FILENAME. +If APPEND is non-nil, append the DATA to the existing contents." + (f--destructive filename + (unless (f-unibyte-string-p data) + (signal 'wrong-type-argument (list 'f-unibyte-string-p data))) + (let ((coding-system-for-write 'binary) + (write-region-annotate-functions nil) + (write-region-post-annotation-function nil)) + (write-region data nil filename append :silent) + nil))) + + +;;;; Destructive + +(defun f-mkdir (&rest dirs) + "Create directories DIRS. + +DIRS should be a successive list of directories forming together +a full path. The easiest way to call this function with a fully +formed path is using `f-split' alongside it: + + (apply #\\='f-mkdir (f-split \"path/to/file\")) + +Although it works sometimes, it is not recommended to use fully +formed paths in the function. In this case, it is recommended to +use `f-mkdir-full-path' instead." + (let (path) + (-each + dirs + (lambda (dir) + (setq path (f-expand dir path)) + (unless (f-directory-p path) + (f--destructive path (make-directory path))))))) + +(defun f-mkdir-full-path (dir) + "Create DIR from a full path. + +This function is similar to `f-mkdir' except it can accept a full +path instead of requiring several successive directory names." + (apply #'f-mkdir (f-split dir))) + +(defun f-delete (path &optional force) + "Delete PATH, which can be file or directory. + +If FORCE is t, a directory will be deleted recursively." + (f--destructive path + (if (or (f-file-p path) (f-symlink-p path)) + (delete-file path) + (delete-directory path force)))) + +(defun f-symlink (source path) + "Create a symlink to SOURCE from PATH." + (f--destructive path (make-symbolic-link source path))) + +(defun f-move (from to) + "Move or rename FROM to TO. +If TO is a directory name, move FROM into TO." + (f--destructive to (rename-file from to t))) + +(defun f-copy (from to) + "Copy file or directory FROM to TO. +If FROM names a directory and TO is a directory name, copy FROM +into TO as a subdirectory." + (f--destructive to + (if (f-file-p from) + (copy-file from to) + ;; The behavior of `copy-directory' differs between Emacs 23 and + ;; 24 in that in Emacs 23, the contents of `from' is copied to + ;; `to', while in Emacs 24 the directory `from' is copied to + ;; `to'. We want the Emacs 24 behavior. + (if (> emacs-major-version 23) + (copy-directory from to) + (if (f-dir-p to) + (progn + (apply 'f-mkdir (f-split to)) + (let ((new-to (f-expand (f-filename from) to))) + (copy-directory from new-to))) + (copy-directory from to)))))) + +(defun f-copy-contents (from to) + "Copy contents in directory FROM, to directory TO." + (unless (f-exists-p to) + (error "Cannot copy contents to non existing directory %s" to)) + (unless (f-dir-p from) + (error "Cannot copy contents as %s is a file" from)) + (--each (f-entries from) + (f-copy it (file-name-as-directory to)))) + +(defun f-touch (path) + "Update PATH last modification date or create if it does not exist." + (f--destructive path + (if (f-file-p path) + (set-file-times path) + (f-write-bytes "" path)))) + + +;;;; Predicates + +(defalias 'f-exists-p 'file-exists-p) +(defalias 'f-exists? 'file-exists-p) + +(defalias 'f-directory-p 'file-directory-p) +(defalias 'f-directory? 'file-directory-p) +(defalias 'f-dir-p 'file-directory-p) +(defalias 'f-dir? 'file-directory-p) + + +(defalias 'f-file-p 'file-regular-p) +(defalias 'f-file? 'file-regular-p) + +(defun f-symlink-p (path) + "Return t if PATH is symlink, false otherwise." + (not (not (file-symlink-p path)))) + +(defalias 'f-symlink? 'f-symlink-p) + +(defalias 'f-readable-p 'file-readable-p) +(defalias 'f-readable? 'file-readable-p) + +(defalias 'f-writable-p 'file-writable-p) +(defalias 'f-writable? 'file-writable-p) + +(defalias 'f-executable-p 'file-executable-p) +(defalias 'f-executable? 'file-executable-p) + +(defalias 'f-absolute-p 'file-name-absolute-p) +(defalias 'f-absolute? 'file-name-absolute-p) + +(defun f-relative-p (path) + "Return t if PATH is relative, false otherwise." + (not (f-absolute-p path))) + +(defalias 'f-relative? 'f-relative-p) + +(defun f-root-p (path) + "Return t if PATH is root directory, false otherwise." + (not (f-parent path))) + +(defalias 'f-root? 'f-root-p) + +(defun f-ext-p (path &optional ext) + "Return t if extension of PATH is EXT, false otherwise. + +If EXT is nil or omitted, return t if PATH has any extension, +false otherwise. + +The extension, in a file name, is the part that follows the last +'.', excluding version numbers and backup suffixes." + (if ext + (string= (f-ext path) ext) + (not (eq (f-ext path) nil)))) + +(defalias 'f-ext? 'f-ext-p) + +(defalias 'f-equal-p 'f-same-p) +(defalias 'f-equal? 'f-same-p) + +(defun f-same-p (path-a path-b) + "Return t if PATH-A and PATH-B are references to same file." + (equal + (f-canonical (directory-file-name (f-expand path-a))) + (f-canonical (directory-file-name (f-expand path-b))))) + +(defalias 'f-same? 'f-same-p) + +(defun f-parent-of-p (path-a path-b) + "Return t if PATH-A is parent of PATH-B." + (--when-let (f-parent path-b) + (f-same-p path-a it))) + +(defalias 'f-parent-of? 'f-parent-of-p) + +(defun f-child-of-p (path-a path-b) + "Return t if PATH-A is child of PATH-B." + (--when-let (f-parent path-a) + (f-same-p it path-b))) + +(defalias 'f-child-of? 'f-child-of-p) + +(defun f-ancestor-of-p (path-a path-b) + "Return t if PATH-A is ancestor of PATH-B." + (unless (f-same-p path-a path-b) + (string-prefix-p (f-full path-a) + (f-full path-b)))) + +(defalias 'f-ancestor-of? 'f-ancestor-of-p) + +(defun f-descendant-of-p (path-a path-b) + "Return t if PATH-A is desendant of PATH-B." + (unless (f-same-p path-a path-b) + (let ((path-a (f-split (f-full path-a))) + (path-b (f-split (f-full path-b))) + (parent-p t)) + (while (and path-b parent-p) + (if (string= (car path-a) (car path-b)) + (setq path-a (cdr path-a) + path-b (cdr path-b)) + (setq parent-p nil))) + parent-p))) + +(defalias 'f-descendant-of? 'f-descendant-of-p) + +(defun f-hidden-p (path &optional behavior) + "Return t if PATH is hidden, nil otherwise. + +BEHAVIOR controls when a path should be considered as hidden +depending on its value. Beware, if PATH begins with \"./\", the +current dir \".\" will not be considered as hidden. + +When BEHAVIOR is nil, it will only check if the path begins with +a dot, as in .a/b/c, and return t if there is one. This is the +old behavior of f.el left as default for backward-compatibility +purposes. + +When BEHAVIOR is ANY, return t if any of the elements of PATH is +hidden, nil otherwise. + +When BEHAVIOR is LAST, return t only if the last element of PATH +is hidden, nil otherwise. + +TODO: Hidden directories and files on Windows are marked +differently than on *NIX systems. This should be properly +implemented." + (let ((split-path (f-split path)) + (check-hidden (lambda (elt) + (and (string= (substring elt 0 1) ".") + (not (member elt '("." ".."))))))) + (pcase behavior + ('any (-any check-hidden split-path)) + ('last (apply check-hidden (last split-path))) + (otherwise (if (null otherwise) + (funcall check-hidden (car split-path)) + (error "Invalid value %S for argument BEHAVIOR" otherwise)))))) + +(defalias 'f-hidden? 'f-hidden-p) + +(defun f-empty-p (path) + "If PATH is a file, return t if the file in PATH is empty, nil otherwise. +If PATH is directory, return t if directory has no files, nil otherwise." + (if (f-directory-p path) + (equal (f-files path nil t) nil) + (= (f-size path) 0))) + +(defalias 'f-empty? 'f-empty-p) + + +;;;; Stats + +(defun f-size (path) + "Return size of PATH. + +If PATH is a file, return size of that file. If PATH is +directory, return sum of all files in PATH." + (if (f-directory-p path) + (-sum (-map 'f-size (f-files path nil t))) + (nth 7 (file-attributes path)))) + +(defun f-depth (path) + "Return the depth of PATH. + +At first, PATH is expanded with `f-expand'. Then the full path is used to +detect the depth. +'/' will be zero depth, '/usr' will be one depth. And so on." + (- (length (f-split (f-expand path))) 1)) + +;; For Emacs 28 and below, forward-declare ‘current-time-list’, which was +;; introduced in Emacs 29. +(defvar current-time-list) + +(defun f--get-time (path timestamp-p fn) + "Helper function, get time-related information for PATH. +Helper for `f-change-time', `f-modification-time', +`f-access-time'. It is meant to be called internally, avoid +calling it manually unless you have to. + +If TIMESTAMP-P is non-nil, return the date requested as a +timestamp. If the value is \\='seconds, return the timestamp as +a timestamp with a one-second precision. Otherwise, the +timestamp is returned in a (TICKS . HZ) format, see +`current-time' if using Emacs 29 or newer. + +Otherwise, if TIMESTAMP-P is nil, return the default style of +`current-time'. + +FN is the function specified by the caller function to retrieve +the correct data from PATH." + (let* ((current-time-list (not timestamp-p)) + (date (apply fn (list (file-attributes path)))) + (emacs29-or-newer-p (version<= "29" emacs-version))) + (cond + ((and (eq timestamp-p 'seconds) emacs29-or-newer-p) + (/ (car date) (cdr date))) + ((or (and (not (eq timestamp-p 'seconds)) emacs29-or-newer-p) + (and (not timestamp-p) (not emacs29-or-newer-p))) + date) + ((and (eq timestamp-p 'seconds) (not emacs29-or-newer-p)) + (+ (* (nth 0 date) (expt 2 16)) + (nth 1 date))) + ((and timestamp-p (not emacs29-or-newer-p)) + `(,(+ (* (nth 0 date) (expt 2 16) 1000) + (* (nth 1 date) 1000) + (nth 3 date)) + . 1000))))) + +(defun f-change-time (path &optional timestamp-p) + "Return the last status change time of PATH. + +The status change time (ctime) of PATH in the same format as +`current-time'. For details on TIMESTAMP-P and the format of the +returned value, see `f--get-time'." + (f--get-time path + timestamp-p + (if (fboundp 'file-attribute-status-change-time) + #'file-attribute-status-change-time + (lambda (f) (nth 6 f))))) + +(defun f-modification-time (path &optional timestamp-p) + "Return the last modification time of PATH. +The modification time (mtime) of PATH in the same format as +`current-time'. For details on TIMESTAMP-P and the format of the +returned value, see `f--get-time'." + (f--get-time path + timestamp-p + (if (fboundp 'file-attribute-modification-time) + #'file-attribute-modification-time + (lambda (f) (nth 5 f))))) + +(defun f-access-time (path &optional timestamp-p) + "Return the last access time of PATH. +The access time (atime) of PATH is in the same format as +`current-time'. For details on TIMESTAMP-P and the format of the +returned value, see `f--get-time'." + (f--get-time path + timestamp-p + (if (fboundp 'file-attribute-access-time) + #'file-attribute-access-time + (lambda (f) (nth 4 f))))) + +(defun f--three-way-compare (a b) + "Three way comparison. + +Return -1 if A < B. +Return 0 if A = B. +Return 1 if A > B." + (cond ((< a b) -1) + ((= a b) 0) + ((> a b) 1))) + +;; TODO: How to properly test this function? +(defun f--date-compare (file other method) + "Three-way comparison of the date of FILE and OTHER. + +This function can return three values: +* 1 means FILE is newer than OTHER +* 0 means FILE and NEWER share the same date +* -1 means FILE is older than OTHER + +The statistics used for the date comparison depends on METHOD. +When METHOD is null, compare their modification time. Otherwise, +compare their change time when METHOD is \\='change, or compare +their last access time when METHOD is \\='access." + (let* ((fn-method (cond + ((eq 'change method) #'f-change-time) + ((eq 'access method) #'f-access-time) + ((null method) #'f-modification-time) + (t (error "Unknown method %S" method)))) + (date-file (apply fn-method (list file))) + (date-other (apply fn-method (list other))) + (dates (-zip-pair date-file date-other))) + (-reduce-from (lambda (acc elt) + (if (= acc 0) + (f--three-way-compare (car elt) (cdr elt)) + acc)) + 0 + dates))) + +(defun f-older-p (file other &optional method) + "Compare if FILE is older than OTHER. + +For more info on METHOD, see `f--date-compare'." + (< (f--date-compare file other method) 0)) + +(defalias 'f-older? #'f-older-p) + +(defun f-newer-p (file other &optional method) + "Compare if FILE is newer than OTHER. + +For more info on METHOD, see `f--date-compare'." + (> (f--date-compare file other method) 0)) + +(defalias 'f-newer? #'f-newer-p) + +(defun f-same-time-p (file other &optional method) + "Check if FILE and OTHER share the same access or modification time. + +For more info on METHOD, see `f--date-compare'." + (= (f--date-compare file other method) 0)) + +(defalias 'f-same-time? #'f-same-time-p) + + +;;;; Misc + +(defun f-this-file () + "Return path to this file." + (cond + (load-in-progress load-file-name) + ((and (boundp 'byte-compile-current-file) byte-compile-current-file) + byte-compile-current-file) + (:else (buffer-file-name)))) + +(defvar f--path-separator nil + "A variable to cache result of `f-path-separator'.") + +(defun f-path-separator () + "Return path separator." + (or f--path-separator + (setq f--path-separator (substring (f-join "x" "y") 1 2)))) + +(defun f-glob (pattern &optional path) + "Find PATTERN in PATH." + (file-expand-wildcards + (f-join (or path default-directory) pattern))) + +(defun f--collect-entries (path recursive) + (let (result + (entries + (-reject + (lambda (file) + (member (f-filename file) '("." ".."))) + (directory-files path t)))) + (cond (recursive + (mapc + (lambda (entry) + (if (f-file-p entry) + (setq result (cons entry result)) + (when (f-directory-p entry) + (setq result (cons entry result)) + (if (f-readable-p entry) + (setq result (append result (f--collect-entries entry recursive))) + result)))) + entries)) + (t (setq result entries))) + result)) + +(defmacro f--entries (path body &optional recursive) + "Anaphoric version of `f-entries'." + `(f-entries + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-entries (path &optional fn recursive) + "Find all files and directories in PATH. + +FN - called for each found file and directory. If FN returns a thruthy +value, file or directory will be included. +RECURSIVE - Search for files and directories recursive." + (let ((entries (f--collect-entries path recursive))) + (if fn (-select fn entries) entries))) + +(defmacro f--directories (path body &optional recursive) + "Anaphoric version of `f-directories'." + `(f-directories + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-directories (path &optional fn recursive) + "Find all directories in PATH. See `f-entries'." + (let ((directories (-select 'f-directory-p (f--collect-entries path recursive)))) + (if fn (-select fn directories) directories))) + +(defmacro f--files (path body &optional recursive) + "Anaphoric version of `f-files'." + `(f-files + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-files (path &optional fn recursive) + "Find all files in PATH. See `f-entries'." + (let ((files (-select 'f-file-p (f--collect-entries path recursive)))) + (if fn (-select fn files) files))) + +(defmacro f--traverse-upwards (body &optional path) + "Anaphoric version of `f-traverse-upwards'." + `(f-traverse-upwards + (lambda (dir) + (let ((it dir)) + ,body)) + ,path)) + +(defun f-traverse-upwards (fn &optional path) + "Traverse up as long as FN return nil, starting at PATH. + +If FN returns a non-nil value, the path sent as argument to FN is +returned. If no function callback return a non-nil value, nil is +returned." + (unless path + (setq path default-directory)) + (when (f-relative-p path) + (setq path (f-expand path))) + (if (funcall fn path) + path + (unless (f-root-p path) + (f-traverse-upwards fn (f-parent path))))) + +(defun f-root () + "Return absolute root." + (f-traverse-upwards 'f-root-p)) + +(defmacro f-with-sandbox (path-or-paths &rest body) + "Only allow PATH-OR-PATHS and descendants to be modified in BODY." + (declare (indent 1)) + `(let ((paths (if (listp ,path-or-paths) + ,path-or-paths + (list ,path-or-paths)))) + (unwind-protect + (let ((f--guard-paths paths)) + ,@body) + (setq f--guard-paths nil)))) + +(provide 'f) + +;;; f.el ends here diff --git a/.config/emacs/lisp/libs/f.elc b/.config/emacs/lisp/libs/f.elc new file mode 100644 index 0000000..b2f72b0 Binary files /dev/null and b/.config/emacs/lisp/libs/f.elc differ diff --git a/.config/emacs/lisp/libs/ht.el b/.config/emacs/lisp/libs/ht.el new file mode 100644 index 0000000..a85f9ff --- /dev/null +++ b/.config/emacs/lisp/libs/ht.el @@ -0,0 +1,354 @@ +;;; ht.el --- The missing hash table library for Emacs -*- lexical-binding: t; -*- + +;; Copyright (C) 2013 Wilfred Hughes + +;; Author: Wilfred Hughes +;; Version: 2.4 +;; Keywords: hash table, hash map, hash +;; Package-Requires: ((dash "2.12.0")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The missing hash table library for Emacs. +;; +;; See documentation at https://github.com/Wilfred/ht.el + +;;; Code: + +(require 'dash) +(require 'gv) +(eval-when-compile + (require 'inline)) + +(defmacro ht (&rest pairs) + "Create a hash table with the key-value pairs given. +Keys are compared with `equal'. + +\(fn (KEY-1 VALUE-1) (KEY-2 VALUE-2) ...)" + (let* ((table-symbol (make-symbol "ht-temp")) + (assignments + (mapcar + (lambda (pair) `(ht-set! ,table-symbol ,@pair)) + pairs))) + `(let ((,table-symbol (ht-create))) + ,@assignments + ,table-symbol))) + +(define-inline ht-set! (table key value) + "Associate KEY in TABLE with VALUE." + (inline-quote + (prog1 nil + (puthash ,key ,value ,table)))) + +(defalias 'ht-set 'ht-set!) + +(define-inline ht-create (&optional test) + "Create an empty hash table. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (declare (side-effect-free t)) + (inline-quote (make-hash-table :test (or ,test 'equal)))) + +(defun ht<-alist (alist &optional test) + "Create a hash table with initial values according to ALIST. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (declare (side-effect-free t)) + (let ((h (ht-create test))) + ;; the first key-value pair in an alist gets precedence, so we + ;; start from the end of the list: + (dolist (pair (reverse alist) h) + (let ((key (car pair)) + (value (cdr pair))) + (ht-set! h key value))))) + +(defalias 'ht-from-alist 'ht<-alist) + +(defun ht<-plist (plist &optional test) + "Create a hash table with initial values according to PLIST. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (declare (side-effect-free t)) + (let ((h (ht-create test))) + (dolist (pair (nreverse (-partition 2 plist)) h) + (let ((key (car pair)) + (value (cadr pair))) + (ht-set! h key value))))) + +(defalias 'ht-from-plist 'ht<-plist) + +(define-inline ht-get (table key &optional default) + "Look up KEY in TABLE, and return the matching value. +If KEY isn't present, return DEFAULT (nil if not specified)." + (declare (side-effect-free t)) + (inline-quote + (gethash ,key ,table ,default))) + +;; Don't use `ht-set!' here, gv setter was assumed to return the value +;; to be set. +(gv-define-setter ht-get (value table key) `(puthash ,key ,value ,table)) + +(define-inline ht-get* (table &rest keys) + "Look up KEYS in nested hash tables, starting with TABLE. +The lookup for each key should return another hash table, except +for the final key, which may return any value." + (declare (side-effect-free t)) + (inline-letevals (table keys) + (inline-quote + (progn + (while ,keys + (setf ,table (ht-get ,table (pop ,keys)))) + ,table)))) + +(put 'ht-get* 'compiler-macro + (lambda (_ table &rest keys) + (--reduce-from `(ht-get ,acc ,it) table keys))) + +(defun ht-update! (table from-table) + "Update TABLE according to every key-value pair in FROM-TABLE." + (maphash + (lambda (key value) (puthash key value table)) + from-table) + nil) + +(defalias 'ht-update 'ht-update!) + +(define-inline ht-update-with! (table key updater &optional default) + "Update the value of KEY in TABLE with UPDATER. +If the value does not exist, do nothing, unless DEFAULT is +non-nil, in which case act as if the value is DEFAULT. + +UPDATER receives one argument, the value, and its return value +becomes the new value of KEY." + (inline-quote + (let* ((not-found-symbol (make-symbol "ht--not-found")) + (v (gethash ,key ,table + (or ,default not-found-symbol)))) + (unless (eq v not-found-symbol) + (prog1 nil + (puthash ,key (funcall ,updater v) ,table)))))) + +(defun ht-merge (&rest tables) + "Crete a new table that includes all the key-value pairs from TABLES. +If multiple tables have the same key, the value in the last +table is used." + (let ((merged (ht-create))) + (mapc (lambda (table) (ht-update! merged table)) tables) + merged)) + +(define-inline ht-remove! (table key) + "Remove KEY from TABLE." + (inline-quote (remhash ,key ,table))) + +(defalias 'ht-remove 'ht-remove!) + +(define-inline ht-clear! (table) + "Remove all keys from TABLE." + (inline-quote + (prog1 nil + (clrhash ,table)))) + +(defalias 'ht-clear 'ht-clear!) + +(defun ht-map (function table) + "Apply FUNCTION to each key-value pair of TABLE, and make a list of the results. +FUNCTION is called with two arguments, KEY and VALUE." + (let (results) + (maphash + (lambda (key value) + (push (funcall function key value) results)) + table) + results)) + +(defmacro ht-amap (form table) + "Anaphoric version of `ht-map'. +For every key-value pair in TABLE, evaluate FORM with the +variables KEY and VALUE bound. If you don't use both of +these variables, then use `ht-map' to avoid warnings." + `(ht-map (lambda (key value) ,form) ,table)) + +(defun ht-keys (table) + "Return a list of all the keys in TABLE." + (declare (side-effect-free t)) + (ht-map (lambda (key _value) key) table)) + +(defun ht-values (table) + "Return a list of all the values in TABLE." + (declare (side-effect-free t)) + (ht-map (lambda (_key value) value) table)) + +(defun ht-items (table) + "Return a list of two-element lists \\='(key value) from TABLE." + (declare (side-effect-free t)) + (ht-amap (list key value) table)) + +(defalias 'ht-each 'maphash + "Apply FUNCTION to each key-value pair of TABLE. +Returns nil, used for side-effects only.") + +(defmacro ht-aeach (form table) + "Anaphoric version of `ht-each'. +For every key-value pair in TABLE, evaluate FORM with the +variables key and value bound." + `(ht-each (lambda (key value) ,form) ,table)) + +(defun ht-select-keys (table keys) + "Return a copy of TABLE with only the specified KEYS." + (declare (side-effect-free t)) + (let ((not-found-symbol (make-symbol "ht--not-found")) + result) + (setq result (make-hash-table :test (hash-table-test table))) + (dolist (key keys result) + (if (not (equal (gethash key table not-found-symbol) not-found-symbol)) + (puthash key (gethash key table) result))))) + +(defun ht->plist (table) + "Return a flat list \\='(key1 value1 key2 value2...) from TABLE. + +Note that hash tables are unordered, so this cannot be an exact +inverse of `ht<-plist'. The following is not guaranteed: + +\(let ((data \\='(a b c d))) + (equalp data + (ht->plist (ht<-plist data))))" + (declare (side-effect-free t)) + (apply 'append (ht-items table))) + +(defalias 'ht-to-plist 'ht->plist) + +(define-inline ht-copy (table) + "Return a shallow copy of TABLE (keys and values are shared)." + (declare (side-effect-free t)) + (inline-quote (copy-hash-table ,table))) + +(defun ht->alist (table) + "Return a list of two-element lists \\='(key . value) from TABLE. + +Note that hash tables are unordered, so this cannot be an exact +inverse of `ht<-alist'. The following is not guaranteed: + +\(let ((data \\='((a . b) (c . d)))) + (equalp data + (ht->alist (ht<-alist data))))" + (declare (side-effect-free t)) + (ht-amap (cons key value) table)) + +(defalias 'ht-to-alist 'ht->alist) + +(defalias 'ht? 'hash-table-p) + +(defalias 'ht-p 'hash-table-p) + +(define-inline ht-contains? (table key) + "Return \\='t if TABLE contains KEY." + (declare (side-effect-free t)) + (inline-quote + (let ((not-found-symbol (make-symbol "ht--not-found"))) + (not (eq (ht-get ,table ,key not-found-symbol) not-found-symbol))))) + +(defalias 'ht-contains-p 'ht-contains?) + +(define-inline ht-size (table) + "Return the actual number of entries in TABLE." + (declare (side-effect-free t)) + (inline-quote + (hash-table-count ,table))) + +(define-inline ht-empty? (table) + "Return true if the actual number of entries in TABLE is zero." + (declare (side-effect-free t)) + (inline-quote + (zerop (ht-size ,table)))) + +(defalias 'ht-empty-p 'ht-empty?) + +(defun ht-select (function table) + "Return a hash table containing all entries in TABLE for which +FUNCTION returns a truthy value. + +FUNCTION is called with two arguments, KEY and VALUE." + (let ((results (ht-create))) + (ht-each + (lambda (key value) + (when (funcall function key value) + (ht-set! results key value))) + table) + results)) + +(defun ht-reject (function table) + "Return a hash table containing all entries in TABLE for which +FUNCTION returns a falsy value. + +FUNCTION is called with two arguments, KEY and VALUE." + (let ((results (ht-create))) + (ht-each + (lambda (key value) + (unless (funcall function key value) + (ht-set! results key value))) + table) + results)) + +(defun ht-reject! (function table) + "Delete entries from TABLE for which FUNCTION returns non-nil. + +FUNCTION is called with two arguments, KEY and VALUE." + (ht-each + (lambda (key value) + (when (funcall function key value) + (remhash key table))) + table) + nil) + +(defalias 'ht-delete-if 'ht-reject!) + +(defun ht-find (function table) + "Return (key, value) from TABLE for which FUNCTION returns a truthy value. +Return nil otherwise. + +FUNCTION is called with two arguments, KEY and VALUE." + (catch 'break + (ht-each + (lambda (key value) + (when (funcall function key value) + (throw 'break (list key value)))) + table))) + +(defun ht-equal? (table1 table2) + "Return t if TABLE1 and TABLE2 have the same keys and values. +Does not compare equality predicates." + (declare (side-effect-free t)) + (let ((keys1 (ht-keys table1)) + (keys2 (ht-keys table2)) + (sentinel (make-symbol "ht-sentinel"))) + (and (equal (length keys1) (length keys2)) + (--all? + (if (ht-p (ht-get table1 it)) + (ht-equal-p (ht-get table1 it) + (ht-get table2 it)) + (equal (ht-get table1 it) + (ht-get table2 it sentinel))) + keys1)))) + +(defalias 'ht-equal-p 'ht-equal?) + +(provide 'ht) +;;; ht.el ends here diff --git a/.config/emacs/lisp/libs/ht.elc b/.config/emacs/lisp/libs/ht.elc new file mode 100644 index 0000000..74a6a61 Binary files /dev/null and b/.config/emacs/lisp/libs/ht.elc differ diff --git a/.config/emacs/lisp/libs/llama.el b/.config/emacs/lisp/libs/llama.el new file mode 100644 index 0000000..4bddfe6 --- /dev/null +++ b/.config/emacs/lisp/libs/llama.el @@ -0,0 +1,572 @@ +;;; llama.el --- Compact syntax for short lambda -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2026 Jonas Bernoulli + +;; Author: Jonas Bernoulli +;; Homepage: https://github.com/tarsius/llama +;; Keywords: extensions + +;; Package-Version: 1.0.5 +;; Package-Requires: ( +;; (emacs "26.1") +;; (compat "31.0")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This package implements a macro named `##', which provides a compact way +;; to write short `lambda' expressions. + +;; The signature of the macro is (## FN &rest BODY) and it expands to a +;; `lambda' expression, which calls the function FN with the arguments BODY +;; and returns the value of that. The arguments of the `lambda' expression +;; are derived from symbols found in BODY. + +;; Each symbol from `%1' through `%9', which appears in an unquoted part +;; of BODY, specifies a mandatory argument. Each symbol from `&1' through +;; `&9', which appears in an unquoted part of BODY, specifies an optional +;; argument. The symbol `&*' specifies extra (`&rest') arguments. + +;; The shorter symbol `%' can be used instead of `%1', but using both in +;; the same expression is not allowed. Likewise `&' can be used instead +;; of `&1'. These shorthands are not recognized in function position. + +;; To support binding forms that use a vector as VARLIST (such as `-let' +;; from the `dash' package), argument symbols are also detected inside of +;; vectors. + +;; The space between `##' and FN can be omitted because `##' is read-syntax +;; for the symbol whose name is the empty string. If you prefer you can +;; place a space there anyway, and if you prefer to not use this somewhat +;; magical symbol at all, you can instead use the alternative name `llama'. + +;; Instead of: +;; +;; (lambda (a &optional _ c &rest d) +;; (foo a (bar c) d)) +;; +;; you can use this macro and write: +;; +;; (##foo %1 (bar &3) &*) +;; +;; which expands to: +;; +;; (lambda (%1 &optional _&2 &3 &rest &*) +;; (foo %1 (bar &3) &*)) + +;; Unused trailing arguments and mandatory unused arguments at the border +;; between mandatory and optional arguments are also supported: +;; +;; (##list %1 _%3 &5 _&6) +;; +;; becomes: +;; +;; (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) +;; (list %1 &5)) +;; +;; Note how `_%3' and `_&6' are removed from the body, because their names +;; begin with an underscore. Also note that `_&4' is optional, unlike the +;; explicitly specified `_%3'. + +;; Consider enabling `llama-fontify-mode' to highlight `##' and its +;; special arguments. + +;;; Code: + +(require 'compat) + +;;;###autoload +(defmacro llama (fn &rest body) + "Expand to a `lambda' expression that wraps around FN and BODY. + +This macro provides a compact way to write short `lambda' expressions. +It expands to a `lambda' expression, which calls the function FN with +arguments BODY and returns its value. The arguments of the `lambda' +expression are derived from symbols found in BODY. + +Each symbol from `%1' through `%9', which appears in an unquoted part +of BODY, specifies a mandatory argument. Each symbol from `&1' through +`&9', which appears in an unquoted part of BODY, specifies an optional +argument. The symbol `&*' specifies extra (`&rest') arguments. + +The shorter symbol `%' can be used instead of `%1', but using both in +the same expression is not allowed. Likewise `&' can be used instead +of `&1'. These shorthands are not recognized in function position. + +To support binding forms that use a vector as VARLIST (such as `-let' +from the `dash' package), argument symbols are also detected inside of +vectors. + +The space between `##' and FN can be omitted because `##' is read-syntax +for the symbol whose name is the empty string. If you prefer you can +place a space there anyway, and if you prefer to not use this somewhat +magical symbol at all, you can instead use the alternative name `llama'. + +Instead of: + + (lambda (a &optional _ c &rest d) + (foo a (bar c) d)) + +you can use this macro and write: + + (##foo %1 (bar &3) &*) + +which expands to: + + (lambda (%1 &optional _&2 &3 &rest &*) + (foo %1 (bar &3) &*)) + +Unused trailing arguments and mandatory unused arguments at the border +between mandatory and optional arguments are also supported: + + (##list %1 _%3 &5 _&6) + +becomes: + + (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) + (list %1 &5)) + +Note how `_%3' and `_&6' are removed from the body, because their names +begin with an underscore. Also note that `_&4' is optional, unlike the +explicitly specified `_%3'. + +Consider enabling `llama-fontify-mode' to highlight `##' and its +special arguments." + (cond ((symbolp fn)) + ((and (eq (car-safe fn) backquote-backquote-symbol) + (not body)) + (setq body (cdr fn)) + (setq fn backquote-backquote-symbol)) + ((signal 'wrong-type-argument + (list 'symbolp backquote-backquote-symbol fn)))) + (let* ((args (make-vector 10 nil)) + (body (cdr (llama--collect (cons fn body) args))) + (rest (aref args 0)) + (args (nreverse (cdr (append args nil)))) + (args (progn (while (and args (null (car args))) + (setq args (cdr args))) + args)) + (pos (length args)) + (opt nil) + (args (mapcar + (lambda (arg) + (if arg + (setq opt (string-match-p "\\`_?&" (symbol-name arg))) + (setq arg (intern (format "_%c%s" (if opt ?& ?%) pos)))) + (setq pos (1- pos)) + arg) + args)) + (opt nil) + (args (mapcar + (lambda (symbol) + (cond + ((string-match-p "\\`_?%" (symbol-name symbol)) + (when opt + (error "`%s' cannot follow optional arguments" symbol)) + (list symbol)) + (opt + (list symbol)) + ((setq opt t) + (list '&optional symbol)))) + (nreverse args)))) + `(lambda + (,@(apply #'nconc args) + ,@(and rest (list '&rest rest))) + (,fn ,@body)))) + +(defalias (intern "") 'llama) +(defalias '\#\# 'llama) + +(defconst llama--unused-argument (make-symbol "llama--unused-argument")) + +(defun llama--collect (expr args &optional fnpos backquoted unquote) + (cond + ((memq (car-safe expr) (list (intern "") 'llama 'quote)) expr) + ((and backquoted (symbolp expr)) expr) + ((and backquoted + (memq (car-safe expr) + (list backquote-unquote-symbol + backquote-splice-symbol))) + (list (car expr) + (llama--collect (cadr expr) args nil nil t))) + ((memq (car-safe expr) + (list backquote-backquote-symbol + backquote-splice-symbol)) + (list (car expr) + (llama--collect (cadr expr) args nil t))) + ((symbolp expr) + (let ((name (symbol-name expr))) + (save-match-data + (cond + ((string-match "\\`\\(_\\)?[%&]\\([1-9*]\\)?\\'" name) + (let* ((pos (match-string 2 name)) + (pos (cond ((equal pos "*") 0) + ((not pos) 1) + ((string-to-number pos)))) + (sym (aref args pos))) + (unless (and fnpos (not unquote) (memq expr '(% &))) + (when (and sym (not (equal expr sym))) + (error "`%s' and `%s' are mutually exclusive" sym expr)) + (aset args pos expr))) + (if (match-string 1 name) + llama--unused-argument + expr)) + (expr))))) + ((or (listp expr) + (vectorp expr)) + (let* ((vectorp (vectorp expr)) + (expr (if vectorp (append expr ()) expr)) + (fnpos (and (not vectorp) + (not backquoted) + (ignore-errors (length expr)))) ;proper-list-p + (ret ())) + (catch t + (while t + (let ((elt (llama--collect (car expr) args fnpos backquoted))) + (unless (eq elt llama--unused-argument) + (push elt ret))) + (setq fnpos nil) + (setq expr (cdr expr)) + (unless (and expr + (listp expr) + (not (eq (car expr) backquote-unquote-symbol))) + (throw t nil)))) + (setq ret (nreverse ret)) + (when expr + (setcdr (last ret) (llama--collect expr args nil backquoted))) + (if vectorp (vconcat ret) ret))) + (expr))) + +;;; Completion + +(define-advice elisp--expect-function-p (:around (fn pos) llama) + "Support function completion directly following `##'." + (or (and (eq (char-before pos) ?#) + (eq (char-before (- pos 1)) ?#)) + (and (eq (char-before pos) ?\s) + (eq (char-before (- pos 1)) ?#) + (eq (char-before (- pos 2)) ?#)) + (funcall fn pos))) + +(define-advice all-completions (:around (fn str table &rest rest) llama) + "Remove empty symbol from completion results if originating from `llama'. + +`##' is the notation for the symbol whose name is the empty string. + (intern \"\") => ## + (symbol-name \\='##) => \"\" + +The `llama' package uses `##' as the name of a macro, which allows +it to be used akin to syntax, without actually being new syntax. +\(`describe-function' won't let you select `##', but because that is an +alias for `llama', you can access the documentation under that name.) + +This advice prevents the empty string from being offered as a completion +candidate when `obarray' or a completion table that internally uses +that is used as TABLE." + (let ((result (apply fn str table rest))) + (if (and (eq obarray table) (equal str "")) + (delete "" result) + result))) + +;;; Fontification + +(defgroup llama () + "Compact syntax for short lambda." + :group 'extensions + :group 'faces + :group 'lisp) + +(defface llama-\#\#-macro '((t :inherit font-lock-function-call-face)) + "Face used for the name of the `##' macro.") + +(defface llama-llama-macro '((t :inherit font-lock-keyword-face)) + "Face used for the name of the `llama' macro.") + +(defface llama-mandatory-argument '((t :inherit font-lock-variable-use-face)) + "Face used for mandatory arguments `%1' through `%9' and `%'.") + +(defface llama-optional-argument '((t :inherit font-lock-type-face)) + "Face used for optional arguments `&1' through `&9', `&' and `&*'.") + +(defface llama-deleted-argument + `((((supports :box t)) + :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) + :color "red" + :style nil)) + (((supports :underline t)) + :underline "red") + (t + :inherit font-lock-warning-face)) + "Face used for deleted arguments `_%1'...`_%9', `_&1'...`_&9' and `_&*'. +This face is used in addition to one of llama's other argument faces. +Unlike implicit unused arguments (which do not appear in the function +body), these arguments are deleted from the function body during macro +expansion, and the looks of this face should hint at that.") + +(defconst llama-font-lock-keywords-28 + '(("(\\(##\\)" 1 'llama-\#\#-macro) + ("(\\(llama\\)\\_>" 1 'llama-llama-macro) + ("\\_<\\(?:_?%[1-9]?\\)\\_>" + 0 (llama--maybe-face 'llama-mandatory-argument)) + ("\\_<\\(?:_?&[1-9*]?\\)\\_>" + 0 (llama--maybe-face 'llama-optional-argument)) + ("\\_<\\(?:_\\(?:%[1-9]?\\|&[1-9*]?\\)\\)\\_>" + 0 'llama-deleted-argument prepend))) + +(defconst llama-font-lock-keywords-29 + `(("\\_<\\(&[1-9*]?\\)\\_>" 1 'default) + (,(apply-partially #'llama--match-and-fontify "(\\(##\\)") + 1 'llama-\#\#-macro) + (,(apply-partially #'llama--match-and-fontify "(\\(llama\\_>\\)") + 1 'llama-llama-macro))) + +(defvar llama-font-lock-keywords + (if (fboundp 'read-positioning-symbols) + llama-font-lock-keywords-29 + llama-font-lock-keywords-28)) + +(defun llama--maybe-face (face) + (and (not (and (member (match-string 0) '("%" "&")) + (and-let* ((beg (ignore-errors + (scan-lists (match-beginning 0) -1 1)))) + (string-match-p "\\`\\(##\\|llama\\_>\\)?[\s\t\n\r]*\\'" + (buffer-substring-no-properties + (1+ beg) (match-beginning 0)))))) + face)) + +(defun llama--match-and-fontify (re end) + (static-if (fboundp 'bare-symbol) + (and (re-search-forward re end t) + (prog1 t + (save-excursion + (goto-char (match-beginning 0)) + (when-let* + ((_(save-match-data (not (nth 8 (syntax-ppss))))) + (expr (ignore-errors + (read-positioning-symbols (current-buffer))))) + (put-text-property (match-beginning 0) (point) + 'font-lock-multiline t) + (llama--fontify (cdr expr) nil nil t))))) + (progn re end nil))) ; Silence compiler. + +(defun llama--fontify (expr &optional fnpos backquoted top) + (static-if (fboundp 'bare-symbol) + (cond + ((null expr) expr) + ((eq (car-safe expr) 'quote)) + ((eq (ignore-errors (bare-symbol (car-safe expr))) 'quote)) + ((and (memq (ignore-errors (bare-symbol (car-safe expr))) + (list (intern "") 'llama)) + (not top))) + ((and backquoted (symbol-with-pos-p expr))) + ((and backquoted + (memq (car-safe expr) + (list backquote-unquote-symbol + backquote-splice-symbol))) + (llama--fontify expr)) + ((symbol-with-pos-p expr) + (save-match-data + (when-let* + ((name (symbol-name (bare-symbol expr))) + (face (cond + ((and (string-match + "\\_<\\(?:\\(_\\)?%\\([1-9]\\)?\\)\\_>" name) + (or (not fnpos) (match-end 2))) + 'llama-mandatory-argument) + ((and (string-match + "\\_<\\(?:\\(_\\)?&\\([1-9*]\\)?\\)\\_>" name) + (or (not fnpos) (match-end 2))) + 'llama-optional-argument)))) + (when (match-end 1) + (setq face (list 'llama-deleted-argument face))) + (let ((beg (symbol-with-pos-pos expr))) + (put-text-property + beg (save-excursion (goto-char beg) (forward-symbol 1)) + 'face face))))) + ((or (listp expr) + (vectorp expr)) + (let* ((vectorp (vectorp expr)) + (expr (if vectorp (append expr ()) expr)) + (fnpos (and (not vectorp) + (not backquoted) + (ignore-errors (length expr))))) + (catch t + (while t + (cond ((eq (car expr) backquote-backquote-symbol) + (setq expr (cdr expr)) + (llama--fontify (car expr) t t)) + ((llama--fontify (car expr) fnpos backquoted))) + (setq fnpos nil) + (setq expr (cdr expr)) + (unless (and expr + (listp expr) + (not (eq (car expr) backquote-unquote-symbol))) + (throw t nil)))) + (when expr + (llama--fontify expr fnpos)))))) + (and expr fnpos backquoted top nil)) ; Silence compiler. + +(defvar llama-fontify-mode-lighter nil) + +;;;###autoload +(define-minor-mode llama-fontify-mode + "In Emacs Lisp mode, highlight the `##' macro and its special arguments." + :lighter llama-fontify-mode-lighter + :global t + (cond + (llama-fontify-mode + (advice-add 'lisp--el-match-keyword :override + #'lisp--el-match-keyword@llama '((depth . -80))) + (advice-add 'elisp-mode-syntax-propertize :override + #'elisp-mode-syntax-propertize@llama) + (add-hook 'emacs-lisp-mode-hook #'llama--add-font-lock-keywords)) + (t + (advice-remove 'lisp--el-match-keyword + #'lisp--el-match-keyword@llama) + (advice-remove 'elisp-mode-syntax-propertize + #'elisp-mode-syntax-propertize@llama) + (remove-hook 'emacs-lisp-mode-hook #'llama--add-font-lock-keywords))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'emacs-lisp-mode) + (if llama-fontify-mode + (font-lock-add-keywords nil llama-font-lock-keywords) + (font-lock-remove-keywords nil llama-font-lock-keywords)) + (font-lock-flush))))) + +(defun llama--add-font-lock-keywords () + (font-lock-add-keywords nil llama-font-lock-keywords)) + +(defun lisp--el-match-keyword@llama (limit) + "Highlight symbols following \"(##\" the same as if they followed \"(\"." + (catch 'found + (while (re-search-forward + (concat "(\\(?:## ?\\)?\\(" + (static-if (get 'lisp-mode-symbol 'rx-definition) ;>= 29.1 + (rx lisp-mode-symbol) + lisp-mode-symbol-regexp) + "\\)\\_>") + limit t) + (let ((sym (intern-soft (match-string 1)))) + (when (and (or (special-form-p sym) + (macrop sym) + (and (bound-and-true-p morlock-mode) + ;; Same as in advice of `morlock' package. + (get sym 'morlock-font-lock-keyword))) + (not (get sym 'no-font-lock-keyword)) + (static-if (fboundp 'lisp--el-funcall-position-p) ;>= 28.1 + (lisp--el-funcall-position-p (match-beginning 0)) + (not (lisp--el-non-funcall-position-p + (match-beginning 0))))) + (throw 'found t)))))) + +(defun elisp-mode-syntax-propertize@llama (start end) + ;; Synced with Emacs up to 6b9510d94f814cacf43793dce76250b5f7e6f64a. + "Highlight `##' as the symbol which it is." + (goto-char start) + (let ((case-fold-search nil)) + (funcall + (syntax-propertize-rules + ;; Empty symbol. + ;; {{ Comment out to prevent the `##' from becoming part of + ;; the following symbol when there is no space in between. + ;; ("##" (0 (unless (nth 8 (syntax-ppss)) + ;; (string-to-syntax "_")))) + ;; }} + ;; {{ As for other symbols, use `font-lock-constant-face' in + ;; docstrings and comments. + ("##" (0 (when (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ;; }} + ;; {{ Preserve this part, even though it is absent from + ;; this function in 29.1; backporting it by association. + ;; Prevent the @ from becoming part of a following symbol. + (",@" (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "'")))) + ;; }} + ;; Unicode character names. (The longest name is 88 characters + ;; long.) + ("\\?\\\\N{[-A-Za-z0-9 ]\\{,100\\}}" + (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ((rx "#" (or (seq (group-n 1 "&" (+ digit)) ?\") ; Bool-vector. + (seq (group-n 1 "s") "(") ; Record. + (seq (group-n 1 (+ "^")) "["))) ; Char-table. + (1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "'"))))) + start end))) + +;;; Partial applications + +(defun llama--left-apply-partially (fn &rest args) + "Return a function that is a partial application of FN to ARGS. + +ARGS is a list of the first N arguments to pass to FN. The result +is a new function which does the same as FN, except that the first N +arguments are fixed at the values with which this function was called. + +See also `llama--right-apply-partially', which instead fixes the last +N arguments. + +These functions are intended to be used using the names `partial' and +`rpartial'. To be able to use these shorthands in a file, you must set +the file-local value of `read-symbols-shorthands', which was added in +Emacs 28.1. For an example see the end of file \"llama.el\". + +This is an alternative to `apply-partially', whose name is too long." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args2) + (apply fn (append args args2)))) + +(defun llama--right-apply-partially (fn &rest args) + "Return a function that is a right partial application of FN to ARGS. + +ARGS is a list of the last N arguments to pass to FN. The result +is a new function which does the same as FN, except that the last N +arguments are fixed at the values with which this function was called. + +See also `llama--left-apply-partially', which instead fixes the first +N arguments. + +These functions are intended to be used using the names `rpartial' and +`partial'. To be able to use these shorthands in a file, you must set +the file-local value of `read-symbols-shorthands', which was added in +Emacs 28.1. For an example see the end of file \"llama.el\"." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args2) + (apply fn (append args2 args)))) + +;; An example of how one would use these functions: +;; +;; (list (funcall (partial (lambda (a b) (list a b)) 'fixed) 'after) +;; (funcall (rpartial (lambda (a b) (list a b)) 'fixed) 'before)) + +;; An example of the configuration that is necessary to enable this: +;; +;; Local Variables: +;; indent-tabs-mode: nil +;; read-symbol-shorthands: ( +;; ("partial" . "llama--left-apply-partially") +;; ("rpartial" . "llama--right-apply-partially")) +;; End: +;; +;; Do not set `read-symbol-shorthands' in the ".dir-locals.el" +;; file, because that does not work for uncompiled libraries. + +(provide 'llama) + +;;; llama.el ends here diff --git a/.config/emacs/lisp/libs/llama.elc b/.config/emacs/lisp/libs/llama.elc new file mode 100644 index 0000000..5dacade Binary files /dev/null and b/.config/emacs/lisp/libs/llama.elc differ diff --git a/.config/emacs/lisp/libs/s.el b/.config/emacs/lisp/libs/s.el new file mode 100644 index 0000000..cae199b --- /dev/null +++ b/.config/emacs/lisp/libs/s.el @@ -0,0 +1,792 @@ +;;; s.el --- The long lost Emacs string manipulation library. -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2022 Magnar Sveen + +;; Author: Magnar Sveen +;; Maintainer: Jason Milkins +;; Version: 1.13.1 +;; Keywords: strings + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The long lost Emacs string manipulation library. +;; +;; See documentation on https://github.com/magnars/s.el#functions + +;;; Code: + +;; Silence byte-compiler +(defvar ucs-normalize-combining-chars) ; Defined in `ucs-normalize' +(autoload 'slot-value "eieio") + +(defun s-trim-left (s) + "Remove whitespace at the beginning of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "\\`[ \t\n\r]+" s) + (replace-match "" t t s) + s))) + +(defun s-trim-right (s) + "Remove whitespace at the end of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "[ \t\n\r]+\\'" s) + (replace-match "" t t s) + s))) + +(defun s-trim (s) + "Remove whitespace at the beginning and end of S." + (declare (pure t) (side-effect-free t)) + (s-trim-left (s-trim-right s))) + +(defun s-collapse-whitespace (s) + "Convert all adjacent whitespace characters to a single space." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string "[ \t\n\r]+" " " s)) + +(defun s-unindent (s &optional bol) + "Unindent S which has BOL (beginning of line) indicators. +BOL will default to pipe. You can optionally supply your own." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil) + (bol (or bol "|"))) + (s-replace-regexp (concat "^[[:space:]]*" (regexp-quote bol)) "" s))) + +(defun s-split (separator s &optional omit-nulls) + "Split S into substrings bounded by matches for regexp SEPARATOR. +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +This is a simple wrapper around the built-in `split-string'." + (declare (side-effect-free t)) + (save-match-data + (split-string s separator omit-nulls))) + +(defun s-split-up-to (separator s n &optional omit-nulls) + "Split S up to N times into substrings bounded by matches for regexp SEPARATOR. + +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +See also `s-split'." + (declare (side-effect-free t)) + (save-match-data + (let ((op 0) + (r nil)) + (with-temp-buffer + (insert s) + (setq op (goto-char (point-min))) + (while (and (re-search-forward separator nil t) + (< 0 n)) + (let ((sub (buffer-substring op (match-beginning 0)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r))) + (setq op (goto-char (match-end 0))) + (setq n (1- n))) + (let ((sub (buffer-substring op (point-max)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r)))) + (nreverse r)))) + +(defun s-lines (s) + "Splits S into a list of strings on newline characters." + (declare (pure t) (side-effect-free t)) + (s-split "\\(\r\n\\|[\n\r]\\)" s)) + +(defun s-join (separator strings) + "Join all the strings in STRINGS with SEPARATOR in between." + (declare (pure t) (side-effect-free t)) + (mapconcat 'identity strings separator)) + +(defun s-concat (&rest strings) + "Join all the string arguments into one string." + (declare (pure t) (side-effect-free t)) + (apply 'concat strings)) + +(defun s-prepend (prefix s) + "Concatenate PREFIX and S." + (declare (pure t) (side-effect-free t)) + (concat prefix s)) + +(defun s-append (suffix s) + "Concatenate S and SUFFIX." + (declare (pure t) (side-effect-free t)) + (concat s suffix)) + +(defun s-splice (needle n s) + "Splice NEEDLE into S at position N. +0 is the beginning of the string, -1 is the end." + (if (< n 0) + (let ((left (substring s 0 (+ 1 n (length s)))) + (right (s-right (- -1 n) s))) + (concat left needle right)) + (let ((left (s-left n s)) + (right (substring s n (length s)))) + (concat left needle right)))) + + +(defun s-repeat (num s) + "Make a string of S repeated NUM times." + (declare (pure t) (side-effect-free t)) + (let (ss) + (while (> num 0) + (setq ss (cons s ss)) + (setq num (1- num))) + (apply 'concat ss))) + +(defun s-chop-suffix (suffix s) + "Remove SUFFIX if it is at end of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (- (length suffix)))) + (if (and (>= (length s) (length suffix)) + (string= suffix (substring s pos))) + (substring s 0 pos) + s))) + +(defun s-chop-suffixes (suffixes s) + "Remove SUFFIXES one by one in order, if they are at the end of S." + (declare (pure t) (side-effect-free t)) + (while suffixes + (setq s (s-chop-suffix (car suffixes) s)) + (setq suffixes (cdr suffixes))) + s) + +(defun s-chop-prefix (prefix s) + "Remove PREFIX if it is at the start of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (length prefix))) + (if (and (>= (length s) (length prefix)) + (string= prefix (substring s 0 pos))) + (substring s pos) + s))) + +(defun s-chop-prefixes (prefixes s) + "Remove PREFIXES one by one in order, if they are at the start of S." + (declare (pure t) (side-effect-free t)) + (while prefixes + (setq s (s-chop-prefix (car prefixes) s)) + (setq prefixes (cdr prefixes))) + s) + +(defun s-shared-start (s1 s2) + "Returns the longest prefix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let ((cmp (compare-strings s1 0 (length s1) s2 0 (length s2)))) + (if (eq cmp t) s1 (substring s1 0 (1- (abs cmp)))))) + +(defun s-shared-end (s1 s2) + "Returns the longest suffix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let* ((l1 (length s1)) + (l2 (length s2)) + (search-length (min l1 l2)) + (i 0)) + (while (and (< i search-length) + (= (aref s1 (- l1 i 1)) (aref s2 (- l2 i 1)))) + (setq i (1+ i))) + ;; If I is 0, then it means that there's no common suffix between + ;; S1 and S2. + ;; + ;; However, since (substring s (- 0)) will return the whole + ;; string, `s-shared-end' should simply return the empty string + ;; when I is 0. + (if (zerop i) + "" + (substring s1 (- i))))) + +(defun s-chomp (s) + "Remove one trailing `\\n`, `\\r` or `\\r\\n` from S." + (declare (pure t) (side-effect-free t)) + (s-chop-suffixes '("\n" "\r") s)) + +(defun s-truncate (len s &optional ellipsis) + "If S is longer than LEN, cut it down and add ELLIPSIS to the end. + +The resulting string, including ellipsis, will be LEN characters +long. + +When not specified, ELLIPSIS defaults to ‘...’." + (declare (pure t) (side-effect-free t)) + (unless ellipsis + (setq ellipsis "...")) + (if (> (length s) len) + (format "%s%s" (substring s 0 (- len (length ellipsis))) ellipsis) + s)) + +(defun s-word-wrap (len s) + "If S is longer than LEN, wrap the words with newlines." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (let ((fill-column len)) + (fill-region (point-min) (point-max))) + (buffer-substring (point-min) (point-max))))) + +(defun s-center (len s) + "If S is shorter than LEN, pad it with spaces so it is centered." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat + (make-string (ceiling extra 2) ?\s) + s + (make-string (floor extra 2) ?\s)))) + +(defun s-pad-left (len padding s) + "If S is shorter than LEN, pad it with PADDING on the left." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat (make-string extra (string-to-char padding)) + s))) + +(defun s-pad-right (len padding s) + "If S is shorter than LEN, pad it with PADDING on the right." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat s + (make-string extra (string-to-char padding))))) + +(defun s-left (len s) + "Returns up to the LEN first chars of S." + (declare (pure t) (side-effect-free t)) + (if (> (length s) len) + (substring s 0 len) + s)) + +(defun s-right (len s) + "Returns up to the LEN last chars of S." + (declare (pure t) (side-effect-free t)) + (let ((l (length s))) + (if (> l len) + (substring s (- l len) l) + s))) + +(defun s-chop-left (len s) + "Remove the first LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s len l) + ""))) + +(defun s-chop-right (len s) + "Remove the last LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s 0 (- l len)) + ""))) + +(defun s-ends-with? (suffix s &optional ignore-case) + "Does S end with SUFFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-suffix?'" + (declare (pure t) (side-effect-free t)) + (let ((start-pos (- (length s) (length suffix)))) + (and (>= start-pos 0) + (eq t (compare-strings suffix nil nil + s start-pos nil ignore-case))))) + +(defun s-starts-with? (prefix s &optional ignore-case) + "Does S start with PREFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-prefix?'. This is a simple wrapper around the built-in +`string-prefix-p'." + (declare (pure t) (side-effect-free t)) + (string-prefix-p prefix s ignore-case)) + +(defun s--truthy? (val) + (declare (pure t) (side-effect-free t)) + (not (null val))) + +(defun s-contains? (needle s &optional ignore-case) + "Does S contain NEEDLE? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (s--truthy? (string-match-p (regexp-quote needle) s)))) + +(defun s-equals? (s1 s2) + "Is S1 equal to S2? + +This is a simple wrapper around the built-in `string-equal'." + (declare (pure t) (side-effect-free t)) + (string-equal s1 s2)) + +(defun s-less? (s1 s2) + "Is S1 less than S2? + +This is a simple wrapper around the built-in `string-lessp'." + (declare (pure t) (side-effect-free t)) + (string-lessp s1 s2)) + +(defun s-matches? (regexp s &optional start) + "Does REGEXP match S? +If START is non-nil the search starts at that index. + +This is a simple wrapper around the built-in `string-match-p'." + (declare (side-effect-free t)) + (s--truthy? (string-match-p regexp s start))) + +(defun s-blank? (s) + "Is S nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (or (null s) (string= "" s))) + +(defun s-blank-str? (s) + "Is S nil or the empty string or string only contains whitespace?" + (declare (pure t) (side-effect-free t)) + (or (s-blank? s) (s-blank? (s-trim s)))) + +(defun s-present? (s) + "Is S anything but nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (not (s-blank? s))) + +(defun s-presence (s) + "Return S if it's `s-present?', otherwise return nil." + (declare (pure t) (side-effect-free t)) + (and (s-present? s) s)) + +(defun s-lowercase? (s) + "Are all the letters in S in lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:upper:]]" s)))) + +(defun s-uppercase? (s) + "Are all the letters in S in upper case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:lower:]]" s)))) + +(defun s-mixedcase? (s) + "Are there both lower case and upper case letters in S?" + (let ((case-fold-search nil)) + (s--truthy? + (and (string-match-p "[[:lower:]]" s) + (string-match-p "[[:upper:]]" s))))) + +(defun s-capitalized? (s) + "In S, is the first letter upper case, and all other letters lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (s--truthy? + (string-match-p "^[[:upper:]][^[:upper:]]*$" s)))) + +(defun s-numeric? (s) + "Is S a number?" + (declare (pure t) (side-effect-free t)) + (s--truthy? + (string-match-p "^[0-9]+$" s))) + +(defun s-replace (old new s) + "Replaces OLD with NEW in S." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string (regexp-quote old) new s t t)) + +(defalias 's-replace-regexp 'replace-regexp-in-string) + +(defun s--aget (alist key) + "Get the value of KEY in ALIST." + (declare (pure t) (side-effect-free t)) + (cdr (assoc-string key alist))) + +(defun s-replace-all (replacements s) + "REPLACEMENTS is a list of cons-cells. Each `car` is replaced with `cdr` in S." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil)) + (replace-regexp-in-string (regexp-opt (mapcar 'car replacements)) + (lambda (it) (s--aget replacements it)) + s t t))) + +(defun s-downcase (s) + "Convert S to lower case. + +This is a simple wrapper around the built-in `downcase'." + (declare (side-effect-free t)) + (downcase s)) + +(defun s-upcase (s) + "Convert S to upper case. + +This is a simple wrapper around the built-in `upcase'." + (declare (side-effect-free t)) + (upcase s)) + +(defun s-capitalize (s) + "Convert S first word's first character to upper and the rest to lower case." + (declare (side-effect-free t)) + (concat (upcase (substring s 0 1)) (downcase (substring s 1)))) + +(defun s-titleize (s) + "Convert in S each word's first character to upper and the rest to lower case. + +This is a simple wrapper around the built-in `capitalize'." + (declare (side-effect-free t)) + (capitalize s)) + +(defmacro s-with (s form &rest more) + "Threads S through the forms. Inserts S as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, inserts the first form as the +last item in second form, etc." + (declare (debug (form &rest [&or (function &rest form) fboundp]))) + (if (null more) + (if (listp form) + `(,(car form) ,@(cdr form) ,s) + (list form s)) + `(s-with (s-with ,s ,form) ,@more))) + +(put 's-with 'lisp-indent-function 1) + +(defun s-index-of (needle s &optional ignore-case) + "Returns first index of NEEDLE in S, or nil. + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (string-match-p (regexp-quote needle) s))) + +(defun s-reverse (s) + "Return the reverse of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (multibyte-string-p s) + (let ((input (string-to-list s)) + output) + (require 'ucs-normalize) + (while input + ;; Handle entire grapheme cluster as a single unit + (let ((grapheme (list (pop input)))) + (while (memql (car input) ucs-normalize-combining-chars) + (push (pop input) grapheme)) + (setq output (nconc (nreverse grapheme) output)))) + (concat output)) + (concat (nreverse (string-to-list s)))))) + +(defun s-match-strings-all (regex string) + "Return a list of matches for REGEX in STRING. + +Each element itself is a list of matches, as per +`match-string'. Multiple matches at the same position will be +ignored after the first." + (declare (side-effect-free t)) + (save-match-data + (let ((all-strings ()) + (i 0)) + (while (and (< i (length string)) + (string-match regex string i)) + (setq i (1+ (match-beginning 0))) + (let (strings + (num-matches (/ (length (match-data)) 2)) + (match 0)) + (while (/= match num-matches) + (push (match-string match string) strings) + (setq match (1+ match))) + (push (nreverse strings) all-strings))) + (nreverse all-strings)))) + +(defun s-matched-positions-all (regexp string &optional subexp-depth) + "Return a list of matched positions for REGEXP in STRING. +SUBEXP-DEPTH is 0 by default." + (declare (side-effect-free t)) + (if (null subexp-depth) + (setq subexp-depth 0)) + (save-match-data + (let ((pos 0) result) + (while (and (string-match regexp string pos) + (< pos (length string))) + (push (cons (match-beginning subexp-depth) (match-end subexp-depth)) result) + (setq pos (match-end 0))) + (nreverse result)))) + +(defun s-match (regexp s &optional start) + "When the given expression matches the string, this function returns a list +of the whole matching string and a string for each matched subexpressions. +Subexpressions that didn't match are represented by nil elements +in the list, except that non-matching subexpressions at the end +of REGEXP might not appear at all in the list. That is, the +returned list can be shorter than the number of subexpressions in +REGEXP plus one. If REGEXP did not match the returned value is +an empty list (nil). + +When START is non-nil the search will start at that index." + (declare (side-effect-free t)) + (save-match-data + (if (string-match regexp s start) + (let ((match-data-list (match-data)) + result) + (while match-data-list + (let* ((beg (car match-data-list)) + (end (cadr match-data-list)) + (subs (if (and beg end) (substring s beg end) nil))) + (setq result (cons subs result)) + (setq match-data-list + (cddr match-data-list)))) + (nreverse result))))) + +(defun s-slice-at (regexp s) + "Slices S up at every index matching REGEXP." + (declare (side-effect-free t)) + (if (s-blank? s) + (list s) + (let (ss) + (while (not (s-blank? s)) + (save-match-data + (let ((i (string-match regexp s 1))) + (if i + (setq ss (cons (substring s 0 i) ss) + s (substring s i)) + (setq ss (cons s ss) + s ""))))) + (nreverse ss)))) + +(defun s-split-words (s) + "Split S into list of words." + (declare (side-effect-free t)) + (s-split + "[^[:word:]0-9]+" + (let ((case-fold-search nil)) + (replace-regexp-in-string + "\\([[:lower:]]\\)\\([[:upper:]]\\)" "\\1 \\2" + (replace-regexp-in-string "\\([[:upper:]]\\)\\([[:upper:]][0-9[:lower:]]\\)" "\\1 \\2" s))) + t)) + +(defun s--mapcar-head (fn-head fn-rest list) + "Like MAPCAR, but applies a different function to the first element." + (if list + (cons (funcall fn-head (car list)) (mapcar fn-rest (cdr list))))) + +(defun s-lower-camel-case (s) + "Convert S to lowerCamelCase." + (declare (side-effect-free t)) + (s-join "" (s--mapcar-head 'downcase 'capitalize (s-split-words s)))) + +(defun s-upper-camel-case (s) + "Convert S to UpperCamelCase." + (declare (side-effect-free t)) + (s-join "" (mapcar 'capitalize (s-split-words s)))) + +(defun s-snake-case (s) + "Convert S to snake_case." + (declare (side-effect-free t)) + (s-join "_" (mapcar 'downcase (s-split-words s)))) + +(defun s-dashed-words (s) + "Convert S to dashed-words." + (declare (side-effect-free t)) + (s-join "-" (mapcar 'downcase (s-split-words s)))) + +(defun s-spaced-words (s) + "Convert S to spaced words." + (declare (side-effect-free t)) + (s-join " " (s-split-words s))) + +(defun s-capitalized-words (s) + "Convert S to Capitalized words." + (declare (side-effect-free t)) + (let ((words (s-split-words s))) + (s-join " " (cons (capitalize (car words)) (mapcar 'downcase (cdr words)))))) + +(defun s-titleized-words (s) + "Convert S to Titleized Words." + (declare (side-effect-free t)) + (s-join " " (mapcar 's-titleize (s-split-words s)))) + +(defun s-word-initials (s) + "Convert S to its initials." + (declare (side-effect-free t)) + (s-join "" (mapcar (lambda (ss) (substring ss 0 1)) + (s-split-words s)))) + +;; Errors for s-format +(progn + (put 's-format-resolve + 'error-conditions + '(error s-format s-format-resolve)) + (put 's-format-resolve + 'error-message + "Cannot resolve a template to values")) + +(defun s-format (template replacer &optional extra) + "Format TEMPLATE with the function REPLACER. + +REPLACER takes an argument of the format variable and optionally +an extra argument which is the EXTRA value from the call to +`s-format'. + +Several standard `s-format' helper functions are recognized and +adapted for this: + + (s-format \"${name}\" \\='gethash hash-table) + (s-format \"${name}\" \\='aget alist) + (s-format \"$0\" \\='elt sequence) + +The REPLACER function may be used to do any other kind of +transformation." + (let ((saved-match-data (match-data))) + (unwind-protect + (replace-regexp-in-string + "\\$\\({\\([^}]+\\)}\\|[0-9]+\\)" + (lambda (md) + (let ((var + (let ((m (match-string 2 md))) + (if m m + (string-to-number (match-string 1 md))))) + (replacer-match-data (match-data))) + (unwind-protect + (let ((v + (cond + ((eq replacer 'gethash) + (funcall replacer var extra)) + ((eq replacer 'aget) + (funcall 's--aget extra var)) + ((eq replacer 'elt) + (funcall replacer extra var)) + ((eq replacer 'oref) + (funcall #'slot-value extra (intern var))) + (t + (set-match-data saved-match-data) + (if extra + (funcall replacer var extra) + (funcall replacer var)))))) + (if v (format "%s" v) (signal 's-format-resolve md))) + (set-match-data replacer-match-data)))) + template + ;; Need literal to make sure it works + t t) + (set-match-data saved-match-data)))) + +(defvar s-lex-value-as-lisp nil + "If `t' interpolate lisp values as lisp. + +`s-lex-format' inserts values with (format \"%S\").") + +(defun s-lex-fmt|expand (fmt) + "Expand FMT into lisp." + (declare (side-effect-free t)) + (list 's-format fmt (quote 'aget) + (append '(list) + (mapcar + (lambda (matches) + (list + 'cons + (cadr matches) + `(format + (if s-lex-value-as-lisp "%S" "%s") + ,(intern (cadr matches))))) + (s-match-strings-all "${\\([^}]+\\)}" fmt))))) + +(defmacro s-lex-format (format-str) + "`s-format` with the current environment. + +FORMAT-STR may use the `s-format' variable reference to refer to +any variable: + + (let ((x 1)) + (s-lex-format \"x is: ${x}\")) + +The values of the variables are interpolated with \"%s\" unless +the variable `s-lex-value-as-lisp' is `t' and then they are +interpolated with \"%S\"." + (declare (debug (form))) + (s-lex-fmt|expand format-str)) + +(defun s-count-matches (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the end of the +previous match. Hence, it ignores matches that overlap a previously +found match. To count overlapping matches, use +`s-count-matches-all'." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (count-matches regexp (or start 1) (or end (point-max)))))) + +(defun s-count-matches-all (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the second +character of the previous match. Hence, it counts matches that +overlap a previously found match. To ignore matches that overlap a +previously found match, use `s-count-matches'." + (declare (side-effect-free t)) + (let* ((anchored-regexp (format "^%s" regexp)) + (match-count 0) + (i 0) + (narrowed-s (substring s (if start (1- start) 0) + (when end (1- end))))) + (save-match-data + (while (< i (length narrowed-s)) + (when (s-matches? anchored-regexp (substring narrowed-s i)) + (setq match-count (1+ match-count))) + (setq i (1+ i)))) + match-count)) + +(defun s-wrap (s prefix &optional suffix) + "Wrap string S with PREFIX and optionally SUFFIX. + +Return string S with PREFIX prepended. If SUFFIX is present, it +is appended, otherwise PREFIX is used as both prefix and +suffix." + (declare (pure t) (side-effect-free t)) + (concat prefix s (or suffix prefix))) + + +;;; Aliases + +(defalias 's-blank-p 's-blank?) +(defalias 's-blank-str-p 's-blank-str?) +(defalias 's-capitalized-p 's-capitalized?) +(defalias 's-contains-p 's-contains?) +(defalias 's-ends-with-p 's-ends-with?) +(defalias 's-equals-p 's-equals?) +(defalias 's-less-p 's-less?) +(defalias 's-lowercase-p 's-lowercase?) +(defalias 's-matches-p 's-matches?) +(defalias 's-mixedcase-p 's-mixedcase?) +(defalias 's-numeric-p 's-numeric?) +(defalias 's-prefix-p 's-starts-with?) +(defalias 's-prefix? 's-starts-with?) +(defalias 's-present-p 's-present?) +(defalias 's-starts-with-p 's-starts-with?) +(defalias 's-suffix-p 's-ends-with?) +(defalias 's-suffix? 's-ends-with?) +(defalias 's-uppercase-p 's-uppercase?) + + +(provide 's) +;;; s.el ends here diff --git a/.config/emacs/lisp/libs/s.elc b/.config/emacs/lisp/libs/s.elc new file mode 100644 index 0000000..16489e9 Binary files /dev/null and b/.config/emacs/lisp/libs/s.elc differ diff --git a/.config/emacs/lisp/libs/transient.el b/.config/emacs/lisp/libs/transient.el new file mode 100644 index 0000000..a313d90 --- /dev/null +++ b/.config/emacs/lisp/libs/transient.el @@ -0,0 +1,5497 @@ +;;; transient.el --- Transient commands -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2026 Free Software Foundation, Inc. + +;; Author: Jonas Bernoulli +;; Homepage: https://github.com/magit/transient +;; Keywords: extensions + +;; Package-Version: 0.12.0 +;; Package-Requires: ( +;; (emacs "28.1") +;; (compat "30.1") +;; (cond-let "0.2") +;; (seq "2.24")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Transient is the library used to implement the keyboard-driven menus +;; in Magit. It is distributed as a separate package, so that it can be +;; used to implement similar menus in other packages. + +;;; Code: + +(defconst transient-version "0.12.0") + +(require 'cl-lib) +(require 'compat) +(require 'cond-let) +(require 'eieio) +(require 'edmacro) +(require 'format-spec) +(require 'pcase) +(require 'pp) + +(eval-and-compile + (when (and (featurep 'seq) + (not (fboundp 'seq-keep))) + (unload-feature 'seq 'force))) +(require 'seq) +(unless (fboundp 'seq-keep) + (display-warning 'transient (substitute-command-keys "\ +Transient requires `seq' >= 2.24, +but due to bad defaults, Emacs's package manager, refuses to +upgrade this and other built-in packages to higher releases +from GNU Elpa, when a package specifies that this is needed. + +To fix this, you have to add this to your init file: + + (setq package-install-upgrade-built-in t) + +Then evaluate that expression by placing the cursor after it +and typing \\[eval-last-sexp]. + +Once you have done that, you have to explicitly upgrade `seq': + + \\[package-upgrade] seq \\`RET' + +Then you also must make sure the updated version is loaded, +by evaluating this form: + + (progn (unload-feature 'seq t) (require 'seq)) + +Until you do this, you will get random errors about `seq-keep' +being undefined while using Transient. + +If you don't use the `package' package manager but still get +this warning, then your chosen package manager likely has a +similar defect.") :emergency)) + +(eval-when-compile (require 'subr-x)) + +(declare-function info "info" (&optional file-or-node buffer)) +(declare-function Man-find-section "man" (section)) +(declare-function Man-next-section "man" (n)) +(declare-function Man-getpage-in-background "man" (topic)) + +(defvar Man-notify-method) +(defvar pp-default-function) ; since Emacs 29.1 + +(static-if (< emacs-major-version 30) + (progn + (defun internal--build-binding@backport-e680827e814 (fn binding prev-var) + "Backport not warning about `_' not being left unused. +Backport fix for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=69108, +from Emacs commit e680827e814e155cf79175d87ff7c6ee3a08b69a." + (let ((binding (funcall fn binding prev-var))) + (if (eq (car binding) '_) + (cons (make-symbol "s") (cdr binding)) + binding))) + (advice-add 'internal--build-binding :around + #'internal--build-binding@backport-e680827e814))) + +(defvar transient-common-command-prefix) + +(defmacro transient--with-emergency-exit (id &rest body) + (declare (indent defun)) + (unless (keywordp id) + (setq body (cons id body)) + (setq id nil)) + `(condition-case err + (let ((debugger #'transient--exit-and-debug)) + ,(macroexp-progn body)) + ((debug error) + (transient--emergency-exit ,id) + (signal (car err) (cdr err))))) + +(defun transient--exit-and-debug (&rest args) + (transient--emergency-exit :debugger) + (apply #'debug args)) + +;;; Options + +(defgroup transient nil + "Transient commands." + :group 'extensions) + +(defcustom transient-show-popup t + "Whether and when to show transient's menu in a buffer. + +\\\ +- If t (the default), then show the buffer as soon as a transient + prefix command is invoked. + +- If nil, then do not show the buffer unless the user explicitly + requests it, by pressing \\[transient-show] or a prefix key. + +- If a number, then delay displaying the buffer and instead show + a brief one-line summary. If zero or negative, then suppress + even showing that summary and display the pressed key only. + + Show the buffer once the user explicitly requests it by pressing + \\[transient-show] or a prefix key. Unless zero, then also show the buffer + after that many seconds of inactivity (using the absolute value)." + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "Instantly" t) + (const :tag "On demand" nil) + (const :tag "On demand (no summary)" 0) + (number :tag "After delay" 1))) + +(defcustom transient-enable-popup-navigation 'verbose + "Whether navigation commands are enabled in the menu buffer. + +If the value is `verbose' (the default), additionally show brief +documentation about the command under point in the echo area. + +While a transient is active transient's menu buffer is not the +current buffer, making it necessary to use dedicated commands to +act on that buffer itself. If this is non-nil, then the following +bindings are available: + +\\\ +- \\[transient-backward-button] moves the cursor to the previous suffix. +- \\[transient-forward-button] moves the cursor to the next suffix. +- \\[transient-push-button] invokes the suffix the cursor is on. +\\\ +- \\`' and \\`' invoke the clicked on suffix. +\\\ +- \\[transient-isearch-backward]\ + and \\[transient-isearch-forward] start isearch in the menu buffer. + +\\`' and \\`' are bound in `transient-push-button'. +All other bindings are in `transient-popup-navigation-map'. + +By default \\`M-RET' is bound to `transient-push-button', instead of +\\`RET', because if a transient allows the invocation of non-suffixes, +then it is likely, that you would want \\`RET' to do what it would do +if no transient were active." + :package-version '(transient . "0.7.8") + :group 'transient + :type '(choice (const :tag "Enable navigation and echo summary" verbose) + (const :tag "Enable navigation commands" t) + (const :tag "Disable navigation commands" nil))) + +(defcustom transient-display-buffer-action + '(display-buffer-in-side-window + (side . bottom) + (dedicated . t) + (inhibit-same-window . t)) + "The action used to display transient's menu buffer. + +The transient menu buffer is displayed in a window using + + (display-buffer BUFFER transient-display-buffer-action) + +The value of this option has the form (FUNCTION . ALIST), +where FUNCTION is a function or a list of functions. Each such +function should accept two arguments: a buffer to display and an +alist of the same form as ALIST. See info node `(elisp)Choosing +Window' for details. + +The default is: + + (display-buffer-in-side-window + (side . bottom) + (dedicated . t) + (inhibit-same-window . t)) + +This displays the window at the bottom of the selected frame. +For alternatives see info node `(elisp)Display Action Functions' +and info node `(elisp)Buffer Display Action Alists'. + +When you switch to a different ACTION, you should keep the ALIST +entries for `dedicated' and `inhibit-same-window' in most cases. +Do not drop them because you are unsure whether they are needed; +if you are unsure, then keep them. + +Note that the buffer that was current before the transient buffer +is shown should remain the current buffer. Many suffix commands +act on the thing at point, if appropriate, and if the transient +buffer became the current buffer, then that would change what is +at point. To that effect `inhibit-same-window' ensures that the +selected window is not used to show the transient buffer. + +The use of a horizontal split to display the menu window can lead +to incompatibilities and is thus discouraged. Transient tries to +mitigate such issue but cannot proactively deal with all possible +configurations and combinations of third-party packages. + +It may be possible to display the window in another frame, but +whether that works in practice depends on the window-manager. +If the window manager selects the new window (Emacs frame), +then that unfortunately changes which buffer is current. + +If you change the value of this option, then you might also +want to change the value of `transient-mode-line-format'." + :package-version '(transient . "0.7.5") + :group 'transient + :type '(cons (choice function (repeat :tag "Functions" function)) + alist)) + +(defcustom transient-minimal-frame-width 83 + "Minimal width of dedicated frame used to display transient menu. + +This is only used if the transient menu is actually displayed in a +dedicated frame (see `transient-display-buffer-action'). The value +is in characters." + :package-version '(transient . "0.8.1") + :group 'transient + :type 'natnum) + +(defcustom transient-mode-line-format 'line + "The mode-line format for transient's menu buffer. + +If nil, then the buffer has no mode-line. If the buffer is not +displayed right above the echo area, then this probably is not +a good value. + +If `line' (the default) or a natural number, then the buffer has no +mode-line, but a line is drawn in its place. If a number is used, +that specifies the thickness of the line. On termcap frames we +cannot draw lines, so there `line' and numbers are synonyms for nil. + +The color of the line is used to indicate if non-suffixes are +allowed and whether they exit the transient. The foreground +color of `transient-key-noop' (if non-suffixes are disallowed), +`transient-key-stay' (if allowed and transient stays active), or +`transient-key-exit' (if allowed and they exit the transient) is +used to draw the line. + +Otherwise this can be any mode-line format. +See `mode-line-format' for details." + :package-version '(transient . "0.2.0") + :group 'transient + :type '(choice (const :tag "Hide mode-line" nil) + (const :tag "Substitute thin line" line) + (number :tag "Substitute line with thickness") + (const :tag "Name of prefix command" + ("%e" mode-line-front-space + mode-line-buffer-identification)) + (sexp :tag "Custom mode-line format"))) + +(defcustom transient-show-common-commands nil + "Whether to permanently show common suffix commands in transient menus. + +By default these commands are only temporarily shown after typing their +shared prefix key \ +\\\\[transient-common-command-prefix], \ +while a transient menu is active. When the value +of this option is non-nil, then these commands are permanently shown. +To toggle the value for the current Emacs session only type \ +\\\\[transient-toggle-common] while +any transient menu is active." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-show-during-minibuffer-read nil + "Whether to show the transient menu while reading in the minibuffer. + +This is only relevant to commands that do not close the menu, such as +commands that set infix arguments. If a command exits the menu, and +uses the minibuffer, then the menu is always closed before the +minibuffer is entered, irrespective of the value of this option. + +When nil (the default), hide the menu while the minibuffer is in use. +When t, keep showing the menu, but allow for the menu window to be +resized, to ensure that completion candidates can be displayed. + +When `fixed', keep showing the menu and prevent it from being resized, +which may make it impossible to display the completion candidates. If +that ever happens for you, consider using t or an integer, as described +below. + +If the value is `fixed' and the menu window uses the full height of its +frame, then the former is ignored and resizing is allowed anyway. This +is necessary because individual menus may use unusual display actions +different from what `transient-display-buffer-action' specifies (likely +to display that menu in a side-window). + +When using a third-party mode, which automatically resizes windows +\(e.g., by calling `balance-windows' on `post-command-hook'), then +`fixed' (or nil) is likely a better choice than t. + +The value can also be an integer, in which case the behavior depends on +whether at least that many lines are left to display windows other than +the menu window. If that is the case, display the menu and preserve the +size of that window. Otherwise, allow resizing the menu window if the +number is positive, or hide the menu if it is negative." + :package-version '(transient . "0.8.0") + :group 'transient + :type '(choice + (const :tag "Hide menu" nil) + (const :tag "Show menu and preserve size" fixed) + (const :tag "Show menu and allow resizing" t) + (natnum :tag "Show menu, allow resizing if less than N lines left" + :format "\n %t: %v" + :value 20) + (integer :tag "Show menu, except if less than N lines left" + :format "\n %t: %v" + :value -20))) + +(defcustom transient-show-docstring-format "%s" + "How to display suffix docstrings. + +The command `transient-toggle-docstrings' toggles between showing suffix +descriptions as usual, and instead or additionally displaying the suffix +docstrings. The format specified here controls how that is done. %c is +the description and %s is the docstring. Use \"%-14c %s\" or similar to +display both. + +This command is not bound by default, see its docstring for instructions." + :package-version '(transient . "0.8.4") + :group 'transient + :type 'string) + +(defcustom transient-read-with-initial-input nil + "Whether to use the last history element as initial minibuffer input." + :package-version '(transient . "0.2.0") + :group 'transient + :type 'boolean) + +(defcustom transient-highlight-mismatched-keys nil + "Whether to highlight keys that do not match their argument. + +This is mostly intended for authors of transient menus and disabled by +default. + +This only affects infix arguments that represent command-line arguments. +When this option is non-nil, then the key binding for infix argument are +highlighted when only a long argument \(e.g., \"--verbose\") is specified +but no shorthand (e.g., \"-v\"). In the rare case that a short-hand is +specified but does not match the key binding, then it is highlighted +differently. + +The highlighting is done using `transient-mismatched-key' +and `transient-nonstandard-key'." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-highlight-higher-levels nil + "Whether to highlight suffixes on higher levels. + +This is primarily intended for package authors. + +When non-nil then highlight the description of suffixes whose +level is above 4, the default of `transient-default-level'. +Assuming you have set that variable to 7, this highlights all +suffixes that won't be available to users without them making +the same customization." + :package-version '(transient . "0.3.6") + :group 'transient + :type 'boolean) + +(defcustom transient-substitute-key-function nil + "Function used to modify key bindings. + +This function is called with one argument, the prefix object, +and must return a key binding description, either the existing +key description it finds in the `key' slot, or a substitution. + +This is intended to let users replace certain prefix keys. It +could also be used to make other substitutions, but that is +discouraged. + +For example, \"=\" is hard to reach using my custom keyboard +layout, so I substitute \"(\" for that, which is easy to reach +using a layout optimized for Lisp. + + (setq transient-substitute-key-function + (lambda (obj) + (let ((key (oref obj key))) + (if (string-match \"\\\\`\\\\(=\\\\)[a-zA-Z]\" key) + (replace-match \"(\" t t key 1) + key)))))" + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "Transform no keys (nil)" nil) function)) + +(defcustom transient-semantic-coloring t + "Whether to use colors to indicate transient behavior. + +If non-nil, then the key binding of each suffix is colorized to +indicate whether it exits the transient state or not, and the +line that is drawn below transient's menu buffer is used to +indicate the behavior of non-suffix commands." + :package-version '(transient . "0.5.0") + :group 'transient + :type 'boolean) + +(defcustom transient-detect-key-conflicts nil + "Whether to detect key binding conflicts. + +Conflicts are detected when a transient prefix command is invoked +and results in an error, which prevents the transient from being +used." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-error-on-insert-failure nil + "Whether to signal an error when failing to insert a suffix. + +When `transient-insert-suffix' and `transient-append-suffix' fail +to insert a suffix into an existing prefix, they usually just show +a warning. If this is non-nil, they signal an error instead." + :package-version '(transient . "0.8.8") + :group 'transient + :type 'boolean) + +(defcustom transient-align-variable-pitch nil + "Whether to align columns pixel-wise in the menu buffer. + +If this is non-nil, then columns are aligned pixel-wise to +support variable-pitch fonts. Keys are not aligned, so you +should use a fixed-pitch font for the `transient-key' face. +Other key faces inherit from that face unless a theme is +used that breaks that relationship. + +This option is intended for users who use a variable-pitch +font for the `default' face. + +See also `transient-force-fixed-pitch'." + :package-version '(transient . "0.4.0") + :group 'transient + :type 'boolean) + +(defcustom transient-force-fixed-pitch nil + "Whether to force use of monospaced font in the menu buffer. + +Even if you use a proportional font for the `default' face, +you might still want to use a monospaced font in transient's +menu buffer. Setting this option to t causes `default' to +be remapped to `fixed-pitch' in that buffer. + +See also `transient-align-variable-pitch'." + :package-version '(transient . "0.2.0") + :group 'transient + :type 'boolean) + +(defcustom transient-force-single-column nil + "Whether to force use of a single column to display suffixes. + +This might be useful for users with low vision who use large +text and might otherwise have to scroll in two dimensions." + :package-version '(transient . "0.3.6") + :group 'transient + :type 'boolean) + +(defconst transient--max-level 7) +(defconst transient--default-child-level 1) +(defconst transient--default-prefix-level 4) + +(defcustom transient-default-level transient--default-prefix-level + "Control what suffix levels are made available by default. + +Each suffix command is placed on a level and each prefix command +has a level, which controls which suffix commands are available. +Integers between 1 and 7 (inclusive) are valid levels. + +The levels of individual transients and/or their individual +suffixes can be changed individually, by invoking the prefix and +then pressing \\\\[transient-set-level]. + +The default level for both transients and their suffixes is 4. +This option only controls the default for transients. The default +suffix level is always 4. The author of a transient should place +certain suffixes on a higher level if they expect that it won't be +of use to most users, and they should place very important suffixes +on a lower level so that they remain available even if the user +lowers the transient level. + +\(Magit currently places nearly all suffixes on level 4 and lower +levels are not used at all yet. So for the time being you should +not set a lower level here and using a higher level might not +give you as many additional suffixes as you hoped.)" + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "1 - fewest suffixes" 1) + (const 2) + (const 3) + (const :tag "4 - default" 4) + (const 5) + (const 6) + (const :tag "7 - most suffixes" 7))) + +(defcustom transient-levels-file + (locate-user-emacs-file "transient/levels.el") + "File used to save levels of transients and their suffixes." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-values-file + (locate-user-emacs-file "transient/values.el") + "File used to save values of transients." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-history-file + (locate-user-emacs-file "transient/history.el") + "File used to save history of transients and their infixes." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-history-limit 10 + "Number of history elements to keep when saving to file." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'integer) + +(defcustom transient-save-history t + "Whether to save history of transient commands when exiting Emacs." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +;;; Faces + +(defgroup transient-faces nil + "Faces used by Transient." + :group 'transient) + +(defface transient-heading '((t :inherit font-lock-keyword-face)) + "Face used for headings." + :group 'transient-faces) + +(defface transient-argument '((t :inherit font-lock-string-face :weight bold)) + "Face used for enabled arguments." + :group 'transient-faces) + +(defface transient-inactive-argument '((t :inherit shadow)) + "Face used for inactive arguments." + :group 'transient-faces) + +(defface transient-inapt-argument '((t :inherit shadow :weight bold)) + "Face used for inapt arguments with a (currently ignored) value. +Depending on the type this is used for the argument and/or value." + :group 'transient-faces) + +(defface transient-value '((t :inherit font-lock-string-face :weight bold)) + "Face used for values." + :group 'transient-faces) + +(defface transient-inactive-value '((t :inherit shadow)) + "Face used for inactive values." + :group 'transient-faces) + +(defface transient-unreachable '((t :inherit shadow)) + "Face used for suffixes unreachable from the current prefix sequence." + :group 'transient-faces) + +(defface transient-inapt-suffix '((t :inherit shadow :slant italic)) + "Face used for suffixes that are inapt at this time." + :group 'transient-faces) + +(defface transient-active-infix '((t :inherit highlight)) + "Face used for the infix for which the value is being read." + :group 'transient-faces) + +(defface transient-enabled-suffix + '((t :background "green" :foreground "black" :weight bold)) + "Face used for enabled levels while editing suffix levels. +See info node `(transient)Enabling and Disabling Suffixes'." + :group 'transient-faces) + +(defface transient-disabled-suffix + '((t :background "red" :foreground "black" :weight bold)) + "Face used for disabled levels while editing suffix levels. +See info node `(transient)Enabling and Disabling Suffixes'." + :group 'transient-faces) + +(defface transient-higher-level + (let* ((color (face-attribute 'shadow :foreground t t)) + (color (if (eq color 'unspecified) "grey60" color))) + `((t :box (:line-width (-1 . -1) :color ,color)))) + "Face optionally used to highlight suffixes on higher levels. +See also option `transient-highlight-higher-levels'." + :group 'transient-faces) + +(defface transient-delimiter '((t :inherit shadow)) + "Face used for delimiters and separators. +This includes the parentheses around values and the pipe +character used to separate possible values from each other." + :group 'transient-faces) + +(defface transient-key '((t :inherit font-lock-builtin-face)) + "Face used for keys." + :group 'transient-faces) + +(defface transient-key-stay + `((((class color) (background light)) + :inherit transient-key + :foreground "#22aa22") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ddffdd")) + "Face used for keys of suffixes that don't exit the menu." + :group 'transient-faces) + +(defface transient-key-noop + `((((class color) (background light)) + :inherit transient-key + :foreground "grey80") + (((class color) (background dark)) + :inherit transient-key + :foreground "grey30")) + "Face used for keys of suffixes that currently cannot be invoked." + :group 'transient-faces) + +(defface transient-key-return + `((((class color) (background light)) + :inherit transient-key + :foreground "#aaaa11") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ffffcc")) + "Face used for keys of suffixes that return to the parent menu." + :group 'transient-faces) + +(defface transient-key-recurse + `((((class color) (background light)) + :inherit transient-key + :foreground "#2266ff") + (((class color) (background dark)) + :inherit transient-key + :foreground "#2299ff")) + "Face used for keys of sub-menus whose suffixes return to the parent menu." + :group 'transient-faces) + +(defface transient-key-stack + `((((class color) (background light)) + :inherit transient-key + :foreground "#dd4488") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ff6699")) + "Face used for keys of sub-menus that exit the parent menu." + :group 'transient-faces) + +(defface transient-key-exit + `((((class color) (background light)) + :inherit transient-key + :foreground "#aa2222") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ffdddd")) + "Face used for keys of suffixes that exit the menu." + :group 'transient-faces) + +(defface transient-unreachable-key + '((t :inherit (shadow transient-key) :weight normal)) + "Face used for keys unreachable from the current prefix sequence." + :group 'transient-faces) + +(defface transient-nonstandard-key + `((t :box (:line-width (-1 . -1) :color "cyan"))) + "Face optionally used to highlight keys conflicting with short-argument. +See also option `transient-highlight-mismatched-keys'." + :group 'transient-faces) + +(defface transient-mismatched-key + `((t :box (:line-width (-1 . -1) :color "magenta"))) + "Face optionally used to highlight keys without a short-argument. +See also option `transient-highlight-mismatched-keys'." + :group 'transient-faces) + +;;; Persistence + +(defun transient--read-file-contents (file) + (with-demoted-errors "Transient error: %S" + (and (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (read (current-buffer)))))) + +(defun transient--pp-to-file (value file) + (when (or value (file-exists-p file)) + (make-directory (file-name-directory file) t) + (setq value (cl-sort (copy-sequence value) #'string< :key #'car)) + (with-temp-file file + (let ((print-level nil) + (print-length nil) + (pp-default-function 'pp-28) + (fill-column 999)) + (pp value (current-buffer)))))) + +(defvar transient-values + (transient--read-file-contents transient-values-file) + "Values of transient commands. +The value of this variable persists between Emacs sessions +and you usually should not change it manually.") + +(defun transient-save-values () + (transient--pp-to-file transient-values transient-values-file)) + +(defvar transient-levels + (transient--read-file-contents transient-levels-file) + "Levels of transient commands. +The value of this variable persists between Emacs sessions +and you usually should not change it manually.") + +(defun transient-save-levels () + (transient--pp-to-file transient-levels transient-levels-file)) + +(defvar transient-history + (transient--read-file-contents transient-history-file) + "History of transient commands and infix arguments. +The value of this variable persists between Emacs sessions +\(unless `transient-save-history' is nil) and you usually +should not change it manually.") + +(defun transient-save-history () + (setq transient-history + (cl-sort (mapcar (pcase-lambda (`(,key . ,val)) + (cons key (seq-take (delete-dups val) + transient-history-limit))) + transient-history) + #'string< :key #'car)) + (transient--pp-to-file transient-history transient-history-file)) + +(defun transient-maybe-save-history () + "Save the value of `transient-history'. +If `transient-save-history' is nil, then do nothing." + (when transient-save-history + (with-demoted-errors "Error saving transient history: %S" + (transient-save-history)))) + +(unless noninteractive + (add-hook 'kill-emacs-hook #'transient-maybe-save-history)) + +;;; Classes +;;;; Prefix + +(defclass transient-prefix () + ((prototype :initarg :prototype) + (command :initarg :command) + (level :initarg :level) + (init-value :initarg :init-value) + (value) (default-value :initarg :value) + (return :initarg :return :initform nil) + (scope :initarg :scope :initform nil) + (history :initarg :history :initform nil) + (history-pos :initarg :history-pos :initform 0) + (history-key :initarg :history-key :initform nil) + (show-help :initarg :show-help :initform nil) + (info-manual :initarg :info-manual :initform nil) + (man-page :initarg :man-page :initform nil) + (transient-suffix :initarg :transient-suffix :initform nil) + (transient-non-suffix :initarg :transient-non-suffix :initform nil) + (transient-switch-frame :initarg :transient-switch-frame) + (refresh-suffixes :initarg :refresh-suffixes :initform nil) + (remember-value :initarg :remember-value :initform nil) + (environment :initarg :environment :initform nil) + (incompatible :initarg :incompatible :initform nil) + (suffix-description :initarg :suffix-description) + (display-action :initarg :display-action :initform nil) + (mode-line-format :initarg :mode-line-format) + (variable-pitch :initarg :variable-pitch :initform nil) + (column-widths :initarg :column-widths :initform nil) + (unwind-suffix :documentation "Internal use." :initform nil)) + "Transient prefix command. + +Each transient prefix command consists of a command, which is +stored in a symbol's function slot and an object, which is +stored in the `transient--prefix' property of the same symbol. + +When a transient prefix command is invoked, then a clone of that +object is stored in the global variable `transient--prefix' and +the prototype is stored in the clone's `prototype' slot.") + +;;;; Suffix + +(defclass transient-child () + ((parent + :initarg :parent + :initform nil + :documentation "The parent group object.") + (level + :initarg :level + :initform nil + :documentation "Enable if level of prefix is equal or greater.") + (inactive + :initform nil) + (if + :initarg :if + :initform nil + :documentation "Enable if predicate returns non-nil.") + (if-not + :initarg :if-not + :initform nil + :documentation "Enable if predicate returns nil.") + (if-non-nil + :initarg :if-non-nil + :initform nil + :documentation "Enable if variable's value is non-nil.") + (if-nil + :initarg :if-nil + :initform nil + :documentation "Enable if variable's value is nil.") + (if-mode + :initarg :if-mode + :initform nil + :documentation "Enable if major-mode matches value.") + (if-not-mode + :initarg :if-not-mode + :initform nil + :documentation "Enable if major-mode does not match value.") + (if-derived + :initarg :if-derived + :initform nil + :documentation "Enable if major-mode derives from value.") + (if-not-derived + :initarg :if-not-derived + :initform nil + :documentation "Enable if major-mode does not derive from value.") + (inapt + :initform nil) + (inapt-face + :initarg :inapt-face + :initform 'transient-inapt-suffix) + (inapt-if + :initarg :inapt-if + :initform nil + :documentation "Inapt if predicate returns non-nil.") + (inapt-if-not + :initarg :inapt-if-not + :initform nil + :documentation "Inapt if predicate returns nil.") + (inapt-if-non-nil + :initarg :inapt-if-non-nil + :initform nil + :documentation "Inapt if variable's value is non-nil.") + (inapt-if-nil + :initarg :inapt-if-nil + :initform nil + :documentation "Inapt if variable's value is nil.") + (inapt-if-mode + :initarg :inapt-if-mode + :initform nil + :documentation "Inapt if major-mode matches value.") + (inapt-if-not-mode + :initarg :inapt-if-not-mode + :initform nil + :documentation "Inapt if major-mode does not match value.") + (inapt-if-derived + :initarg :inapt-if-derived + :initform nil + :documentation "Inapt if major-mode derives from value.") + (inapt-if-not-derived + :initarg :inapt-if-not-derived + :initform nil + :documentation "Inapt if major-mode does not derive from value.") + (advice + :initarg :advice + :initform nil + :documentation "Advise applied to the command body.") + (advice* + :initarg :advice* + :initform nil + :documentation "Advise applied to the command body and interactive spec.")) + "Abstract superclass for group and suffix classes. + +It is undefined which predicates are used if more than one `if*' +predicate slots or more than one `inapt-if*' slots are non-nil." + :abstract t) + +(defclass transient-suffix (transient-child) + ((definition :allocation :class :initform nil) + (key :initarg :key) + (command :initarg :command) + (transient :initarg :transient) + (format :initarg :format :initform " %k %d") + (description :initarg :description :initform nil) + (face :initarg :face :initform nil) + (show-help :initarg :show-help :initform nil) + (summary :initarg :summary :initform nil)) + "Superclass for suffix command.") + +(defclass transient-information (transient-suffix) + ((format :initform " %k %d") + (key :initform " ")) + "Display-only information, aligned with suffix keys. +Technically a suffix object with no associated command.") + +(defclass transient-information* (transient-information) + ((format :initform " %d")) + "Display-only information, aligned with suffix descriptions. +Technically a suffix object with no associated command.") + +(defclass transient-infix (transient-suffix) + ((transient :initform t) + (argument :initarg :argument) + (shortarg :initarg :shortarg) + (value :initform nil) + (init-value :initarg :init-value) + (unsavable :initarg :unsavable :initform nil) + (multi-value :initarg :multi-value :initform nil) + (always-read :initarg :always-read :initform nil) + (allow-empty :initarg :allow-empty :initform nil) + (history-key :initarg :history-key :initform nil) + (reader :initarg :reader :initform nil) + (prompt :initarg :prompt :initform nil) + (choices :initarg :choices :initform nil) + (format :initform " %k %d (%v)")) + "Transient infix command." + :abstract t) + +(defclass transient-argument (transient-infix) () + "Abstract superclass for infix arguments." + :abstract t) + +(defclass transient-switch (transient-argument) () + "Class used for command-line argument that can be turned on and off.") + +(defclass transient-option (transient-argument) () + "Class used for command-line argument that can take a value.") + +(defclass transient-variable (transient-infix) + ((variable :initarg :variable) + (format :initform " %k %d %v")) + "Abstract superclass for infix commands that set a variable." + :abstract t) + +(defclass transient-switches (transient-argument) + ((argument-format :initarg :argument-format) + (argument-regexp :initarg :argument-regexp)) + "Class used for sets of mutually exclusive command-line switches.") + +(defclass transient-files (transient-option) () + ((key :initform "--") + (argument :initform "--") + (multi-value :initform rest) + (reader :initform transient-read-files)) + "Class used for the \"--\" argument or similar. +All remaining arguments are treated as files. +They become the value of this argument.") + +(defclass transient-value-preset (transient-suffix) + ((transient :initform t) + (set :initarg := :initform nil)) + "Class used by the `transient-preset' suffix command.") + +(defclass transient-describe-target (transient-suffix) + ((transient :initform #'transient--do-suspend) + (helper :initarg :helper :initform nil) + (target :initarg := :initform nil)) + "Class used by the `transient-describe' suffix command.") + +;;;; Group + +(defclass transient-group (transient-child) + ((suffixes :initarg :suffixes :initform nil) + (hide :initarg :hide :initform nil) + (description :initarg :description :initform nil) + (pad-keys :initarg :pad-keys :initform nil) + (info-format :initarg :info-format :initform nil) + (setup-children :initarg :setup-children)) + "Abstract superclass of all group classes." + :abstract t) + +(defclass transient-column (transient-group) () + "Group class that displays each element on a separate line.") + +(defclass transient-row (transient-group) () + "Group class that displays all elements on a single line.") + +(defclass transient-columns (transient-group) () + "Group class that displays elements organized in columns. +Direct elements have to be groups whose elements have to be +commands or strings. Each subgroup represents a column. +This class takes care of inserting the subgroups' elements.") + +(defclass transient-subgroups (transient-group) () + "Group class that wraps other groups. + +Direct elements have to be groups whose elements have to be +commands or strings. This group inserts an empty line between +subgroups. The subgroups are responsible for displaying their +elements themselves.") + +;;; Define + +(defmacro transient-define-prefix (name arglist &rest args) + "Define NAME as a transient prefix command. + +ARGLIST are the arguments that command takes. +DOCSTRING is the documentation string and is optional. + +These arguments can optionally be followed by key-value pairs. +Each key has to be a keyword symbol, either `:class' or a keyword +argument supported by the constructor of that class. The +`transient-prefix' class is used if the class is not specified +explicitly. + +GROUPs add key bindings for infix and suffix commands and specify +how these bindings are presented in the menu buffer. At least +one GROUP has to be specified. See info node `(transient)Binding +Suffix and Infix Commands'. + +The BODY is optional. If it is omitted, then ARGLIST is also +ignored and the function definition becomes: + + (lambda () + (interactive) + (transient-setup \\='NAME)) + +If BODY is specified, then it must begin with an `interactive' +form that matches ARGLIST, and it must call `transient-setup'. +It may however call that function only when some condition is +satisfied; that is one of the reason why you might want to use +an explicit BODY. + +All transients have a (possibly nil) value, which is exported +when suffix commands are called, so that they can consume that +value. For some transients it might be necessary to have a sort +of secondary value, called a scope. Such a scope would usually +be set in the commands `interactive' form and has to be passed +to the setup function: + + (transient-setup \\='NAME nil nil :scope SCOPE) + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + [&rest vectorp] + [&optional ("interactive" interactive) def-body])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,groups ,docstr ,body ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-prefix))) + `(progn + (defalias ',name + ,(if body + `(lambda ,arglist ,@body) + `(lambda () + (interactive) + (transient-setup ',name)))) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--prefix + (,(or class 'transient-prefix) :command ',name ,@slots)) + (transient--set-layout + ',name + (list ,@(mapcan (lambda (s) (transient--parse-child name s)) groups)))))) + +(defmacro transient-define-group (name &rest groups) + "Define one or more groups and store them in symbol NAME. + +Groups defined using this macro, can be used inside the +definition of transient prefix commands, by using the symbol +NAME where a group vector is expected. GROUPS has the same +form as for `transient-define-prefix'." + (declare (debug (&define name [&rest vectorp])) + (indent defun)) + `(transient--set-layout + ',name + (list ,@(mapcan (lambda (s) (transient--parse-child name s)) groups)))) + +(defmacro transient-define-suffix (name arglist &rest args) + "Define NAME as a transient suffix command. + +ARGLIST are the arguments that the command takes. +DOCSTRING is the documentation string and is optional. + +These arguments can optionally be followed by key-value pairs. +Each key has to be a keyword symbol, either `:class' or a +keyword argument supported by the constructor of that class. +The `transient-suffix' class is used if the class is not +specified explicitly. + +The BODY must begin with an `interactive' form that matches +ARGLIST. The infix arguments are usually accessed by using +`transient-args' inside `interactive'. + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... [BODY...])" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + [&optional ("interactive" interactive) def-body])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,_ ,docstr ,body ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-suffix))) + `(progn + (defalias ',name + ,(if (and (not body) class (oref-default class definition)) + `(oref-default ',class definition) + `(lambda ,arglist ,@body))) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--suffix + (,(or class 'transient-suffix) :command ',name ,@slots))))) + +(defmacro transient-augment-suffix (name &rest args) + "Augment existing command NAME with a new transient suffix object. +Similar to `transient-define-suffix' but define a suffix object only. +\n\(fn NAME [KEYWORD VALUE]...)" + (declare (debug (&define name [&rest keywordp sexp])) + (indent defun)) + (pcase-let + ((`(,class ,slots) + (transient--expand-define-args args nil 'transient-augment-suffix t))) + `(put ',name 'transient--suffix + (,(or class 'transient-suffix) :command ',name ,@slots)))) + +(defmacro transient-define-infix (name arglist &rest args) + "Define NAME as a transient infix command. + +ARGLIST is always ignored and reserved for future use. +DOCSTRING is the documentation string and is optional. + +At least one key-value pair is required. All transient infix +commands are equal to each other (but not eq). It is meaning- +less to define an infix command, without providing at least one +keyword argument (usually `:argument' or `:variable', depending +on the class). The suffix class defaults to `transient-switch' +and can be set using the `:class' keyword. + +The function definitions is always: + + (lambda () + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) + +`transient-infix-read' and `transient-infix-set' are generic +functions. Different infix commands behave differently because +the concrete methods are different for different infix command +classes. In rare case the above command function might not be +suitable, even if you define your own infix command class. In +that case you have to use `transient-define-suffix' to define +the infix command and use t as the value of the `:transient' +keyword. + +\(fn NAME ARGLIST [DOCSTRING] KEYWORD VALUE [KEYWORD VALUE]...)" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + keywordp sexp + [&rest keywordp sexp])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,_ ,docstr ,_ ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-infix t))) + `(progn + (defalias ',name #'transient--default-infix-command) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'completion-predicate #'transient--suffix-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--suffix + (,(or class 'transient-switch) :command ',name ,@slots))))) + +(defalias 'transient-define-argument #'transient-define-infix + "Define NAME as a transient infix command. + +Only use this alias to define an infix command that actually +sets an infix argument. To define a infix command that, for +example, sets a variable, use `transient-define-infix' instead. + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)") + +(defun transient--default-infix-command () + ;; Most infix commands are but an alias for this command. + "Cannot show any documentation for this transient infix command. + +When you request help for an infix command using `transient-help', that +usually shows the respective man-page and tries to jump to the location +where the respective argument is being described. + +If no man-page is specified for the containing transient menu, then the +docstring is displayed instead, if any. + +If the infix command doesn't have a docstring, as is the case here, then +this docstring is displayed instead, because technically infix commands +are aliases for `transient--default-infix-command'. + +`describe-function' also shows the docstring of the infix command, +falling back to that of the same aliased command." + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) +(put 'transient--default-infix-command 'interactive-only t) +(put 'transient--default-infix-command 'completion-predicate + #'transient--suffix-only) + +(define-advice find-function-advised-original + (:around (fn func) transient-default-infix) + "Return nil instead of `transient--default-infix-command'. +When using `find-function' to jump to the definition of a transient +infix command/argument, then we want to actually jump to that, not to +the definition of `transient--default-infix-command', which all infix +commands are aliases for." + (let ((val (funcall fn func))) + (and val (not (eq val 'transient--default-infix-command)) val))) + +(eval-and-compile ;transient--expand-define-args + (defun transient--expand-define-args (args &optional arglist form nobody) + ;; ARGLIST and FORM are only optional for backward compatibility. + ;; This is necessary because "emoji.el" from Emacs 29 calls this + ;; function directly, with just one argument. + (declare (advertised-calling-convention + (args arglist form &optional nobody) "0.7.1")) + (unless (listp arglist) + (error "Mandatory ARGLIST is missing")) + (let (class keys suffixes docstr declare (interactive-only t)) + (when (stringp (car args)) + (setq docstr (pop args))) + (while (keywordp (car args)) + (let ((k (pop args)) + (v (pop args))) + (if (eq k :class) + (setq class v) + (push k keys) + (push v keys)))) + (while-let* + ((arg (car args)) + (arg (cond + ;; Inline group definition. + ((vectorp arg) + (pop args)) + ;; Quoted include, as one would expect. + ((eq (car-safe arg) 'quote) + (cadr (pop args))) + ;; Unquoted include, for compatibility. + ((and arg (symbolp arg)) + (pop args))))) + (push arg suffixes)) + (when (eq (car-safe (car args)) 'declare) + (setq declare (car args)) + (setq args (cdr args)) + (when-let ((int (assq 'interactive-only declare))) + (setq interactive-only (cadr int)) + (delq int declare)) + (unless (cdr declare) + (setq declare nil))) + (cond + ((not args)) + (nobody + (error "%s: No function body allowed" form)) + ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive)) + (error "%s: Interactive form missing" form))) + (list (if (eq (car-safe class) 'quote) + (cadr class) + class) + (nreverse keys) + (nreverse suffixes) + docstr + (if declare (cons declare args) args) + interactive-only)))) + +(defun transient--parse-child (prefix spec) + (cl-typecase spec + (null (error "Invalid transient--parse-child spec: %s" spec)) + (symbol (list `',spec)) + (vector (and$ (transient--parse-group prefix spec) (list $))) + (list (and$ (transient--parse-suffix prefix spec) (list $))) + (string (list spec)) + (t (error "Invalid transient--parse-child spec: %s" spec)))) + +(defun transient--parse-group (prefix spec) + (let (class args) + (setq spec (append spec nil)) + (when (integerp (car spec)) + (setq args (plist-put args :level (pop spec)))) + (when (stringp (car spec)) + (setq args (plist-put args :description (pop spec)))) + (while (keywordp (car spec)) + (let* ((key (pop spec)) + (val (if spec (pop spec) (error "No value for `%s'" key)))) + (cond ((eq key :class) + (setq class val)) + ((or (symbolp val) + (and (listp val) + (not (memq (car val) (list 'lambda (intern "")))))) + (setq args (plist-put args key (macroexp-quote val)))) + ((setq args (plist-put args key val)))))) + (unless (or spec class (not (plist-get args :setup-children))) + (message "WARNING: %s: When %s is used, %s must also be specified" + 'transient-define-prefix :setup-children :class)) + (list 'vector + (list 'quote + (cond (class) + ((cl-typep (car spec) + '(or vector (and symbol (not null)))) + 'transient-columns) + ('transient-column))) + (and args (cons 'list args)) + (cons 'list + (mapcan (lambda (s) (transient--parse-child prefix s)) spec))))) + +(defun transient--parse-suffix (prefix spec) + (let (class args) + (cl-flet ((use (prop value) + (setq args (plist-put args prop value)))) + (pcase (car spec) + ((cl-type integer) + (use :level (pop spec)))) + (pcase (car spec) + ((cl-type (or string vector)) + (use :key (pop spec)))) + (pcase (car spec) + ((guard (or (stringp (car spec)) + (and (eq (car-safe (car spec)) 'lambda) + (not (commandp (car spec)))))) + (use :description (pop spec))) + ((and (cl-type (and symbol (not keyword) (not command))) + (guard (commandp (cadr spec)))) + (use :description (macroexp-quote (pop spec))))) + (pcase (car spec) + ((or :info :info* :cons)) + ((and (cl-type keyword) invalid) + (error "Need command, argument, `:info', `:info*' or `:cons'; got `%s'" + invalid)) + ((cl-type symbol) + (use :command (macroexp-quote (pop spec)))) + ;; During macro-expansion this is expected to be a `lambda' + ;; expression (i.e., source code). When this is called from a + ;; `:setup-children' function, it may also be a function object + ;; (a.k.a a function value). However, we never treat a string + ;; as a command, so we have to check for that explicitly. + ((cl-type (and command (not string))) + (let ((cmd (pop spec)) + (sym (intern + (format + "transient:%s:%s:%d" prefix + (replace-regexp-in-string (plist-get args :key) " " "") + (prog1 gensym-counter (cl-incf gensym-counter)))))) + (use :command + `(prog1 ',sym + (put ',sym 'interactive-only t) + (put ',sym 'completion-predicate #'transient--suffix-only) + (defalias ',sym ,cmd))))) + ((cl-type (or string (and list (not null)))) + (let ((arg (pop spec))) + (cl-typecase arg + (list + (use :shortarg (car arg)) + (use :argument (cadr arg)) + (setq arg (cadr arg))) + (string + (when-let ((shortarg (transient--derive-shortarg arg))) + (use :shortarg shortarg)) + (use :argument arg))) + (use :command + (let ((sym (intern (format "transient:%s:%s" prefix arg)))) + `(prog1 ',sym + (put ',sym 'interactive-only t) + (put ',sym 'completion-predicate #'transient--suffix-only) + (defalias ',sym #'transient--default-infix-command)))) + (pcase (car spec) + ((cl-type (and (not null) (not keyword))) + (setq class 'transient-option) + (use :reader (macroexp-quote (pop spec)))) + ((guard (string-suffix-p "=" arg)) + (setq class 'transient-option)) + (_ (setq class 'transient-switch))))) + (invalid + (error "Need command, argument, `:info' or `:info*'; got %s" invalid))) + (while (keywordp (car spec)) + (let* ((key (pop spec)) + (val (if spec (pop spec) (error "No value for `%s'" key)))) + (pcase key + (:class (setq class val)) + (:info (setq class 'transient-information) + (use :description val)) + (:info* (setq class 'transient-information*) + (use :description val)) + (:cons + (setq class 'transient-cons-option) + (use :command + (let ((sym (intern (format "transient:%s:%s" prefix val)))) + `(prog1 ',sym + (put ',sym 'interactive-only t) + (put ',sym 'completion-predicate #'transient--suffix-only) + (defalias ',sym #'transient--default-infix-command)))) + (use :argument val)) + ((guard (eq (car-safe val) '\,)) + (use key (cadr val))) + ((guard (or (symbolp val) + (and (listp val) + (not (memq (car val) (list 'lambda (intern ""))))))) + (use key (macroexp-quote val))) + (_ (use key val))))) + (when spec + (error "Need keyword, got %S" (car spec))) + (cond-let + ([key (plist-get args :key)] + (when (string-match "\\`\\({p}\\)" key) + (use :key + (replace-match transient-common-command-prefix t t key 1)))) + ([shortarg (plist-get args :shortarg)] + (use :key shortarg)))) + (list 'cons + (macroexp-quote (or class 'transient-suffix)) + (cons 'list args)))) + +(defun transient--derive-shortarg (arg) + (save-match-data + (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) + (match-string 1 arg)))) + +(defun transient-command-completion-not-suffix-only-p (symbol _buffer) + "Say whether SYMBOL should be offered as a completion. +If the value of SYMBOL's `completion-predicate' property is +`transient--suffix-only', then return nil, otherwise return t. +This is the case when a command should only ever be used as a +suffix of a transient prefix command (as opposed to bindings +in regular keymaps or by using `execute-extended-command')." + (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) + +(defalias 'transient--suffix-only #'ignore + "Ignore ARGUMENTS, do nothing, and return nil. +See also `transient-command-completion-not-suffix-only-p'. +Only use this alias as the value of the `completion-predicate' +symbol property.") + +(unless read-extended-command-predicate + (setq read-extended-command-predicate + #'transient-command-completion-not-suffix-only-p)) + +(defun transient--set-layout (prefix layout) + (put prefix 'transient--layout (vector 2 nil layout))) + +(defun transient--get-layout (prefix) + (cond-let + [[layout (or (get prefix 'transient--layout) + ;; Migrate unparsed legacy group definition. + (condition-case-unless-debug err + (and-let* ((value (symbol-value prefix))) + (transient--set-layout + prefix + (if (and (listp value) + (or (listp (car value)) + (vectorp (car value)))) + (transient-parse-suffixes prefix value) + (list (transient-parse-suffix prefix value))))) + (error + (message "Not a legacy group definition: %s: %S" prefix err) + nil)))]] + ((not layout) + (error "Not a transient prefix command or group definition: %s" prefix)) + ((vectorp layout) + (let ((version (aref layout 0))) + (if (= version 2) + layout + (error "Unsupported layout version %s for %s" version prefix)))) + (t + ;; Upgrade from version 1. + (transient--set-layout + prefix + (named-let upgrade ((spec layout)) + (cond ((vectorp spec) + (pcase-let ((`[,level ,class ,args ,children] spec)) + (when level + (setq args (plist-put args :level level))) + (vector class args (mapcar #'upgrade children)))) + ((and (listp spec) + (length= spec 3) + (or (null (car spec)) + (natnump (car spec))) + (symbolp (cadr spec))) + (pcase-let ((`(,level ,class ,args) spec)) + (when level + (setq args (plist-put args :level level))) + (cons class args))) + ((listp spec) + (mapcar #'upgrade spec)) + (t spec))))))) + +(defun transient--get-children (prefix) + (aref (transient--get-layout prefix) 2)) + +(defun transient-parse-suffix (prefix suffix) + "Parse SUFFIX, to be added to PREFIX. +PREFIX is a prefix command symbol or object. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +Intended for use in a group's `:setup-children' function." + (when (cl-typep prefix 'transient-prefix) + (setq prefix (oref prefix command))) + (eval (car (transient--parse-child prefix suffix)) t)) + +(defun transient-parse-suffixes (prefix suffixes) + "Parse SUFFIXES, to be added to PREFIX. +PREFIX is a prefix command symbol or object. +SUFFIXES is a list of suffix command or a group specification + (of the same forms as expected by `transient-define-prefix'). +Intended for use in a group's `:setup-children' function." + (when (cl-typep prefix 'transient-prefix) + (setq prefix (oref prefix command))) + (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) + +;;; Edit + +(defun transient--insert-suffix (prefix loc suffix action &optional keep-other) + (pcase-let* ((suf (cl-etypecase suffix + (vector (eval (transient--parse-group prefix suffix) t)) + (list (eval (transient--parse-suffix prefix suffix) t)) + (string suffix) + (symbol suffix))) + (`(,elt ,group) (transient--locate-child prefix loc))) + (cond + ((not elt) + (funcall (if transient-error-on-insert-failure #'error #'message) + "Cannot insert %S into %s; %s not found" + suffix prefix loc)) + ((or (and (vectorp suffix) (not (vectorp elt))) + (and (listp suffix) (vectorp elt)) + (and (stringp suffix) (vectorp elt))) + (funcall (if transient-error-on-insert-failure #'error #'message) + "Cannot place %S into %s at %s; %s" + suffix prefix loc + "suffixes and groups cannot be siblings")) + (t + (when-let* ((_(not (eq keep-other 'always))) + (bindingp (listp suf)) + (key (transient--suffix-key suf)) + (conflict (car (transient--locate-child prefix key))) + (conflictp + (and (not (and (eq action 'replace) + (eq conflict elt))) + (or (not keep-other) + (eq (plist-get (transient--suffix-props suf) + :command) + (plist-get (transient--suffix-props conflict) + :command))) + (equal (transient--suffix-predicate suf) + (transient--suffix-predicate conflict))))) + (transient-remove-suffix prefix key) + (let ((eg (transient--locate-child prefix loc))) + (setq elt (car eg) group (cadr eg)))) + (let ((mem (memq elt (aref group 2)))) + (pcase-exhaustive action + ('insert (setcdr mem (cons elt (cdr mem))) + (setcar mem suf)) + ('append (setcdr mem (cons suf (cdr mem)))) + ('replace (setcar mem suf)))))))) + +;;;###autoload +(defun transient-insert-suffix (prefix loc suffix &optional keep-other) + "Insert a SUFFIX into PREFIX before LOC. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. When the conflict appears to be a false-positive, + non-nil KEEP-OTHER may be ignored, which can be prevented + by using `always'. +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'insert keep-other)) + +;;;###autoload +(defun transient-append-suffix (prefix loc suffix &optional keep-other) + "Insert a SUFFIX into PREFIX after LOC. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. When the conflict appears to be a false-positive, + non-nil KEEP-OTHER may be ignored, which can be prevented + by using `always'. +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'append keep-other)) + +;;;###autoload +(defun transient-replace-suffix (prefix loc suffix) + "Replace the suffix at LOC in PREFIX with SUFFIX. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'replace)) + +;;;###autoload +(defun transient-inline-group (prefix group) + "Inline the included GROUP into PREFIX. +Replace the symbol GROUP with its expanded layout in the +layout of PREFIX." + (declare (indent defun)) + (cl-assert (symbolp group)) + (pcase-let ((`(,suffix ,parent) (transient--locate-child prefix group))) + (when suffix + (let* ((siblings (aref parent 2)) + (pos (cl-position group siblings))) + (aset parent 2 + (nconc (seq-take siblings pos) + (transient--get-children group) + (seq-drop siblings (1+ pos)))))))) + +;;;###autoload +(defun transient-remove-suffix (prefix loc) + "Remove the suffix or group at LOC in PREFIX. +PREFIX is a prefix command, a symbol. +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (pcase-let ((`(,suffix ,group) (transient--locate-child prefix loc))) + (when suffix + (aset group 2 (delq suffix (aref group 2)))))) + +(defun transient-suffix-put (prefix loc prop value) + "Edit the suffix at LOC in PREFIX, setting PROP to VALUE. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (let ((child (transient-get-suffix prefix loc))) + (if (vectorp child) + (aset child 1 (plist-put (aref child 1) prop value)) + (setcdr child (plist-put (transient--suffix-props child) prop value))))) + +(defalias 'transient--suffix-props #'cdr) + +(defun transient-get-suffix (prefix loc) + "Return the suffix or group at LOC in PREFIX. +PREFIX is a prefix command, a symbol. +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (or (car (transient--locate-child prefix loc)) + (error "%s not found in %s" loc prefix))) + +(defun transient--locate-child (group loc) + (when (symbolp group) + (setq group (transient--get-layout group))) + (when (vectorp loc) + (setq loc (append loc nil))) + (cond-let + ((atom loc) + (seq-some (lambda (child) + (transient--match-child group loc child)) + (aref group 2))) + ([match (transient--nth (pop loc) (aref group 2))] + (cond (loc (transient--locate-child + match (cond ((or (stringp (car loc)) + (symbolp (car loc))) + (car loc)) + ((symbolp match) + (vconcat (cons 0 loc))) + ((vconcat loc))))) + ((list match group)))))) + +(defun transient--match-child (group loc child) + (cl-etypecase child + (string nil) + (symbol (cond-let + ((symbolp loc) + (and (eq child loc) + (list child group))) + ([include (transient--get-layout child)] + (transient--locate-child include loc)))) + (vector (seq-some (lambda (subgroup) + (transient--locate-child subgroup loc)) + (aref group 2))) + (list (and (if (symbolp loc) + (eq (plist-get (transient--suffix-props child) :command) + loc) + (equal (kbd (transient--suffix-key child)) + (kbd loc))) + (list child group))))) + +(defun transient--nth (n list) + (nth (if (< n 0) (- (length list) (abs n)) n) list)) + +(defun transient--suffix-key (spec) + (let ((props (transient--suffix-props spec))) + (or (plist-get props :key) + (transient--command-key + (plist-get props :command))))) + +(defun transient--command-key (cmd) + (and-let* ((obj (transient--suffix-prototype cmd))) + (cond ((slot-boundp obj 'key) + (oref obj key)) + ((slot-exists-p obj 'shortarg) + (if (slot-boundp obj 'shortarg) + (oref obj shortarg) + (transient--derive-shortarg (oref obj argument))))))) + +(defun transient-set-default-level (command level) + "Set the default level of suffix COMMAND to LEVEL. + +The default level is shadowed if the binding of the suffix in a +prefix menu specifies a level, and also if the user changes the +level of such a binding. + +The default level can only be set for commands that were defined +using `transient-define-suffix', `transient-define-infix' or +`transient-define-argument'." + (if-let ((proto (transient--suffix-prototype command))) + (oset proto level level) + (user-error "Cannot set level for `%s'; no prototype object exists" + command))) + +;;; Variables + +(defvar transient-current-prefix nil + "The transient from which this suffix command was invoked. +This is an object representing that transient, use +`transient-current-command' to get the respective command.") + +(defvar transient-current-command nil + "The transient from which this suffix command was invoked. +This is a symbol representing that transient, use +`transient-current-prefix' to get the respective object.") + +(defvar transient-current-suffixes nil + "The suffixes of the transient from which this suffix command was invoked. +This is a list of objects. Usually it is sufficient to instead +use the function `transient-args', which returns a list of +values. In complex cases it might be necessary to use this +variable instead.") + +(defvar transient-exit-hook nil + "Hook run after exiting a transient menu. +Unlike `transient-post-exit-hook', this runs even if another transient +menu becomes active at the same time. ") + +(defvar transient-post-exit-hook nil + "Hook run after exiting all transient menus. +Unlike `transient-exit-hook', this does not run if another transient +menu becomes active at the same time.") + +(defvar transient-setup-buffer-hook nil + "Hook run when setting up the transient buffer. +That buffer is current and empty when this hook runs.") + +(defvar transient--prefix nil) +(defvar transient--layout nil) +(defvar transient--suffixes nil) + +(defconst transient--stay t "Do not exit the transient.") +(defconst transient--exit nil "Do exit the transient.") + +(defvar transient--exitp nil "Whether to exit the transient.") +(defvar transient--showp nil "Whether to show the transient menu buffer.") +(defvar transient--helpp nil "Whether help-mode is active.") +(defvar transient--docsp nil "Whether docstring-mode is active.") +(defvar transient--editp nil "Whether edit-mode is active.") + +(defvar transient--refreshp nil + "Whether to refresh the transient completely.") + +(defvar transient--all-levels-p nil + "Whether temporary display of suffixes on all levels is active.") + +(defvar transient--timer nil) + +(defvar transient--stack nil) + +(defvar transient--minibuffer-depth 0) + +(defvar transient--buffer-name " *transient*" + "Name of the transient buffer.") + +(defvar transient--buffer nil + "The transient menu buffer.") + +(defvar transient--window nil + "The window used to display transient's menu buffer.") + +(defvar transient--original-window nil + "The window that was selected before the transient was invoked. +Usually it remains selected while the transient is active.") + +(defvar transient--original-buffer nil + "The buffer that was current before the transient was invoked. +Usually it remains current while the transient is active.") + +(defvar transient--restore-winconf nil + "Window configuration to restore after exiting help.") + +(defvar transient--shadowed-buffer nil + "The buffer that is temporarily shadowed by the transient buffer. +This is bound while the suffix predicate is being evaluated and while +drawing in the transient buffer.") + +(defvar transient--pending-suffix nil + "The suffix that is currently being processed. +This is bound while the suffix predicate is being evaluated, +and while functions that return faces are being evaluated.") + +(defvar transient--current-suffix nil + "The suffix currently being invoked using a mouse event. +Do not use this; instead use function `transient-suffix-object'.") + +(defvar transient--pending-group nil + "The group that is currently being processed. +This is bound while the suffixes are drawn in the transient buffer.") + +(defvar transient--debug nil + "Whether to put debug information into *Messages*.") + +(defvar transient--history nil) + +(defvar transient--scroll-commands + '(transient-scroll-up + transient-scroll-down + mwheel-scroll + scroll-bar-toolkit-scroll)) + +(defvar transient--quit-commands + '(transient-quit-one + transient-quit-all)) + +;;; Identities + +(defun transient-active-prefix (&optional prefixes) + "Return the active transient object. + +Return nil if there is no active transient, if the transient buffer +isn't shown, and while the active transient is suspended (e.g., while +the minibuffer is in use). + +Unlike `transient-current-prefix', which is only ever non-nil in code +that is run directly by a command that is invoked while a transient +is current, this function is also suitable for use in asynchronous +code, such as timers and callbacks (this function's main use-case). + +If optional PREFIXES is non-nil, it must be a prefix command symbol +or a list of symbols, in which case the active transient object is +only returned if it matches one of PREFIXES." + (and transient--showp + transient--prefix + (or (not prefixes) + (memq (oref transient--prefix command) (ensure-list prefixes))) + (or (memq 'transient--pre-command pre-command-hook) + (and (memq t pre-command-hook) + (memq 'transient--pre-command + (default-value 'pre-command-hook)))) + transient--prefix)) + +(defun transient-prefix-object () + "Return the current prefix as an object. + +While a transient is being setup or refreshed (which involves +preparing its suffixes) the variable `transient--prefix' can be +used to access the prefix object. Thus this is what has to be +used in suffix methods such as `transient-format-description', +and in object-specific functions that are stored in suffix slots +such as `description'. + +When a suffix command is invoked (i.e., in its `interactive' form +and function body) then the variable `transient-current-prefix' +has to be used instead. + +Two distinct variables are needed, because any prefix may itself +be used as a suffix of another prefix, and such sub-prefixes have +to be able to tell themselves apart from the prefix they were +invoked from. + +Regular suffix commands, which are not prefixes, do not have to +concern themselves with this distinction, so they can use this +function instead. In the context of a plain suffix, it always +returns the value of the appropriate variable." + (or transient--prefix transient-current-prefix)) + +(defun transient-suffix-object (&optional command) + "Return the object associated with the current suffix command. + +Each suffix commands is associated with an object, which holds +additional information about the suffix, such as its value (in +the case of an infix command, which is a kind of suffix command). + +This function is intended to be called by infix commands, which +are usually aliases of `transient--default-infix-command', which +is defined like this: + + (defun transient--default-infix-command () + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) + +\(User input is read outside of `interactive' to prevent the +command from being added to `command-history'. See #23.) + +Such commands need to be able to access their associated object +to guide how `transient-infix-read' reads the new value and to +store the read value. Other suffix commands (including non-infix +commands) may also need the object to guide their behavior. + +This function attempts to return the object associated with the +current suffix command even if the suffix command was not invoked +from a transient. (For some suffix command that is a valid thing +to do, for others it is not.) In that case nil may be returned, +if the command was not defined using one of the macros intended +to define such commands. + +The optional argument COMMAND is intended for internal use. If +you are contemplating using it in your own code, then you should +probably use this instead: + + (get COMMAND \\='transient--suffix)" + (when command + (cl-check-type command command)) + (cond-let* + (transient--pending-suffix) + (transient--current-suffix) + ((or transient--prefix + transient-current-prefix) + (let ((suffixes + (cl-remove-if-not + (lambda (obj) + (eq (oref obj command) + (or command + (if (eq this-command 'transient-set-level) + ;; This is how it can look up for which + ;; command it is setting the level. + this-original-command + this-command)))) + (or transient--suffixes + transient-current-suffixes)))) + (cond + ((length= suffixes 1) + (car suffixes)) + ((cl-find-if (lambda (obj) + (equal (listify-key-sequence (kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes)) + ;; COMMAND is only provided if `this-command' is meaningless, in + ;; which case `this-command-keys' is also meaningless, making it + ;; impossible to disambiguate bindings for the same command. + (command (car suffixes)) + ;; If COMMAND is nil, then failure to disambiguate likely means + ;; that there is a bug somewhere. + ((length> suffixes 1) + (error "BUG: Cannot unambiguously determine suffix object")) + ;; It is legimate to use this function as a predicate of sorts. + ;; `transient--pre-command' and `transient-help' are examples. + (t nil)))) + ([obj (transient--suffix-prototype (or command this-command))] + [obj (clone obj)] + (transient-init-scope obj) + (transient-init-value obj) + obj))) + +(defun transient--suffix-prototype (command) + (or (get command 'transient--suffix) + (seq-some (lambda (cmd) (get cmd 'transient--suffix)) + (function-alias-p command)))) + +;;; Keymaps + +(defvar-keymap transient-base-map + :doc "Parent of other keymaps used by Transient. + +This is the parent keymap of all the keymaps that are used in +all transients: `transient-map' (which in turn is the parent +of the transient-specific keymaps), `transient-edit-map' and +`transient-sticky-map'. + +If you change a binding here, then you might also have to edit +`transient-sticky-map' and `transient-common-commands'. While +the latter isn't a proper transient prefix command, it can be +edited using the same functions as used for transients. + +If you add a new command here, then you must also add a binding +to `transient-predicate-map'." + "ESC ESC ESC" #'transient-quit-all + "C-g" #'transient-quit-one + "C-q" #'transient-quit-all + "C-z" #'transient-suspend + "C-v" #'transient-scroll-up + "C-M-v" #'transient-scroll-down + "" #'transient-scroll-up + "" #'transient-scroll-down) + +(defvar-keymap transient-map + :doc "Top-level keymap used by all transients. + +If you add a new command here, then you must also add a binding +to `transient-predicate-map'. See also `transient-base-map'." + :parent transient-base-map + "C-u" #'universal-argument + "C--" #'negative-argument + "C-t" #'transient-show + "?" #'transient-help + "C-h" #'transient-help + "C-x 5 5" #'other-frame-prefix + "C-x 4 4" #'other-window-prefix + ;; These have additional bindings in transient-common-commands. + "C-M-p" #'transient-history-prev + "C-M-n" #'transient-history-next) + +(defvar-keymap transient-edit-map + :doc "Keymap that is active while a transient in is in \"edit mode\"." + :parent transient-base-map + "?" #'transient-help + "C-h" #'transient-help) + +(defvar-keymap transient-sticky-map + :doc "Keymap that is active while an incomplete key sequence is active." + :parent transient-base-map + "C-g" #'transient-quit-seq) + +(defvar transient-common-commands + [:hide (lambda () + (defvar transient--redisplay-key) + (and (not (equal (vconcat transient--redisplay-key) + (read-kbd-macro transient-common-command-prefix))) + (not transient-show-common-commands))) + ["Value commands" + ("{p} s " "Set" transient-set) + ("{p} C-s" "Save" transient-save) + ("{p} C-k" "Reset" transient-reset) + ("{p} p " "Previous value" transient-history-prev) + ("{p} n " "Next value" transient-history-next)] + ["Sticky commands" + ;; Like `transient-sticky-map' except that + ;; "C-g" has to be bound to a different command. + ("C-g" "Quit prefix or transient" transient-quit-one) + ("C-q" "Quit transient stack" transient-quit-all) + ("C-z" "Suspend transient stack" transient-suspend)] + ["Customize" + ("{p} t" transient-toggle-common) + ("{p} l" "Show/hide suffixes" transient-set-level) + ("{p} a" transient-toggle-level-limit)]] + "Commands available in all transient menus. + +The same functions, that are used to change bindings in transient prefix +commands and transient groups (defined using `transient-define-group'), +should be used to modify these bindings as well. The actual layout is +stored in the symbol's `transient--layout' property. The variable value +is only used when customizing `transient-common-command-prefix', which +resets the value of `transient--layout' based on the values of that +option and this variable.") + +(defun transient--init-common-commands () + (transient--set-layout + 'transient-common-commands + (list (eval (car (transient--parse-child 'transient-common-commands + transient-common-commands)) + t))) + (defvar transient-common-command-prefix) + (defvar transient--docstr-hint-1) + (defvar transient--docstr-hint-2) + (setq transient--docstr-hint-1 + (define-keymap transient-common-command-prefix + 'transient-common-command-prefix)) + (setq transient--docstr-hint-2 + (define-keymap (concat transient-common-command-prefix " t") + 'transient-toggle-common))) + +(defcustom transient-common-command-prefix "C-x" + "The prefix key used for most commands common to all menus. + +Some shared commands are available in all transient menus, most of +which share a common prefix specified by this option. By default the +bindings for these shared commands are only shown after pressing that +prefix key and before following that up with a valid key binding. + +For historic reasons \\`C-x' is used by default, but users are +encouraged to pick another key, preferably one that is not commonly used +in Emacs but is still convenient to them. See info node `(transient) +Common Suffix Commands'." + :type 'key + :initialize (lambda (symbol exp) + (custom-initialize-default symbol exp) + (transient--init-common-commands)) + :set (lambda (symbol value) + (set-default symbol value) + (transient--init-common-commands))) + +(defvar-keymap transient-popup-navigation-map + :doc "One of the keymaps used when menu navigation is enabled. +See `transient-enable-popup-navigation'." + "" #'transient-noop + "" #'transient-backward-button + "" #'transient-forward-button + "C-r" #'transient-isearch-backward + "C-s" #'transient-isearch-forward + "M-RET" #'transient-push-button) + +(defvar-keymap transient-button-map + :doc "One of the keymaps used when menu navigation is enabled. +See `transient-enable-popup-navigation'." + "" #'transient-push-button + "" #'transient-push-button) + +(defvar-keymap transient-resume-mode-map + :doc "Keymap for `transient-resume-mode'. + +This keymap remaps every command that would usually just quit the +documentation buffer to `transient-resume', which additionally +resumes the suspended transient." + " " #'transient-resume + " " #'transient-resume + " " #'transient-resume) + +(defvar-keymap transient-predicate-map + :doc "Base keymap used to map common commands to their transient behavior. + +The \"transient behavior\" of a command controls, among other +things, whether invoking the command causes the transient to be +exited or not, and whether infix arguments are exported before +doing so. + +Each \"key\" is a command that is common to all transients and +that is bound in `transient-map', `transient-edit-map', +`transient-sticky-map' and/or `transient-common-command'. + +Each binding is a \"pre-command\", a function that controls the +transient behavior of the respective command. + +For transient commands that are bound in individual transients, +the transient behavior is specified using the `:transient' slot +of the corresponding object." + "" #'transient--do-suspend + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-minus + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-quit-all + "" #'transient--do-quit-all + "" #'transient--do-quit-one + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-call + "" #'transient--do-exit + "" #'transient--do-call + "" #'transient--do-exit + "" #'transient--do-call + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-stay + "" #'transient--do-noop + "" #'transient--do-move + "" #'transient--do-push-button + "" #'transient--do-move + "" #'transient--do-move + "" #'transient--do-move + "" #'transient--do-move + "" #'transient--do-stay + "" #'transient--do-stay + ;; If a valid but incomplete prefix sequence is followed by + ;; an unbound key, then Emacs calls the `undefined' command + ;; but does not set `this-command', `this-original-command' + ;; or `real-this-command' accordingly. Instead they are nil. + "" #'transient--do-warn + ;; Bound to the `mouse-movement' event, this command is similar + ;; to `ignore'. + "" #'transient--do-noop) + +(defvar transient--transient-map nil) +(defvar transient--predicate-map nil) +(defvar transient--redisplay-map nil) +(defvar transient--redisplay-key nil) + +(defun transient--push-keymap (var) + (let ((map (symbol-value var))) + (transient--debug " push %s%s" var (if map "" " VOID")) + (when map + (with-demoted-errors "transient--push-keymap: %S" + (internal-push-keymap map 'overriding-terminal-local-map))))) + +(defun transient--pop-keymap (var) + (let ((map (symbol-value var))) + (when map + (transient--debug " pop %s" var) + (with-demoted-errors "transient--pop-keymap: %S" + (internal-pop-keymap map 'overriding-terminal-local-map))))) + +(defun transient--make-transient-map () + (let ((map (make-sparse-keymap))) + (cond (transient--editp + (keymap-set map (concat transient-common-command-prefix " l") + #'transient-set-level) + (set-keymap-parent map transient-edit-map)) + ((set-keymap-parent map transient-map))) + (dolist (obj transient--suffixes) + (let ((key (oref obj key))) + (when (vectorp key) + (setq key (key-description key)) + (oset obj key key)) + (when transient-substitute-key-function + (setq key (save-match-data + (funcall transient-substitute-key-function obj))) + (oset obj key key)) + (let* ((kbd (kbd key)) + (cmd (oref obj command)) + (alt (transient--lookup-key map kbd))) + (cond ((not alt) + (define-key map kbd cmd)) + ((eq alt cmd)) + ((oref obj inactive)) + ((oref obj inapt)) + ((and-let* ((alt (transient-suffix-object alt))) + (or (oref alt inactive) + (oref alt inapt))) + (define-key map kbd cmd)) + (transient-detect-key-conflicts + (error "Cannot bind %S to %s and also %s" + (string-trim key) cmd alt)) + ((define-key map kbd cmd)))))) + (when$ (keymap-lookup map "-") (keymap-set map "" $)) + (when$ (keymap-lookup map "=") (keymap-set map "" $)) + (when$ (keymap-lookup map "+") (keymap-set map "" $)) + (when transient-enable-popup-navigation + ;; `transient--make-redisplay-map' maps only over bindings that are + ;; directly in the base keymap, so that cannot be a composed keymap. + (set-keymap-parent + map (make-composed-keymap + (keymap-parent map) + transient-popup-navigation-map))) + map)) + +(defun transient--make-predicate-map () + (let ((default (transient--resolve-pre-command + (oref transient--prefix transient-suffix))) + (return (and transient--stack (oref transient--prefix return))) + (map (make-sparse-keymap))) + (set-keymap-parent map transient-predicate-map) + (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) + (transient--resolve-pre-command + (not (oref transient--prefix transient-switch-frame)))) + (memq (transient--resolve-pre-command + (oref transient--prefix transient-non-suffix)) + '(nil transient--do-warn transient--do-noop))) + (define-key map [handle-switch-frame] #'transient--do-suspend)) + (dolist (obj transient--suffixes) + (let* ((cmd (oref obj command)) + (id (vector cmd)) + (kind (cond ((get cmd 'transient--prefix) 'prefix) + ((cl-typep obj 'transient-infix) 'infix) + (t 'suffix))) + (pre (cond + ((oref obj inactive) nil) + ((oref obj inapt) #'transient--do-warn-inapt) + ((slot-boundp obj 'transient) + (pcase (list kind + (transient--resolve-pre-command + (oref obj transient) nil t) + return) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix nil ,_) #'transient--do-stack) + (`(infix t ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(,_ nil ,_) #'transient--do-exit) + (`(,_ ,do ,_) do))) + ((not (lookup-key transient-predicate-map id)) + (pcase (list kind default return) + (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_) + #'transient--do-recurse) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix ,_ ,_) #'transient--do-stack) + (`(infix ,_ ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(suffix nil nil) #'transient--do-exit) + (`(suffix ,do ,_) do)))))) + (when pre + (if-let ((alt (lookup-key map id))) + (unless (eq alt pre) + (define-key map (vconcat (oref obj key) id) pre)) + (define-key map id pre))))) + map)) + +(defun transient--make-redisplay-map () + (setq transient--redisplay-key + (pcase this-command + ('transient-update + (setq transient--showp t) + (let ((keys (listify-key-sequence (this-single-command-raw-keys)))) + (setq unread-command-events (mapcar (lambda (key) (cons t key)) keys)) + keys)) + ('transient-quit-seq + (setq unread-command-events + (butlast (listify-key-sequence + (this-single-command-raw-keys)) + 2)) + (butlast transient--redisplay-key)) + (_ nil))) + (let ((topmap (make-sparse-keymap)) + (submap (make-sparse-keymap))) + (when transient--redisplay-key + (define-key topmap (vconcat transient--redisplay-key) submap) + (set-keymap-parent submap transient-sticky-map)) + (map-keymap-internal + (lambda (key def) + (when (and (not (eq key ?\e)) + (listp def) + (keymapp def)) + (define-key topmap (vconcat transient--redisplay-key (list key)) + #'transient-update))) + (if transient--redisplay-key + (let ((key (vconcat transient--redisplay-key))) + (or (lookup-key transient--transient-map key) + (and-let* ((regular (lookup-key local-function-key-map key))) + (lookup-key transient--transient-map (vconcat regular))))) + transient--transient-map)) + topmap)) + +;;; Setup + +(defun transient-setup (&optional name layout edit &rest params) + "Setup the transient specified by NAME. + +This function is called by transient prefix commands to setup the +transient. In that case NAME is mandatory, LAYOUT and EDIT must +be nil and PARAMS may be (but usually is not) used to set, e.g., +the \"scope\" of the transient (see `transient-define-prefix'). + +This function is also called internally, in which case LAYOUT and +EDIT may be non-nil." + (transient--debug 'setup) + (transient--with-emergency-exit :setup + (cond + ((not name) + ;; Switching between regular and edit mode. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (setq name (oref transient--prefix command)) + (setq params (list :scope (oref transient--prefix scope)))) + (transient--prefix + ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}" + ;; of an outer prefix. Unlike the usual `transient--do-stack', + ;; these predicates fail to clean up after the outer prefix. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map)) + ((not (or layout ; resuming parent/suspended prefix + transient-current-command)) ; entering child prefix + (transient--stack-zap)) ; replace suspended prefix, if any + (edit + ;; Returning from help to edit. + (setq transient--editp t))) + (transient--env-apply + (lambda () + (transient--init-transient name layout params) + (transient--history-init transient--prefix) + (setq transient--original-window (selected-window)) + (setq transient--original-buffer (current-buffer)) + (setq transient--minibuffer-depth (minibuffer-depth)) + (transient--redisplay)) + (get name 'transient--prefix)) + (transient--suspend-text-conversion-style) + (transient--setup-transient) + (transient--suspend-which-key-mode))) + +(cl-defgeneric transient-setup-children (group children) + "Setup the CHILDREN of GROUP. +If the value of the `setup-children' slot is non-nil, then call +that function with CHILDREN as the only argument and return the +value. Otherwise return CHILDREN as is.") + +(cl-defmethod transient-setup-children ((group transient-group) children) + (if (slot-boundp group 'setup-children) + (funcall (oref group setup-children) children) + children)) + +(defun transient--env-apply (fn &optional prefix) + (if-let ((env (oref (or prefix transient--prefix) environment))) + (funcall env fn) + (funcall fn))) + +(defun transient--init-transient (&optional name layout params) + (unless name + ;; Re-init. + (if (eq transient--refreshp 'updated-value) + ;; Preserve the prefix value this once, because the + ;; invoked suffix indicates that it has updated that. + (setq transient--refreshp (oref transient--prefix refresh-suffixes)) + ;; Otherwise update the prefix value from suffix values. + (oset transient--prefix value (transient--get-extended-value)))) + (transient--init-objects name layout params) + (transient--init-keymaps)) + +(defun transient--init-keymaps () + (setq transient--predicate-map (transient--make-predicate-map)) + (setq transient--transient-map (transient--make-transient-map)) + (setq transient--redisplay-map (transient--make-redisplay-map))) + +(defun transient--init-objects (&optional name layout params) + (if name + (setq transient--prefix (transient--init-prefix name params)) + (setq name (oref transient--prefix command))) + (setq transient--refreshp (oref transient--prefix refresh-suffixes)) + (cond ((and (not transient--refreshp) layout) + (setq transient--layout layout) + (setq transient--suffixes (transient--flatten-suffixes layout))) + (t + (setq transient--suffixes nil) + (setq transient--layout (transient--init-suffixes name)) + (setq transient--suffixes (nreverse transient--suffixes)))) + (slot-makeunbound transient--prefix 'value)) + +(defun transient--init-prefix (name &optional params) + (let ((obj (let ((proto (get name 'transient--prefix))) + (apply #'clone proto + :prototype proto + :level (or (alist-get t (alist-get name transient-levels)) + transient-default-level) + params)))) + (transient-init-value obj) + (transient-init-return obj) + (transient-init-scope obj) + obj)) + +(defun transient--init-suffixes (name) + (let ((levels (alist-get name transient-levels))) + (mapcan (lambda (c) (transient--init-child levels c nil)) + (append (transient--get-children name) + (and (not transient--editp) + (transient--get-children 'transient-common-commands)))))) + +(defun transient--flatten-suffixes (layout) + (named-let flatten ((def layout)) + (cond ((stringp def) nil) + ((cl-typep def 'transient-information) nil) + ((listp def) (mapcan #'flatten def)) + ((cl-typep def 'transient-group) + (mapcan #'flatten (oref def suffixes))) + ((cl-typep def 'transient-suffix) + (list def))))) + +(defun transient--init-child (levels spec parent) + (cl-etypecase spec + (symbol (mapcan (lambda (c) (transient--init-child levels c parent)) + (transient--get-children spec))) + (vector (transient--init-group levels spec parent)) + (list (transient--init-suffix levels spec parent)) + (string (list spec)))) + +(defun transient--init-group (levels spec parent) + (pcase-let* ((`[,class ,args ,children] spec) + (level (or (plist-get args :level) + transient--default-child-level))) + (and-let* ((_(transient--use-level-p level)) + (obj (apply class :parent parent :level level args)) + (_(transient--use-suffix-p obj)) + (_(prog1 t + (when (transient--inapt-suffix-p obj) + (oset obj inapt t)))) + (suffixes (mapcan (lambda (c) (transient--init-child levels c obj)) + (transient-setup-children obj children)))) + (progn + (oset obj suffixes suffixes) + (list obj))))) + +(defun transient--init-suffix (levels spec parent) + (let* ((class (car spec)) + (args (cdr spec)) + (cmd (plist-get args :command)) + (_ (transient--load-command-if-autoload cmd)) + (key (plist-get args :key)) + (key (and key (kbd key))) + (proto (and cmd (transient--suffix-prototype cmd))) + (level (or (alist-get (cons cmd key) levels nil nil #'equal) + (alist-get cmd levels) + (plist-get args :level) + (and proto (oref proto level)) + transient--default-child-level)) + (args (plist-put (copy-sequence args) :level level)) + (obj (if (child-of-class-p class 'transient-information) + (apply class :parent parent args) + (unless (and cmd (symbolp cmd)) + (error "BUG: Non-symbolic suffix command: %s" cmd)) + (if proto + (apply #'clone proto :parent parent args) + (apply class :command cmd :parent parent args)))) + (active (and (transient--use-level-p level) + (transient--use-suffix-p obj))) + (inapt (and active (transient--inapt-suffix-p obj))) + (active (and active (not inapt)))) + (cond (inapt + (oset obj inapt t)) + ((not active) + (oset obj inactive t))) + (cond ((not cmd)) + ((commandp cmd)) + ((or (cl-typep obj 'transient-switch) + (cl-typep obj 'transient-option)) + ;; As a temporary special case, if the package was compiled + ;; with an older version of Transient, then we must define + ;; "anonymous" switch and option commands here. + (defalias cmd #'transient--default-infix-command)) + (active + (error "Suffix command %s is not defined or autoloaded" cmd))) + (cond ((not (cl-typep obj 'transient-information)) + (transient--init-suffix-key obj) + (transient-init-scope obj) + (transient-init-value obj) + (push obj transient--suffixes))) + (list obj))) + +(cl-defmethod transient--init-suffix-key ((obj transient-suffix)) + (unless (slot-boundp obj 'key) + (error "No key for %s" (oref obj command)))) + +(cl-defmethod transient--init-suffix-key ((obj transient-argument)) + (if (transient-switches--eieio-childp obj) + (cl-call-next-method obj) + (when-let* ((_(not (slot-boundp obj 'shortarg))) + (argument (oref obj argument)) + (_(stringp argument)) + (shortarg (transient--derive-shortarg argument))) + (oset obj shortarg shortarg)) + (unless (slot-boundp obj 'key) + (if (slot-boundp obj 'shortarg) + (oset obj key (oref obj shortarg)) + (error "No key for %s" (oref obj command)))))) + +(defun transient--use-level-p (level &optional edit) + (or transient--all-levels-p + (and transient--editp (not edit)) + (and (>= level 1) + (<= level (oref transient--prefix level))))) + +(defun transient--use-suffix-p (obj) + (let ((transient--shadowed-buffer (current-buffer)) + (transient--pending-suffix obj)) + (transient--do-suffix-p + (oref obj if) + (oref obj if-not) + (oref obj if-nil) + (oref obj if-non-nil) + (oref obj if-mode) + (oref obj if-not-mode) + (oref obj if-derived) + (oref obj if-not-derived) + t))) + +(defun transient--inapt-suffix-p (obj) + (or (and$ (oref obj parent) + (oref $ inapt)) + (let ((transient--shadowed-buffer (current-buffer)) + (transient--pending-suffix obj)) + (transient--do-suffix-p + (oref obj inapt-if) + (oref obj inapt-if-not) + (oref obj inapt-if-nil) + (oref obj inapt-if-non-nil) + (oref obj inapt-if-mode) + (oref obj inapt-if-not-mode) + (oref obj inapt-if-derived) + (oref obj inapt-if-not-derived) + nil)))) + +(defun transient--do-suffix-p + (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived + default) + (cond + (if (funcall if)) + (if-not (not (funcall if-not))) + (if-non-nil (symbol-value if-non-nil)) + (if-nil (not (symbol-value if-nil))) + (if-mode (if (atom if-mode) + (eq major-mode if-mode) + (memq major-mode if-mode))) + (if-not-mode (not (if (atom if-not-mode) + (eq major-mode if-not-mode) + (memq major-mode if-not-mode)))) + (if-derived (if (or (atom if-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-derived) + (apply #'derived-mode-p if-derived))) + (if-not-derived (not (if (or (atom if-not-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-not-derived) + (apply #'derived-mode-p if-not-derived)))) + (default))) + +(defun transient--suffix-predicate (spec) + (let ((props (transient--suffix-props spec))) + (seq-some (lambda (prop) + (and$ (plist-get props prop) + (list prop $))) + '( :if :if-not + :if-nil :if-non-nil + :if-mode :if-not-mode + :if-derived :if-not-derived + :inapt-if :inapt-if-not + :inapt-if-nil :inapt-if-non-nil + :inapt-if-mode :inapt-if-not-mode + :inapt-if-derived :inapt-if-not-derived)))) + +(defun transient--load-command-if-autoload (cmd) + (when-let* ((_(symbolp cmd)) + (fn (symbol-function cmd)) + (_(autoloadp fn))) + (transient--debug " autoload %s" cmd) + (autoload-do-load fn))) + +;;; Flow-Control + +(defun transient--setup-transient () + (transient--debug 'setup-transient) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (add-hook 'pre-command-hook #'transient--pre-command 99) + (add-hook 'post-command-hook #'transient--post-command) + (advice-add 'recursive-edit :around #'transient--recursive-edit) + (transient--quit-kludge 'enable) + (when transient--exitp + ;; This prefix command was invoked as the suffix of another. + ;; Prevent `transient--post-command' from removing the hooks + ;; that we just added. + (setq transient--exitp 'replace))) + +(defun transient--refresh-transient () + (transient--debug 'refresh-transient) + (transient--pop-keymap 'transient--predicate-map) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (transient--init-transient) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (transient--redisplay)) + +(defun transient--pre-command () + (transient--debug 'pre-command) + (transient--with-emergency-exit :pre-command + ;; The use of `overriding-terminal-local-map' does not prevent the + ;; lookup of command remappings in the overridden maps, which can + ;; lead to a suffix being remapped to a non-suffix. We have to undo + ;; the remapping in that case. However, remapping a non-suffix to + ;; another should remain possible. + (when (and (transient--get-pre-command this-original-command nil 'suffix) + (not (transient--get-pre-command this-command nil 'suffix))) + (setq this-command this-original-command)) + (cond + ((memq this-command '(transient-update transient-quit-seq)) + (transient--pop-keymap 'transient--redisplay-map)) + ((and transient--helpp + (not (memq this-command transient--quit-commands))) + (cond + ((transient-help) + (transient--do-suspend) + (setq this-command 'transient-suspend) + (transient--pre-exit)) + ((not (transient--edebug-command-p)) + (setq this-command 'transient-undefined)))) + ((and transient--editp + (transient-suffix-object) + (not (memq this-command + (cons 'transient-help transient--quit-commands)))) + (setq this-command 'transient-set-level) + (transient--wrap-command)) + (t + (setq transient--exitp nil) + (let ((exitp (eq (transient--call-pre-command) transient--exit))) + (transient--wrap-command) + (when exitp + (transient--maybe-set-value 'exit) + (transient--pre-exit))))))) + +(defun transient--pre-exit () + (transient--debug 'pre-exit) + (transient--delete-window) + (transient--timer-cancel) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (unless transient--showp + (let ((message-log-max nil)) + (message ""))) + (setq transient--transient-map nil) + (setq transient--predicate-map nil) + (setq transient--redisplay-map nil) + (setq transient--redisplay-key nil) + (setq transient--helpp nil) + (unless (eq transient--docsp 'permanent) + (setq transient--docsp nil)) + (setq transient--editp nil) + (setq transient--prefix nil) + (setq transient--layout nil) + (setq transient--suffixes nil) + (setq transient--original-window nil) + (setq transient--original-buffer nil) + (setq transient--window nil)) + +(defun transient--export () + (setq transient-current-prefix transient--prefix) + (setq transient-current-command (oref transient--prefix command)) + (setq transient-current-suffixes transient--suffixes) + (unless (transient--maybe-set-value 'export) + (transient--history-push transient--prefix))) + +(defun transient--suspend-override (&optional nohide) + (transient--debug 'suspend-override) + (transient--timer-cancel) + (let ((show (transient--preserve-window-p nohide))) + (cond ((not show) + (transient--delete-window)) + ((and transient--prefix transient--redisplay-key) + (setq transient--redisplay-key nil) + (when transient--showp + (if-let ((win (minibuffer-selected-window))) + (with-selected-window win + (transient--show)) + (transient--show))))) + (when (and (window-live-p transient--window) + (and show + (or (not (eq show 'fixed)) + (window-full-height-p transient--window)))) + (set-window-parameter transient--window 'window-preserved-size + (list (window-buffer transient--window) nil nil)))) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (remove-hook 'pre-command-hook #'transient--pre-command) + (remove-hook 'post-command-hook #'transient--post-command)) + +(defun transient--resume-override (&optional _ignore) + (transient--debug 'resume-override) + (when (window-live-p transient--window) + (transient--fit-window-to-buffer transient--window)) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (add-hook 'pre-command-hook #'transient--pre-command) + (add-hook 'post-command-hook #'transient--post-command)) + +(defun transient--recursive-edit (fn) + (transient--debug 'recursive-edit) + (if (not transient--prefix) + (funcall fn) + (transient--suspend-override (bound-and-true-p edebug-active)) + (funcall fn) ; Already unwind protected. + (cond ((memq this-command '(top-level abort-recursive-edit)) + (setq transient--exitp t) + (transient--post-exit this-command) + (transient--delete-window)) + (transient--prefix + (transient--resume-override))))) + +(defmacro transient--with-suspended-override (&rest body) + (let ((depth (make-symbol "depth")) + (setup (make-symbol "setup")) + (exit (make-symbol "exit"))) + `(if (and transient--transient-map + (memq transient--transient-map + overriding-terminal-local-map)) + (let ((,depth (1+ (minibuffer-depth))) ,setup ,exit) + (setq ,setup + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-setup) + (remove-hook 'minibuffer-setup-hook ,setup) + (transient--suspend-override))) + (setq ,exit + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-exit) + (when (= (minibuffer-depth) ,depth) + (transient--resume-override)))) + (unwind-protect + (progn + (add-hook 'minibuffer-setup-hook ,setup) + (add-hook 'minibuffer-exit-hook ,exit) + ,@body) + (remove-hook 'minibuffer-setup-hook ,setup) + (remove-hook 'minibuffer-exit-hook ,exit))) + ,@body))) + +(defun transient--wrap-command () + (transient--load-command-if-autoload this-command) + (static-if (>= emacs-major-version 30) + (letrec + ((command this-command) + (suffix (transient-suffix-object this-command)) + (prefix transient--prefix) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (if-let* ((obj suffix) + (grp (oref obj parent)) + (adv (or (oref obj advice*) + (oref grp advice*)))) + (funcall + adv #'advice-eval-interactive-spec spec) + (advice-eval-interactive-spec spec))) + (setq abort nil)) + (when abort + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind command)) + (when (symbolp command) + (remove-function (symbol-function command) advice)) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (if-let* ((obj suffix) + (grp (oref obj parent)) + (adv (or (oref obj advice) + (oref obj advice*) + (oref grp advice) + (oref grp advice*)))) + (apply adv fn args) + (apply fn args))) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind command)) + (when (symbolp command) + (remove-function (symbol-function command) advice)) + (oset prefix unwind-suffix nil))))) + (add-function :around (if (symbolp this-command) + (symbol-function this-command) + this-command) + advice '((depth . -99))) + (cl-assert + (>= emacs-major-version 30) nil + "Emacs was downgraded, making it necessary to recompile Transient")) + ;; (< emacs-major-version 30) + (let* ((command this-command) + (suffix (transient-suffix-object this-command)) + (prefix transient--prefix) + (advice nil) + (advice-interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (if-let* ((obj suffix) + (grp (oref obj parent)) + (adv (or (oref obj advice*) + (oref grp advice*)))) + (funcall + adv #'advice-eval-interactive-spec spec) + (advice-eval-interactive-spec spec))) + (setq abort nil)) + (when abort + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind command)) + (when (symbolp command) + (remove-function (symbol-function command) advice)) + (oset prefix unwind-suffix nil)))))) + (advice-body + (lambda (fn &rest args) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (if-let* ((obj suffix) + (grp (oref obj parent)) + (adv (or (oref obj advice) + (oref obj advice*) + (oref grp advice) + (oref grp advice*)))) + (apply adv fn args) + (apply fn args))) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind command)) + (when (symbolp command) + (remove-function (symbol-function command) advice)) + (oset prefix unwind-suffix nil))))) + (setq advice `(lambda (fn &rest args) + (interactive ,advice-interactive) + (apply ',advice-body fn args))) + (add-function :around (if (symbolp this-command) + (symbol-function this-command) + this-command) + advice '((depth . -99)))))) + +(defun transient--premature-post-command () + (and (equal (this-command-keys-vector) []) + (= (minibuffer-depth) + (1+ transient--minibuffer-depth)) + (progn + (transient--debug 'premature-post-command) + (transient--suspend-override) + (oset (or transient--prefix transient-current-prefix) + unwind-suffix + (if transient--exitp + #'transient--post-exit + #'transient--resume-override)) + t))) + +(defun transient--post-command () + (unless (transient--premature-post-command) + (transient--debug 'post-command) + (transient--with-emergency-exit :post-command + (cond (transient--exitp (transient--post-exit)) + ;; If `this-command' is the current transient prefix, then we + ;; have already taken care of updating the transient buffer... + ((and (eq this-command (oref transient--prefix command)) + ;; ... but if `prefix-arg' is non-nil, then the values + ;; of `this-command' and `real-this-command' are untrue + ;; because `prefix-command-preserve-state' changes them. + ;; We cannot use `current-prefix-arg' because it is set + ;; too late (in `command-execute'), and if it were set + ;; earlier, then we likely still would not be able to + ;; rely on it, and `prefix-command-preserve-state-hook' + ;; would have to be used to record that a universal + ;; argument is in effect. + (not prefix-arg))) + (transient--refreshp + (transient--env-apply #'transient--refresh-transient)) + ((let ((old transient--redisplay-map) + (new (transient--make-redisplay-map))) + (unless (equal old new) + (transient--pop-keymap 'transient--redisplay-map) + (setq transient--redisplay-map new) + (transient--push-keymap 'transient--redisplay-map)) + (transient--env-apply #'transient--redisplay))))) + (setq transient-current-prefix nil) + (setq transient-current-command nil) + (setq transient-current-suffixes nil) + (setq transient--current-suffix nil))) + +(defun transient--post-exit (&optional command) + (transient--debug 'post-exit) + (unless (and (eq transient--exitp 'replace) + (or transient--prefix + ;; The current command could act as a prefix, + ;; but decided not to call `transient-setup', + ;; or it is prevented from doing so because it + ;; uses the minibuffer and the user aborted + ;; that. + (prog1 nil + (if (let ((obj (transient-suffix-object command))) + (and (slot-boundp obj 'transient) + (oref obj transient))) + ;; This sub-prefix is a transient suffix; + ;; go back to outer prefix, by calling + ;; `transient--stack-pop' further down. + (setq transient--exitp nil) + (transient--stack-zap))))) + (remove-hook 'pre-command-hook #'transient--pre-command) + (remove-hook 'post-command-hook #'transient--post-command) + (advice-remove 'recursive-edit #'transient--recursive-edit)) + (let ((replace (eq transient--exitp 'replace)) + (resume (and transient--stack + (not (memq transient--exitp '(replace suspend)))))) + (unless (or resume replace) + (setq transient--showp nil)) + (setq transient--exitp nil) + (setq transient--helpp nil) + (setq transient--editp nil) + (setq transient--all-levels-p nil) + (setq transient--minibuffer-depth 0) + (run-hooks 'transient-exit-hook) + (when command + (setq transient-current-prefix nil) + (setq transient-current-command nil) + (setq transient-current-suffixes nil) + (setq transient--current-suffix nil)) + (cond (resume (transient--stack-pop)) + ((not replace) + (transient--quit-kludge 'disable) + (run-hooks 'transient-post-exit-hook))))) + +(defun transient--stack-push () + (transient--debug 'stack-push) + (push (list (oref transient--prefix command) + transient--layout + transient--editp + :value (transient--get-extended-value) + :return (oref transient--prefix return) + :scope (oref transient--prefix scope)) + transient--stack)) + +(defun transient--stack-pop () + (transient--debug 'stack-pop) + (and transient--stack + (prog1 t (apply #'transient-setup (pop transient--stack))))) + +(defun transient--stack-zap () + (transient--debug 'stack-zap) + (setq transient--stack nil)) + +(defun transient--redisplay () + (if (or (eq transient-show-popup t) + transient--showp) + (unless + (or (memq this-command transient--scroll-commands) + (and (or (memq this-command '(mouse-drag-region + mouse-set-region)) + (equal (key-description (this-command-keys-vector)) + "")) + (and (eq (current-buffer) transient--buffer)))) + (transient--show)) + (when (and (numberp transient-show-popup) + (not (zerop transient-show-popup)) + (not transient--timer)) + (transient--timer-start)) + (transient--show-hint))) + +(defun transient--timer-start () + (setq transient--timer + (run-at-time (abs transient-show-popup) nil + (lambda () + (transient--timer-cancel) + (transient--show) + (let ((message-log-max nil)) + (message "")))))) + +(defun transient--timer-cancel () + (when transient--timer + (cancel-timer transient--timer) + (setq transient--timer nil))) + +(defun transient--debug (arg &rest args) + (when transient--debug + (let ((inhibit-message (not (eq transient--debug 'message)))) + (if (symbolp arg) + (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" + arg + (cond ((and (symbolp this-command) this-command)) + ((fboundp 'help-fns-function-name) + (help-fns-function-name this-command)) + ((byte-code-function-p this-command) + "#[...]") + (this-command)) + (key-description (this-command-keys-vector)) + transient--exitp + (cond ((keywordp (car args)) + (format ", from: %s" + (substring (symbol-name (car args)) 1))) + ((stringp (car args)) + (concat ", " (apply #'format args))) + ((functionp (car args)) + (concat ", " (apply (car args) (cdr args)))) + (""))) + (apply #'message arg args))))) + +(defun transient--emergency-exit (&optional id) + "Exit the current transient command after an error occurred. +When no transient is active (i.e., when `transient--prefix' is +nil) then only reset `inhibit-quit'. Optional ID is a keyword +identifying the exit." + (transient--debug 'emergency-exit id) + (transient--quit-kludge 'disable) + (when transient--prefix + (setq transient--stack nil) + (setq transient--exitp t) + (transient--pre-exit) + (transient--post-exit this-command))) + +(defun transient--quit-kludge (action) + (static-if (boundp 'redisplay-can-quit) ;Emacs 31 + action + (pcase-exhaustive action + ('enable + (add-function + :around command-error-function + (let (unreadp) + (lambda (orig data context fn) + (cond ((not (eq (car data) 'quit)) + (funcall orig data context fn) + (setq unreadp nil)) + (unreadp + (remove-function command-error-function "inhibit-quit") + (funcall orig data context fn)) + (t + (push ?\C-g unread-command-events) + (setq unreadp t))))) + '((name . "inhibit-quit")))) + ('disable + (remove-function command-error-function "inhibit-quit"))))) + +;;; Pre-Commands + +(defun transient--call-pre-command () + (if-let ((fn (transient--get-pre-command this-command + (this-command-keys-vector)))) + (let ((action (funcall fn))) + (when (eq action transient--exit) + (setq transient--exitp (or transient--exitp t))) + action) + (if (let ((keys (this-command-keys-vector))) + (eq (aref keys (1- (length keys))) ?\C-g)) + (setq this-command 'transient-noop) + (unless (transient--edebug-command-p) + (setq this-command 'transient-undefined))) + transient--stay)) + +(defun transient--get-pre-command (&optional cmd key enforce-type) + (or (and (not (eq enforce-type 'non-suffix)) + (symbolp cmd) + (or (and key + (let ((def (lookup-key transient--predicate-map + (vconcat key (list cmd))))) + (and (symbolp def) def))) + (lookup-key transient--predicate-map (vector cmd)))) + (and (not (eq enforce-type 'suffix)) + (transient--resolve-pre-command + (oref transient--prefix transient-non-suffix) + t)))) + +(defun transient--resolve-pre-command (pre &optional resolve-boolean correct) + (setq pre (cond ((booleanp pre) + (if resolve-boolean + (if pre #'transient--do-stay #'transient--do-warn) + pre)) + ((string-match-p "--do-" (symbol-name pre)) pre) + ((let ((sym (intern (format "transient--do-%s" pre)))) + (if (functionp sym) sym pre))))) + (cond ((not correct) pre) + ((and (eq pre 'transient--do-return) + (not transient--stack)) + 'transient--do-exit) + (pre))) + +(defun transient--do-stay () + "Call the command without exporting variables and stay transient." + transient--stay) + +(defun transient--do-noop () + "Call `transient-noop' and stay transient." + (setq this-command 'transient-noop) + transient--stay) + +(defun transient--do-warn () + "Call `transient-undefined' and stay transient." + (setq this-command 'transient-undefined) + transient--stay) + +(defun transient--do-warn-inapt () + "Call `transient-inapt' and stay transient." + (setq this-command 'transient-inapt) + transient--stay) + +(defun transient--do-call () + "Call the command after exporting variables and stay transient." + (transient--export) + transient--stay) + +(defun transient--do-return () + "Call the command after exporting variables and return to parent prefix. +If there is no parent prefix, then behave like `transient--do-exit'." + (if (not transient--stack) + (transient--do-exit) + (transient--export) + transient--exit)) + +(defun transient--do-exit () + "Call the command after exporting variables and exit the transient." + (transient--export) + (transient--stack-zap) + transient--exit) + +(defun transient--do-leave () + "Call the command without exporting variables and exit the transient." + (transient--stack-zap) + transient--exit) + +(defun transient--do-push-button () + "Call the command represented by the activated button. +Use that command's pre-command to determine transient behavior." + (if (and (mouse-event-p last-command-event) + (not (eq (posn-window (event-start last-command-event)) + transient--window))) + transient--stay + (with-selected-window transient--window + (let ((pos (if (mouse-event-p last-command-event) + (posn-point (event-start last-command-event)) + (point)))) + (setq this-command (get-text-property pos 'command)) + (setq transient--current-suffix (get-text-property pos 'suffix)))) + (transient--call-pre-command))) + +(defun transient--do-recurse () + "Call the transient prefix command, preparing for return to outer transient. +If there is no parent prefix, then just call the command." + (transient--do-stack)) + +(defun transient--do-stack () + "Call the transient prefix command, stacking the active transient. +Push the active transient to the transient stack." + (transient--export) + (transient--stack-push) + (setq transient--exitp 'replace) + transient--exit) + +(defun transient--do-replace () + "Call the transient prefix command, replacing the active transient. +Do not push the active transient to the transient stack." + (transient--export) + (setq transient--exitp 'replace) + transient--exit) + +(defun transient--do-suspend () + "Suspend the active transient, saving the transient stack." + ;; Export so that `transient-describe' instances can use + ;; `transient-suffix-object' to get their respective object. + (transient--export) + (transient--stack-push) + (setq transient--exitp 'suspend) + transient--exit) + +(defun transient--do-quit-one () + "If active, quit help or edit mode, else exit the active transient." + (cond (transient--helpp + (setq transient--helpp nil) + transient--stay) + (transient--editp + (setq transient--editp nil) + (transient-setup) + transient--stay) + (prefix-arg + transient--stay) + (transient--exit))) + +(defun transient--do-quit-all () + "Exit all transients without saving the transient stack." + (transient--stack-zap) + transient--exit) + +(defun transient--do-move () + "Call the command if `transient-enable-popup-navigation' is non-nil. +In that case behave like `transient--do-stay', otherwise similar +to `transient--do-warn'." + (unless transient-enable-popup-navigation + (setq this-command 'transient-inhibit-move)) + transient--stay) + +(defun transient--do-minus () + "Call `negative-argument' or pivot to `transient-update'. +If `negative-argument' is invoked using \"-\" then preserve the +prefix argument and pivot to `transient-update'." + (when (equal (this-command-keys) "-") + (setq this-command 'transient-update)) + transient--stay) + +(put 'transient--do-stay 'transient-face 'transient-key-stay) +(put 'transient--do-noop 'transient-face 'transient-key-noop) +(put 'transient--do-warn 'transient-face 'transient-key-noop) +(put 'transient--do-warn-inapt 'transient-face 'transient-key-noop) +(put 'transient--do-call 'transient-face 'transient-key-stay) +(put 'transient--do-return 'transient-face 'transient-key-return) +(put 'transient--do-exit 'transient-face 'transient-key-exit) +(put 'transient--do-leave 'transient-face 'transient-key-exit) + +(put 'transient--do-recurse 'transient-face 'transient-key-recurse) +(put 'transient--do-stack 'transient-face 'transient-key-stack) +(put 'transient--do-replace 'transient-face 'transient-key-exit) +(put 'transient--do-suspend 'transient-face 'transient-key-exit) + +(put 'transient--do-quit-one 'transient-face 'transient-key-return) +(put 'transient--do-quit-all 'transient-face 'transient-key-exit) +(put 'transient--do-move 'transient-face 'transient-key-stay) +(put 'transient--do-minus 'transient-face 'transient-key-stay) + +;;; Commands +;;;; Noop + +(defun transient-noop () + "Do nothing at all." + (interactive)) + +(defun transient-undefined () + "Warn the user that the pressed key is not bound to any suffix." + (interactive) + (transient--invalid "Unbound suffix")) + +(defun transient-inapt () + "Warn the user that the invoked command is inapt." + (interactive) + (transient--invalid "Inapt command")) + +(defun transient--invalid (msg) + (ding) + (message "%s: `%s' (Use `%s' to abort, `%s' for help)%s" + msg + (propertize (key-description (this-single-command-keys)) + 'face 'font-lock-warning-face) + (propertize "C-g" 'face 'transient-key) + (propertize "?" 'face 'transient-key) + ;; `this-command' is `transient-undefined' or `transient-inapt'. + ;; Show the command (`this-original-command') the user actually + ;; tried to invoke. + (if-let ((cmd (or (ignore-errors (symbol-name this-original-command)) + (ignore-errors (symbol-name this-command))))) + (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) + "")) + (unless (and transient--transient-map + (memq transient--transient-map overriding-terminal-local-map)) + (let ((transient--prefix (or transient--prefix 'sic))) + (transient--emergency-exit)) + (view-lossage) + (other-window 1) + (display-warning 'transient "Inconsistent transient state detected. +This should never happen. +Please open an issue and post the shown command log." :error))) + +(defun transient-inhibit-move () + "Warn the user that menu navigation is disabled." + (interactive) + (message "To enable use of `%s', please customize `%s'" + this-original-command + 'transient-enable-popup-navigation)) + +;;;; Core + +(defun transient-quit-all () + "Exit all transients without saving the transient stack." + (interactive)) + +(defun transient-quit-one () + "Exit the current transients, returning to outer transient, if any." + (interactive)) + +(defun transient-quit-seq () + "Abort the current incomplete key sequence." + (interactive)) + +(defun transient-update () + "Redraw the transient's state in the menu buffer." + (interactive) + (setq prefix-arg current-prefix-arg)) + +(defun transient-show () + "Show the transient's state in the menu buffer." + (interactive) + (setq transient--showp t)) + +(defun transient-push-button () + "Invoke the suffix command represented by this button." + (interactive)) + +;;;; Suspend + +(defun transient-suspend () + "Suspend the current transient. +It can later be resumed using `transient-resume', while no other +transient is active." + (interactive)) + +(define-minor-mode transient-resume-mode + "Auxiliary minor-mode used to resume a transient after viewing help.") + +(defun transient-resume () + "Resume a previously suspended stack of transients." + (interactive) + (cond (transient--stack + (let ((winconf transient--restore-winconf)) + (kill-local-variable 'transient--restore-winconf) + (when transient-resume-mode + (transient-resume-mode -1) + (quit-window)) + (when winconf + (set-window-configuration winconf))) + (transient--stack-pop)) + (transient-resume-mode + (kill-local-variable 'transient--restore-winconf) + (transient-resume-mode -1) + (quit-window)) + (t + (message "No suspended transient command")))) + +;;;; Help + +(defun transient-help (&optional interactivep) + "Show help for the active transient or one of its suffixes. +\n(fn)" + (interactive (list t)) + (cond + (interactivep + (setq transient--helpp t)) + ((lookup-key transient--transient-map + (this-single-command-raw-keys)) + (setq transient--helpp nil) + (with-demoted-errors "transient-help: %S" + (transient--display-help #'transient-show-help + (if (eq this-original-command 'transient-help) + transient--prefix + (or (transient-suffix-object) + this-original-command))))))) + +(transient-define-suffix transient-describe () + "From a transient menu, describe something in another buffer. + +This command can be bound multiple times to describe different targets. +Each binding must specify the thing it describes, be setting the value +of its `target' slot, using the keyword argument `:='. + +The `helper' slot specifies the low-level function used to describe the +target, and can be omitted, in which case `transient--describe-function' +is used for a symbol, `transient--show-manual' is used for a string +beginning with a parenthesis, and `transient--show-manpage' is used for +any other string. + +For example: + [(\"e\" \"about emacs\" transient-describe := \"(emacs)\") + (\"g\" \"about git\" transient-describe := \"git\")]" + :class 'transient-describe-target + (interactive) + (with-slots (helper target) (transient-suffix-object) + (transient--display-help helper target))) + +;;;; Level + +(defun transient-set-level (&optional command level) + "Set the level of the transient or one of its suffix commands." + (interactive + (let ((command this-original-command) + (prefix (oref transient--prefix command))) + (and (or (not (eq command 'transient-set-level)) + (and transient--editp + (setq command prefix))) + (list command + (let ((keys (this-single-command-raw-keys))) + (and (lookup-key transient--transient-map keys) + (progn + (transient--show) + (string-to-number + (transient--read-number-N + (format "Set level for `%s': " command) + nil nil (not (eq command prefix))))))))))) + (cond + ((not command) + (setq transient--editp t) + (transient-setup)) + (level + (let* ((prefix (oref transient--prefix command)) + (alist (alist-get prefix transient-levels)) + (akey command)) + (cond ((eq command prefix) + (oset transient--prefix level level) + (setq akey t)) + (t + (oset (transient-suffix-object command) level level) + (when (cdr (cl-remove-if-not (lambda (obj) + (eq (oref obj command) command)) + transient--suffixes)) + (setq akey (cons command (this-command-keys)))))) + (setf (alist-get akey alist) level) + (setf (alist-get prefix transient-levels) alist)) + (transient-save-levels) + (transient--show)) + (t + (transient-undefined)))) + +(transient-define-suffix transient-toggle-level-limit () + "Toggle whether to temporarily display suffixes on all levels." + :description + (lambda () + (cond + (transient--all-levels-p + (format "Hide suffix %s" + (propertize + (format "levels > %s" (oref (transient-prefix-object) level)) + 'face 'transient-higher-level))) + ("Show all suffix levels"))) + :transient t + (interactive) + (setq transient--all-levels-p (not transient--all-levels-p)) + (setq transient--refreshp t)) + +;;;; Value + +(defun transient-set () + "Set active transient's value for this Emacs session." + (interactive) + (transient-set-value (transient-prefix-object))) + +(defalias 'transient-set-and-exit #'transient-set + "Set active transient's value for this Emacs session and exit.") + +(defun transient-save () + "Save active transient's value for this and future Emacs sessions." + (interactive) + (transient-save-value (transient-prefix-object))) + +(defalias 'transient-save-and-exit #'transient-save + "Save active transient's value for this and future Emacs sessions and exit.") + +(defun transient-reset () + "Clear the set and saved values of the active transient." + (interactive) + (transient-reset-value (transient-prefix-object))) + +(defun transient-history-next () + "Switch to the next value used for the active transient." + (interactive) + (let* ((obj transient--prefix) + (pos (1- (oref obj history-pos))) + (hst (oref obj history))) + (if (< pos 0) + (user-error "End of history") + (oset obj history-pos pos) + (oset obj value (nth pos hst)) + (mapc #'transient-init-value transient--suffixes)))) + +(defun transient-history-prev () + "Switch to the previous value used for the active transient." + (interactive) + (let* ((obj transient--prefix) + (pos (1+ (oref obj history-pos))) + (hst (oref obj history)) + (len (length hst))) + (if (> pos (1- len)) + (user-error "End of history") + (oset obj history-pos pos) + (oset obj value (nth pos hst)) + (mapc #'transient-init-value transient--suffixes)))) + +(transient-define-suffix transient-preset () + "Put this preset into action." + :class transient-value-preset + (interactive) + (transient-prefix-set (oref (transient-suffix-object) set))) + +;;;; Auxiliary + +(transient-define-suffix transient-toggle-common () + "Toggle whether common commands are permanently shown." + :transient t + :description (lambda () + (if transient-show-common-commands + "Hide common commands" + "Show common permanently")) + (interactive) + (setq transient-show-common-commands (not transient-show-common-commands))) + +(transient-define-suffix transient-toggle-docstrings (&optional permanent) + "Toggle whether to show docstrings instead of suffix descriptions. + +By default this is only enabled temporarily for the current transient +menu invocation. With a prefix argument, enable this until explicitly +disabled again. + +Infix arguments are not affected by this, because otherwise many menus +would likely become unreadable. To make this command available in all +menus, bind it in `transient-map'. `transient-show-docstring-format' +controls how the docstrings are displayed and whether descriptions are +also displayed." + :transient t + (interactive (list current-prefix-arg)) + (setq transient--docsp (if permanent 'permanent (not transient--docsp)))) + +(defun transient-toggle-debug () + "Toggle debugging statements for transient commands." + (interactive) + (setq transient--debug (not transient--debug)) + (message "Debugging transient %s" + (if transient--debug "enabled" "disabled"))) + +(defun transient-copy-menu-text () + "Copy the contents of the menu buffer to the kill ring. +To make this available in all menus, bind it in `transient-map'" + (interactive) + (transient--show) + (with-current-buffer (get-buffer transient--buffer-name) + (copy-region-as-kill (point-min) (point-max)))) + +(transient-define-suffix transient-echo-arguments (arguments) + "Show the transient's active ARGUMENTS in the echo area. +Intended for use in prefixes used for demonstration purposes, +such as when suggesting a new feature or reporting an issue." + :transient t + :description "Echo arguments" + :key "x" + (interactive (list (transient-args transient-current-command))) + (if (seq-every-p #'stringp arguments) + (message "%s: %s" (key-description (this-command-keys)) + (mapconcat (lambda (arg) + (propertize (if (string-match-p " " arg) + (format "%S" arg) + arg) + 'face 'transient-argument)) + arguments " ")) + (message "%s: %S" (key-description (this-command-keys)) arguments))) + +;;; Value +;;;; Init + +(cl-defgeneric transient-init-value (obj) + "Set the initial value of the prefix or suffix object OBJ. + +This function is called for all prefix and suffix commands. + +Third-party subclasses of `transient-infix' must implement a primary +method.") + +(cl-defmethod transient-init-value :around ((obj transient-prefix)) + "If bound, use the value returned by OBJ' `init-value' function. +If the value of OBJ's `init-value' is non-nil, call that function to +determine the value. Otherwise call the primary method according to +OBJ's class." + (if (slot-boundp obj 'init-value) + (funcall (oref obj init-value) obj) + (cl-call-next-method obj))) + +(cl-defmethod transient-init-value :around ((obj transient-infix)) + "If bound, use the value returned by OBJ's `init-value' function. +If the value of OBJ's `init-value' is non-nil, call that function to +determine the value. Otherwise call the primary method according to +OBJ's class." + (if (slot-boundp obj 'init-value) + (funcall (oref obj init-value) obj) + (cl-call-next-method obj))) + +(cl-defmethod transient-init-value ((obj transient-prefix)) + "Set OBJ's initial value to the set, saved or default value. +Use `transient-default-value' to determine the default value." + (if (slot-boundp obj 'value) + ;; Already set because the live object is cloned from + ;; the prototype, were the set (if any) value is stored. + (oref obj value) + (oset obj value + (if-let ((saved (assq (oref obj command) transient-values))) + (cdr saved) + (transient-default-value obj))))) + +(cl-defmethod transient-init-value ((obj transient-suffix)) + "Non-infix suffixes usually don't have a value. +Call `transient-default-value' but because that is a noop for +`transient-suffix', this function is effectively also a noop." + (let ((value (transient-default-value obj))) + (unless (eq value eieio--unbound) + (oset obj value value)))) + +(cl-defmethod transient-init-value ((obj transient-argument)) + "Extract OBJ's value from the value of the prefix object." + (oset obj value + (let ((value (oref transient--prefix value)) + (argument (and (slot-boundp obj 'argument) + (oref obj argument))) + (multi-value (oref obj multi-value)) + (case-fold-search nil) + (regexp (if (slot-exists-p obj 'argument-regexp) + (oref obj argument-regexp) + (format "\\`%s\\(.*\\)" (oref obj argument))))) + (if (memq multi-value '(t rest)) + (cdr (assoc argument value)) + (let ((match (lambda (v) + (and (stringp v) + (string-match regexp v) + (match-string 1 v))))) + (if multi-value + (delq nil (mapcar match value)) + (cl-some match value))))))) + +(cl-defmethod transient-init-value ((obj transient-switch)) + "Extract OBJ's value from the value of the prefix object." + (oset obj value + (car (member (oref obj argument) + (oref transient--prefix value))))) + +;;;; Default + +(cl-defgeneric transient-default-value (obj) + "Return the default value.") + +(cl-defmethod transient-default-value ((obj transient-prefix)) + "Return the default value as specified by the `default-value' slot. +If the value of the `default-value' slot is a function, call it to +determine the value. If the slot's value isn't a function, return +that. If the slot is unbound, return nil." + (if-let ((default (and (slot-boundp obj 'default-value) + (oref obj default-value)))) + (if (functionp default) + (funcall default) + default) + nil)) + +(cl-defmethod transient-default-value ((_ transient-suffix)) + "Return `eieio--unbound' to indicate that there is no default value. +Doing so causes `transient-init-value' to skip setting the `value' slot." + eieio--unbound) + +;;;; Read + +(cl-defgeneric transient-infix-read (obj) + "Determine the new value of the infix object OBJ. + +This function merely determines the value; `transient-infix-set' +is used to actually store the new value in the object. + +For most infix classes this is done by reading a value from the +user using the reader specified by the `reader' slot (using the +method for `transient-infix', described below). + +For some infix classes the value is changed without reading +anything in the minibuffer, i.e., the mere act of invoking the +infix command determines what the new value should be, based +on the previous value.") + +(cl-defmethod transient-infix-read :around ((obj transient-infix)) + "Refresh the transient buffer and call the next method. + +Also wrap `cl-call-next-method' with two macros: +- `transient--with-suspended-override' allows use of minibuffer. +- `transient--with-emergency-exit' arranges for the transient to + be exited in case of an error." + (transient--show) + (transient--with-emergency-exit :infix-read + (transient--with-suspended-override + (cl-call-next-method obj)))) + +(cl-defmethod transient-infix-read ((obj transient-infix)) + "Read a value while taking care of history. + +This method is suitable for a wide variety of infix commands, +including but not limited to inline arguments and variables. + +If you do not use this method for your own infix class, then +you should likely replicate a lot of the behavior of this +method. If you fail to do so, then users might not appreciate +the lack of history, for example. + +Only for very simple classes that toggle or cycle through a very +limited number of possible values should you replace this with a +simple method that does not handle history. (E.g., for a command +line switch the only possible values are \"use it\" and \"don't use +it\", in which case it is pointless to preserve history.)" + (with-slots (value multi-value always-read allow-empty choices) obj + (if (and value + (not multi-value) + (not always-read) + transient--prefix) + (oset obj value nil) + (let* ((enable-recursive-minibuffers t) + (reader (oref obj reader)) + (choices (if (functionp choices) (funcall choices) choices)) + (prompt (transient-prompt obj)) + (value (if multi-value (string-join value ",") value)) + (history-key (or (oref obj history-key) + (oref obj command))) + (transient--history (alist-get history-key transient-history)) + (transient--history (if (or (null value) + (eq value (car transient--history))) + transient--history + (cons value transient--history))) + (initial-input (and transient-read-with-initial-input + (car transient--history))) + (history (if initial-input + (cons 'transient--history 1) + 'transient--history)) + (value + (cond + (reader (funcall reader prompt initial-input history)) + (multi-value + (completing-read-multiple prompt choices nil nil + initial-input history)) + (choices + (completing-read prompt choices nil t initial-input history)) + ((read-string prompt initial-input history))))) + (cond ((and (equal value "") (not allow-empty)) + (setq value nil)) + ((and (equal value "\"\"") allow-empty) + (setq value ""))) + (when value + (when (and (bound-and-true-p ivy-mode) + (stringp (car transient--history))) + (set-text-properties 0 (length (car transient--history)) nil + (car transient--history))) + (setf (alist-get history-key transient-history) + (delete-dups transient--history))) + value)))) + +(cl-defmethod transient-infix-read ((obj transient-switch)) + "Toggle the switch on or off." + (if (oref obj value) nil (oref obj argument))) + +(cl-defmethod transient-infix-read ((obj transient-switches)) + "Cycle through the mutually exclusive switches. +The last value is \"don't use any of these switches\"." + (let ((choices (mapcar (apply-partially #'format (oref obj argument-format)) + (oref obj choices)))) + (if-let ((value (oref obj value))) + (cadr (member value choices)) + (car choices)))) + +(cl-defmethod transient-infix-read ((command symbol)) + "Elsewhere use the reader of the infix command COMMAND. +Use this if you want to share an infix's history with a regular +stand-alone command." + (if-let ((obj (transient--suffix-prototype command))) + (cl-letf (((symbol-function #'transient--show) #'ignore)) + (transient-infix-read obj)) + (error "Not a suffix command: `%s'" command))) + +;;;; Readers + +(defun transient-read-file (prompt _initial-input _history) + "Read a file." + (file-local-name (expand-file-name (read-file-name prompt)))) + +(defun transient-read-existing-file (prompt _initial-input _history) + "Read an existing file." + (file-local-name (expand-file-name (read-file-name prompt nil nil t)))) + +(defun transient-read-directory (prompt _initial-input _history) + "Read a directory." + (file-local-name (expand-file-name (read-directory-name prompt)))) + +(defun transient-read-existing-directory (prompt _initial-input _history) + "Read an existing directory." + (file-local-name (expand-file-name (read-directory-name prompt nil nil t)))) + +(defun transient-read-number-N0 (prompt initial-input history) + "Read a natural number (including zero) and return it as a string." + (transient--read-number-N prompt initial-input history t)) + +(defun transient-read-number-N+ (prompt initial-input history) + "Read a natural number (excluding zero) and return it as a string." + (transient--read-number-N prompt initial-input history nil)) + +(defun transient--read-number-N (prompt initial-input history include-zero) + (save-match-data + (cl-block nil + (while t + (let ((str (read-from-minibuffer prompt initial-input nil nil history))) + (when (or (string-equal str "") + (string-match-p (if include-zero + "\\`\\(0\\|[1-9][0-9]*\\)\\'" + "\\`[1-9][0-9]*\\'") + str)) + (cl-return str))) + (message "Please enter a natural number (%s zero)." + (if include-zero "including" "excluding")) + (sit-for 1))))) + +(defun transient-read-date (prompt default-time _history) + "Read a date using `org-read-date' (which see)." + (require 'org) + (when (fboundp 'org-read-date) + (org-read-date 'with-time nil nil prompt default-time))) + +;;;; Prompt + +(cl-defgeneric transient-prompt (obj) + "Return the prompt to be used to read infix object OBJ's value.") + +(cl-defmethod transient-prompt ((obj transient-infix)) + "Return the prompt to be used to read infix object OBJ's value. + +This implementation should be suitable for almost all infix +commands. + +If the value of OBJ's `prompt' slot is non-nil, then it must be +a string or a function. If it is a string, then use that. If +it is a function, then call that with OBJ as the only argument. +That function must return a string, which is then used as the +prompt. + +Otherwise, if the value of either the `argument' or `variable' +slot of OBJ is a string, then base the prompt on that (preferring +the former), appending either \"=\" (if it appears to be a +command-line option) or \": \". + +Finally fall through to using \"(BUG: no prompt): \" as the +prompt." + (cond-let + ([prompt (oref obj prompt)] + (let ((prompt (if (functionp prompt) + (funcall prompt obj) + prompt))) + (if (stringp prompt) + prompt + "[BUG: invalid prompt]: "))) + ([name (or (and (slot-boundp obj 'argument) (oref obj argument)) + (and (slot-boundp obj 'variable) (oref obj variable)))] + (if (and (stringp name) + (string-suffix-p "=" name)) + name + (format "%s: " name))) + ("[BUG: no prompt]: "))) + +;;;; Set + +(cl-defgeneric transient-infix-set (obj value) + "Set the value of infix object OBJ to VALUE.") + +(cl-defmethod transient-infix-set ((obj transient-infix) value) + "Set the value of infix object OBJ to VALUE." + (oset obj value value)) + +(cl-defmethod transient-infix-set :after ((obj transient-argument) value) + "Unset incompatible infix arguments." + (when-let* ((_ value) + (val (transient-infix-value obj)) + (arg (if (slot-boundp obj 'argument) + (oref obj argument) + (oref obj argument-format))) + (spec (oref transient--prefix incompatible)) + (filter (lambda (x rule) + (and (member x rule) + (remove x rule)))) + (incomp (nconc + (mapcan (apply-partially filter arg) spec) + (and (not (equal val arg)) + (mapcan (apply-partially filter val) spec))))) + (dolist (obj transient--suffixes) + (when-let* ((_(cl-typep obj 'transient-argument)) + (val (transient-infix-value obj)) + (arg (if (slot-boundp obj 'argument) + (oref obj argument) + (oref obj argument-format))) + (_(if (equal val arg) + (member arg incomp) + (or (member val incomp) + (member arg incomp))))) + (transient-infix-set obj nil))))) + +(defun transient-prefix-set (value) + "Set the value of the active transient prefix to VALUE. +Intended for use by transient suffix commands." + (oset transient--prefix value value) + (setq transient--refreshp 'updated-value)) + +(cl-defgeneric transient-set-value (obj) + "Persist the value of the transient prefix OBJ. +Only intended for use by `transient-set'. +See also `transient-prefix-set'.") + +(cl-defmethod transient-set-value ((obj transient-prefix)) + (let ((value (transient--get-savable-value))) + (oset (oref obj prototype) value value) + (transient--history-push obj value))) + +(defun transient--maybe-set-value (event) + "Maybe set the value, subject to EVENT and the `remember-value' slot." + (let* ((event (if (and (eq event 'exit) + (memq this-command transient--quit-commands)) + 'quit + event)) + (spec (oref transient--prefix remember-value)) + (spec (cond ((listp spec) spec) + ((memq spec '(export exit quit)) + (list spec)) + ((boundp spec) + (symbol-value spec))))) + (and (memq event spec) + (prog1 t + (if (memq 'save spec) + (transient-save-value transient--prefix) + (transient-set-value transient--prefix)))))) + +;;;; Save + +(cl-defgeneric transient-save-value (obj) + "Save the value of the transient prefix OBJ.") + +(cl-defmethod transient-save-value ((obj transient-prefix)) + (let ((value (transient--get-savable-value))) + (oset (oref obj prototype) value value) + (setf (alist-get (oref obj command) transient-values) value) + (transient-save-values) + (transient--history-push obj value))) + +;;;; Reset + +(cl-defgeneric transient-reset-value (obj) + "Clear the set and saved values of the transient prefix OBJ.") + +(cl-defmethod transient-reset-value ((obj transient-prefix)) + (let ((value (transient-default-value obj))) + (oset obj value value) + (oset (oref obj prototype) value value) + (setf (alist-get (oref obj command) transient-values nil 'remove) nil) + (transient-save-values) + (transient--history-push obj value)) + (mapc #'transient-init-value transient--suffixes)) + +;;;; Get + +(defun transient-args (prefix) + "Return the value of the transient prefix command PREFIX. + +If the current command was invoked from the transient prefix command +PREFIX, then return the active infix arguments. If the current command +was not invoked from PREFIX, then return the set, saved or default value +for PREFIX. + +PREFIX may also be a list of prefixes. If no prefix is active, the +fallback value of the first of these prefixes is used. + +The generic function `transient-prefix-value' is used to determine the +returned value. + +This function is intended to be used by suffix commands, whether they +are invoked from a menu or not. It is not intended to be used when +setting up a menu and its suffixes, in which case `transient-get-value' +should be used." + (when (listp prefix) + (setq prefix (car (or (memq transient-current-command prefix) prefix)))) + (if-let ((obj (get prefix 'transient--prefix))) + ;; This OBJ is only used for dispatch purposes; see below. + (transient-prefix-value obj) + (error "Not a transient prefix: %s" prefix))) + +(cl-defgeneric transient-prefix-value (obj) + "Return a list of the values of the suffixes of the specified prefix. + +OBJ is a prototype object and is only used to select the appropriate +method of this generic function. Transient itself only provides one +such method, which should be suitable for most prefixes. + +This function is only intended to be used by `transient-args'. It is +not defined as an internal function because third-party packages may +define their own methods. That does not mean that it would be a good +idea to call it for any other purpose.") + +(cl-defmethod transient-prefix-value ((obj transient-prefix)) + "Return a list of the values of the suffixes of the specified prefix. + +OBJ is a prototype object. This method does not return the value of +that object. Instead it extracts the name of the respective command +from the object and uses that to collect the current values from the +suffixes of the prefix from which the current command was invoked. +If the current command was not invoked from the identified prefix, +then this method returns the set, save or default value, as described +for `transient-args'. + +This method uses `transient-suffixes' (which see) to determine the +suffix objects and then extracts the value(s) from those objects." + (mapcan (lambda (obj) + (and (not (oref obj inactive)) + (not (oref obj inapt)) + (transient--get-wrapped-value obj))) + (transient-suffixes (oref obj command)))) + +(defun transient-suffixes (prefix) + "Return the suffix objects of the transient prefix command PREFIX. + +If PREFIX is not the current prefix, initialize the suffixes so that +they can be returned. That does not cause the menu to be displayed." + (if (eq transient-current-command prefix) + transient-current-suffixes + (let ((transient--prefix (transient--init-prefix prefix))) + (transient--flatten-suffixes + (transient--init-suffixes prefix))))) + +(defun transient-get-value () + "Return the value of the extant prefix. + +This function is intended to be used when setting up a menu and its +suffixes. It is not intended to be used when a suffix command is +invoked, whether from a menu or not, in which case `transient-args' +should be used." + (transient--with-emergency-exit :get-value + (mapcan (lambda (obj) + (and (not (oref obj inactive)) + (not (oref obj inapt)) + (transient--get-wrapped-value obj))) + transient--suffixes))) + +(defun transient--get-extended-value () + "Return the extended value of the extant prefix. + +Unlike `transient-get-value' also include the values of inactive and +inapt arguments. This function is mainly intended for internal use. +It is used to preserve the full value when a menu is being refreshed, +including the presently ineffective parts." + (transient--with-emergency-exit :get-value + (mapcan #'transient--get-wrapped-value transient--suffixes))) + +(defun transient--get-savable-value () + "Return the value of the extant prefix, excluding unsavable parts. + +This function is only intended for internal use. It is used to save +the value." + (transient--with-emergency-exit :get-savable-value + (mapcan (lambda (obj) + (and (not (and (slot-exists-p obj 'unsavable) + (oref obj unsavable))) + (transient--get-wrapped-value obj))) + (or transient--suffixes transient-current-suffixes)))) + +(defun transient--get-wrapped-value (obj) + "Return a list of the value(s) of suffix object OBJ. + +Internally a suffix only ever has one value, stored in its `value' +slot, but callers of `transient-args' wish to treat the values of +certain suffixes as multiple values. That translation is handled +here. The object's `multi-value' slot specifies whether and how +to interpret the `value' as multiple values." + (and-let* ((value (transient-infix-value obj))) + (pcase-exhaustive (and (slot-exists-p obj 'multi-value) + (oref obj multi-value)) + ('nil (list value)) + ((or 't 'rest) (list value)) + ('repeat value)))) + +(cl-defgeneric transient-infix-value (obj) + "Return the value of the suffix object OBJ. + +By default this function is involved when determining the prefix's +overall value, returned by `transient-args' (which see), so that +the invoked suffix command can use that. + +Currently most values are strings, but that is not set in stone. +Nil is not a value, it means \"no value\". + +Usually only infixes have a value, but see the method for +`transient-suffix'.") + +(cl-defmethod transient-infix-value ((_ transient-suffix)) + "Return nil, which means \"no value\". + +Infix arguments contribute the transient's value while suffix +commands consume it. This function is called for suffixes anyway +because a command that both contributes to the transient's value +and also consumes it is not completely unconceivable. + +If you define such a command, then you must define a derived +class and implement this function because this default method +does nothing." nil) + +(cl-defmethod transient-infix-value ((obj transient-infix)) + "Return the value of OBJ's `value' slot." + (oref obj value)) + +(cl-defmethod transient-infix-value ((obj transient-option)) + "Return ARGUMENT and VALUE as a unit or nil if the latter is nil." + (and-let* ((value (oref obj value))) + (let ((arg (oref obj argument))) + (pcase-exhaustive (oref obj multi-value) + ('nil (concat arg value)) + ((or 't 'rest) (cons arg value)) + ('repeat (mapcar (lambda (v) (concat arg v)) value)))))) + +(cl-defmethod transient-infix-value ((_ transient-variable)) + "Return nil, which means \"no value\". + +Setting the value of a variable is done by, well, setting the +value of the variable. I.e., this is a side-effect and does +not contribute to the value of the transient." + nil) + +;;;; Utilities + +(defun transient-arg-value (arg args) + "Return the value of ARG as it appears in ARGS. + +For a switch return a boolean. For an option return the value as +a string, using the empty string for the empty value, or nil if +the option does not appear in ARGS. + +Append \"=\ to ARG to indicate that it is an option." + (save-match-data + (cond-let + ((member arg args) t) + ([_(string-suffix-p "=" arg)] + [match (let ((case-fold-search nil) + (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" + (substring arg 0 -1)))) + (cl-find-if (lambda (a) + (and (stringp a) + (string-match re a))) + args))] + (match-string 1 match))))) + +;;; Return + +(defun transient-init-return (obj) + (when-let* ((_ transient--stack) + (command (oref obj command)) + (suffix-obj (transient-suffix-object command)) + (_(memq (if (slot-boundp suffix-obj 'transient) + (oref suffix-obj transient) + (oref transient-current-prefix transient-suffix)) + (list t 'recurse #'transient--do-recurse)))) + (oset obj return t))) + +;;; Scope +;;;; Init + +(cl-defgeneric transient-init-scope (obj) + "Set the scope of the prefix or suffix object OBJ. + +The scope is actually a property of the transient prefix, not of +individual suffixes. However it is possible to invoke a suffix +command directly instead of from a transient. In that case, if +the suffix expects a scope, then it has to determine that itself +and store it in its `scope' slot. + +This function is called for all prefix and suffix commands, but +unless a concrete method is implemented, this falls through to +a default implementation, which is a noop.") + +(cl-defmethod transient-init-scope ((_ transient-prefix)) + "Noop." nil) + +(cl-defmethod transient-init-scope ((_ transient-suffix)) + "Noop." nil) + +;;;; Get + +(defun transient-scope (&optional prefixes classes) + "Return the scope of the active or current transient prefix command. + +If optional PREFIXES and CLASSES are both nil, return the scope of +the prefix currently being setup, making this variation useful, e.g., +in `:if*' predicates. If no prefix is being setup, but the current +command was invoked from some prefix, then return the scope of that. + +If PREFIXES is non-nil, it must be a prefix command or a list of such +commands. If CLASSES is non-nil, it must be a prefix class or a list +of such classes. When this function is called from the body or the +`interactive' form of a suffix command, PREFIXES and/or CLASSES should +be non-nil. If either is non-nil, try the following in order: + +- If the current suffix command was invoked from a prefix, which + appears in PREFIXES, return the scope of that prefix. + +- If the current suffix command was invoked from a prefix, and its + class derives from one of the CLASSES, return the scope of that + prefix. + +- If a prefix is being setup and it appears in PREFIXES, return its + scope. + +- If a prefix is being setup and its class derives from one of the + CLASSES, return its scope. + +- Finally try to return the default scope of the first command in + PREFIXES. This only works if that slot is set in the respective + class definition or using its `transient-init-scope' method. + +If no prefix matches, return nil." + (cond-let + ((or prefixes classes) + (let* ((prefixes (ensure-list prefixes)) + (type (if (symbolp classes) classes (cons 'or classes))) + (match (lambda (obj) + (and obj + (or (memq (oref obj command) prefixes) + (cl-typep obj type)) + obj)))) + (cond-let + ([obj (or (funcall match transient-current-prefix) + (funcall match transient--prefix))] + (oref obj scope)) + ((get (car prefixes) 'transient--prefix) + (oref (transient--init-prefix (car prefixes)) scope))))) + ([obj (transient-prefix-object)] + (oref obj scope)))) + +;;; History + +(cl-defgeneric transient--history-key (obj) + "Return OBJ's history key.") + +(cl-defmethod transient--history-key ((obj transient-prefix)) + "If the value of the `history-key' slot is non-nil, return that. +Otherwise return the value of the `command' slot." + (or (oref obj history-key) + (oref obj command))) + +(cl-defgeneric transient--history-push (obj value) + "Push VALUE to OBJ's entry in `transient-history'.") + +(cl-defmethod transient--history-push + ((obj transient-prefix) + &optional (value (transient--get-savable-value))) + (let ((key (transient--history-key obj))) + (setf (alist-get key transient-history) + (cons value (delete value (alist-get key transient-history)))))) + +(cl-defgeneric transient--history-init (obj) + "Initialize OBJ's `history' slot. +This is the transient-wide history; many individual infixes also +have a history of their own.") + +(cl-defmethod transient--history-init ((obj transient-prefix)) + "Initialize OBJ's `history' slot from the variable `transient-history'." + (oset obj history + (let ((val (transient--get-extended-value))) + (cons val (delete val (alist-get (transient--history-key obj) + transient-history)))))) + +;;; Display + +(defun transient--show-hint () + (let ((message-log-max nil)) + (message "%s" (transient--format-hint)))) + +(defun transient--show () + (transient--timer-cancel) + (setq transient--showp t) + (let ((transient--shadowed-buffer (current-buffer)) + (setup (not (get-buffer transient--buffer-name))) + (focus nil)) + (setq transient--buffer (get-buffer-create transient--buffer-name)) + (with-current-buffer transient--buffer + (when transient-enable-popup-navigation + (setq focus (or (button-get (point) 'command) + (and (not (bobp)) + (button-get (1- (point)) 'command)) + (transient--heading-at-point)))) + (erase-buffer) + (transient--insert-menu setup)) + (unless (window-live-p transient--window) + (setq transient--window + (display-buffer transient--buffer + (transient--display-action))) + (with-selected-window transient--window + (set-window-parameter nil 'prev--no-other-window + (window-parameter nil 'no-other-window)))) + (when (window-live-p transient--window) + (with-selected-window transient--window + (set-window-parameter nil 'no-other-window t) + (goto-char (point-min)) + (when transient-enable-popup-navigation + (transient--goto-button focus)) + (transient--fit-window-to-buffer transient--window))))) + +(defun transient--display-action () + (let ((action + (cond ((oref transient--prefix display-action)) + ((memq 'display-buffer-full-frame + (ensure-list (car transient-display-buffer-action))) + (user-error "%s disallowed in %s" + 'display-buffer-full-frame + 'transient-display-buffer-action)) + (transient-display-buffer-action)))) + (when (and (assq 'pop-up-frame-parameters (cdr action)) + (fboundp 'buffer-line-statistics)) ; Emacs >= 28.1 + (setq action (copy-tree action)) + (pcase-let ((`(,height ,width) + (buffer-line-statistics transient--buffer)) + (params (assq 'pop-up-frame-parameters (cdr action)))) + (setf (alist-get 'height params) height) + (setf (alist-get 'width params) + (max width (or transient-minimal-frame-width 0))))) + action)) + +(defun transient--fit-window-to-buffer (window) + (set-window-parameter window 'window-preserved-size nil) + (let ((fit-window-to-buffer-horizontally t) + (window-resize-pixelwise t) + (window-size-fixed nil)) + (cond ((not (window-parent window)) + (fit-frame-to-buffer (window-frame window) nil nil nil + transient-minimal-frame-width)) + ((eq (car (window-parameter window 'quit-restore)) 'other) + ;; Grow but never shrink window that previously displayed + ;; another buffer and is going to display that again. + (fit-window-to-buffer window nil (window-height window))) + ((fit-window-to-buffer window nil 1)))) + (set-window-parameter window 'window-preserved-size + (list (window-buffer window) + (window-body-width window t) + (window-body-height window t)))) + +;;; Delete + +(defun transient--delete-window () + (when (window-live-p transient--window) + (let ((win transient--window) + (remain-in-minibuffer-window + (and (minibuffer-selected-window) + (selected-window)))) + (cond + ((eq (car (window-parameter win 'quit-restore)) 'other) + ;; Window used to display another buffer. + (set-window-parameter win 'no-other-window + (window-parameter win 'prev--no-other-window)) + (set-window-parameter win 'prev--no-other-window nil)) + ((with-demoted-errors "Error while exiting transient: %S" + (if (window-parent win) + (delete-window win) + (delete-frame (window-frame win) t))))) + (when remain-in-minibuffer-window + (select-window remain-in-minibuffer-window)))) + (when (buffer-live-p transient--buffer) + (kill-buffer transient--buffer)) + (setq transient--buffer nil)) + +(defun transient--preserve-window-p (&optional nohide) + (let ((show (if nohide 'fixed transient-show-during-minibuffer-read))) + (when (and (integerp show) + (window-live-p transient--window) + (< (frame-height (window-frame transient--window)) + (+ (abs show) + (window-height transient--window)))) + (setq show (natnump show))) + show)) + +;;; Format + +(defun transient--format-hint () + (if (and transient-show-popup (<= transient-show-popup 0)) + (format "%s-" (key-description (this-command-keys))) + (format + "%s- [%s] %s" + (key-description (this-command-keys)) + (oref transient--prefix command) + (mapconcat + #'identity + (sort + (mapcan + (lambda (suffix) + (let ((key (kbd (oref suffix key)))) + ;; Don't list any common commands. + (and (not (memq (oref suffix command) + `(,(lookup-key transient-map key) + ,(lookup-key transient-sticky-map key) + ;; From transient-common-commands: + transient-set + transient-save + transient-history-prev + transient-history-next + transient-quit-one + transient-toggle-common + transient-set-level))) + (list (propertize (oref suffix key) 'face 'transient-key))))) + transient--suffixes) + #'string<) + (propertize "|" 'face 'transient-delimiter))))) + +(defun transient--insert-menu (setup) + (when setup + (when transient-force-fixed-pitch + (transient--force-fixed-pitch)) + (when (bound-and-true-p tab-line-format) + (setq tab-line-format nil)) + (setq header-line-format nil) + (setq mode-line-format + (let ((format (transient--mode-line-format))) + (if (or (natnump format) (eq format 'line)) nil format))) + (setq mode-line-buffer-identification + (symbol-name (oref transient--prefix command))) + (if transient-enable-popup-navigation + (setq-local cursor-in-non-selected-windows 'box) + (setq cursor-type nil)) + (setq display-line-numbers nil) + (setq show-trailing-whitespace nil) + (run-hooks 'transient-setup-buffer-hook)) + (transient--insert-groups) + (when (or transient--helpp transient--editp) + (transient--insert-help)) + (when-let ((line (transient--separator-line))) + (insert line))) + +(defun transient--mode-line-format () + (if (slot-boundp transient--prefix 'mode-line-format) + (oref transient--prefix mode-line-format) + transient-mode-line-format)) + +(defun transient--separator-line () + (and-let* ((format (transient--mode-line-format)) + (height (cond ((not window-system) nil) + ((natnump format) format) + ((eq format 'line) 1))) + (face `(:background ,(transient--prefix-color) :extend t))) + (concat (propertize "__" 'face face 'display `(space :height (,height))) + (propertize "\n" 'face face 'line-height t)))) + +(defun transient--prefix-color () + (or (face-foreground (transient--key-face nil nil 'non-suffix) nil t) + "#gray60")) + +(defmacro transient-with-shadowed-buffer (&rest body) + "While in the transient buffer, temporarily make the shadowed buffer current." + (declare (indent 0) (debug t)) + `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) + ,@body)) + +(defun transient--insert-groups () + (let ((groups (mapcan (lambda (group) + (let ((hide (oref group hide))) + (and (not (and (functionp hide) + (transient-with-shadowed-buffer + (funcall hide)))) + (list group)))) + transient--layout))) + (while-let ((group (pop groups))) + (transient--insert-group group) + (when groups + (insert ?\n))))) + +(defun transient--active-suffixes (group) + (seq-remove (lambda (suffix) + (and (cl-typep suffix 'transient-suffix) + (oref suffix inactive))) + (oref group suffixes))) + +(defvar transient--max-group-level 1) + +(cl-defgeneric transient--insert-group (group) + "Format GROUP and its elements and insert the result.") + +(cl-defmethod transient--insert-group :around ((group transient-group) + &optional _) + "Insert GROUP's description, if any." + (when-let ((desc (transient-with-shadowed-buffer + (transient-format-description group)))) + (insert desc ?\n)) + (let ((transient--max-group-level + (max (oref group level) transient--max-group-level)) + (transient--pending-group group)) + (cl-call-next-method group))) + +(cl-defmethod transient--insert-group ((group transient-row)) + (transient--maybe-pad-keys group) + (dolist (suffix (transient--active-suffixes group)) + (insert (transient-with-shadowed-buffer (transient-format suffix))) + (insert " ")) + (insert ?\n)) + +(cl-defmethod transient--insert-group ((group transient-column) + &optional skip-empty) + (transient--maybe-pad-keys group) + (dolist (suffix (transient--active-suffixes group)) + (let ((str (transient-with-shadowed-buffer (transient-format suffix)))) + (unless (and (not skip-empty) (equal str "")) + (insert str) + (unless (string-match-p ".\n\\'" str) + (insert ?\n)))))) + +(cl-defmethod transient--insert-group ((group transient-columns)) + (if (or transient-force-single-column transient--docsp) + (dolist (group (oref group suffixes)) + (transient--insert-group group t)) + (let* ((columns + (mapcar + (lambda (column) + (transient--maybe-pad-keys column group) + (transient-with-shadowed-buffer + `(,@(and-let* ((desc (transient-format-description column))) + (list desc)) + ,@(let ((transient--pending-group column)) + (mapcar #'transient-format + (transient--active-suffixes column)))))) + (oref group suffixes))) + (stops (transient--column-stops columns))) + (dolist (row (apply #'transient--mapn #'list columns)) + (let ((stops stops)) + (dolist (cell row) + (let ((stop (pop stops))) + (when cell + (transient--align-to stop) + (insert cell))))) + (insert ?\n))))) + +(cl-defmethod transient--insert-group ((group transient-subgroups)) + (let ((subgroups (oref group suffixes))) + (while-let ((subgroup (pop subgroups))) + (transient--maybe-pad-keys subgroup group) + (transient--insert-group subgroup) + (when subgroups + (insert ?\n))))) + +(cl-defgeneric transient-format (obj) + "Format and return OBJ for display. + +When this function is called, then the current buffer is some +temporary buffer. If you need the buffer from which the prefix +command was invoked to be current, then do so by temporarily +making `transient--original-buffer' current.") + +(cl-defmethod transient-format ((arg string)) + "Return the string ARG after applying the `transient-heading' face." + (propertize arg 'face 'transient-heading)) + +(cl-defmethod transient-format ((_ null)) + "Return a string containing just the newline character." + "\n") + +(cl-defmethod transient-format ((arg integer)) + "Return a string containing just the ARG character." + (char-to-string arg)) + +(cl-defmethod transient-format :around ((obj transient-suffix)) + "Add additional formatting if appropriate. +When reading user input for this infix, then highlight it. +When edit-mode is enabled, then prepend the level information. +When `transient-enable-popup-navigation' is non-nil then format +as a button." + (let ((str (cl-call-next-method obj))) + (when (and (cl-typep obj 'transient-infix) + (eq (oref obj command) this-original-command) + (active-minibuffer-window)) + (setq str (transient--add-face str 'transient-active-infix))) + (when transient--editp + (setq str (concat (let ((level (oref obj level))) + (propertize (format " %s " level) + 'face (if (transient--use-level-p level t) + 'transient-enabled-suffix + 'transient-disabled-suffix))) + str))) + (when (and transient-enable-popup-navigation + (slot-boundp obj 'command)) + (setq str (make-text-button str nil + 'type 'transient + 'suffix obj + 'command (oref obj command)))) + str)) + +(cl-defmethod transient-format ((obj transient-infix)) + "Return a string generated using OBJ's `format'. +%k is formatted using `transient-format-key'. +%d is formatted using `transient-format-description'. +%v is formatted using `transient-format-value'." + (format-spec (oref obj format) + `((?k . ,(transient-format-key obj)) + (?d . ,(transient-format-description obj)) + (?v . ,(transient-format-value obj))))) + +(cl-defmethod transient-format ((obj transient-suffix)) + "Return a string generated using OBJ's `format'. +%k is formatted using `transient-format-key'. +%d is formatted using `transient-format-description'." + (format-spec (oref obj format) + `((?k . ,(transient-format-key obj)) + (?d . ,(transient-format-description obj))))) + +(cl-defgeneric transient-format-key (obj) + "Format OBJ's `key' for display and return the result.") + +(cl-defmethod transient-format-key ((obj transient-suffix)) + "Format OBJ's `key' for display and return the result." + (let ((key (if (slot-boundp obj 'key) (oref obj key) "")) + (cmd (and (slot-boundp obj 'command) (oref obj command)))) + (when-let ((width (oref transient--pending-group pad-keys))) + (setq key (truncate-string-to-width key width nil ?\s))) + (if transient--redisplay-key + (let ((len (length transient--redisplay-key)) + (seq (cl-coerce (edmacro-parse-keys key t) 'list))) + (cond + ((member (seq-take seq len) + (list transient--redisplay-key + (thread-last transient--redisplay-key + (cl-substitute ?- 'kp-subtract) + (cl-substitute ?= 'kp-equal) + (cl-substitute ?+ 'kp-add)))) + (let ((pre (key-description (vconcat (seq-take seq len)))) + (suf (key-description (vconcat (seq-drop seq len))))) + (setq pre (string-replace "RET" "C-m" pre)) + (setq pre (string-replace "TAB" "C-i" pre)) + (setq suf (string-replace "RET" "C-m" suf)) + (setq suf (string-replace "TAB" "C-i" suf)) + ;; We use e.g., "-k" instead of the more correct "- k", + ;; because the former is prettier. If we did that in + ;; the definition, then we want to drop the space that + ;; is reinserted above. False-positives are possible + ;; for silly bindings like "-C-c C-c". + (unless (string-search " " key) + (setq pre (string-replace " " "" pre)) + (setq suf (string-replace " " "" suf))) + (concat (propertize pre 'face 'transient-unreachable-key) + (and (string-prefix-p (concat pre " ") key) " ") + (propertize suf 'face (transient--key-face cmd key)) + (save-excursion + (and (string-match " +\\'" key) + (propertize (match-string 0 key) + 'face 'fixed-pitch)))))) + ((transient--lookup-key transient-sticky-map (kbd key)) + (propertize key 'face (transient--key-face cmd key))) + (t + (propertize key 'face 'transient-unreachable-key)))) + (propertize key 'face (transient--key-face cmd key))))) + +(cl-defmethod transient-format-key :around ((obj transient-argument)) + "Handle `transient-highlight-mismatched-keys'." + (let ((key (cl-call-next-method obj))) + (cond + ((not transient-highlight-mismatched-keys) key) + ((not (slot-boundp obj 'shortarg)) + (transient--add-face key 'transient-nonstandard-key)) + ((not (string-equal key (oref obj shortarg))) + (transient--add-face key 'transient-mismatched-key)) + (key)))) + +(cl-defgeneric transient-format-description (obj) + "Format OBJ's `description' for display and return the result.") + +(cl-defmethod transient-format-description ((obj transient-suffix)) + "The `description' slot may be a function, in which case that is +called inside the correct buffer (see `transient--insert-group') +and its value is returned to the caller." + (transient--get-description obj)) + +(cl-defmethod transient-format-description ((obj transient-value-preset)) + (pcase-let* (((eieio description key set) obj) + (value (transient--get-extended-value)) + (active (seq-set-equal-p set value))) + (format + "%s %s" + (propertize (or description (format "Preset %s" key)) + 'face (and active 'transient-argument)) + (format (propertize "(%s)" 'face 'transient-delimiter) + (mapconcat (lambda (arg) + (propertize + arg 'face (cond (active 'transient-argument) + ((member arg value) + '((:weight demibold) + transient-inactive-argument)) + ('transient-inactive-argument)))) + set " "))))) + +(cl-defmethod transient-format-description ((obj transient-group)) + "Format the description by calling the next method. +If the result doesn't use the `face' property at all, then apply the +face `transient-heading' to the complete string." + (and-let* ((desc (transient--get-description obj))) + (cond ((oref obj inapt) + (propertize desc 'face 'transient-inapt-suffix)) + ((text-property-not-all 0 (length desc) 'face nil desc) + desc) + ((propertize desc 'face 'transient-heading))))) + +(cl-defmethod transient-format-description :around ((obj transient-suffix)) + "Format the description by calling the next method. +If the result is nil, then use \"(BUG: no description)\" as the +description. If the OBJ's `key' is currently unreachable, then +apply the face `transient-unreachable' to the complete string." + (let ((desc (or (cl-call-next-method obj) + (and (slot-boundp transient--prefix 'suffix-description) + (funcall (oref transient--prefix suffix-description) + obj))))) + (when-let* ((_ transient--docsp) + (_(slot-boundp obj 'command)) + (cmd (oref obj command)) + (_(not (memq 'transient--default-infix-command + (function-alias-p cmd)))) + (docstr (ignore-errors (documentation cmd))) + (docstr (string-trim + (substring docstr 0 (string-match "\\.?\n" docstr)))) + (_(not (equal docstr "")))) + (setq desc (format-spec transient-show-docstring-format + `((?c . ,desc) + (?s . ,docstr))))) + (if desc + (when-let ((face (transient--get-face obj 'face))) + (setq desc (transient--add-face desc face t))) + (setq desc (propertize "(BUG: no description)" 'face 'error))) + (when (cond (transient--all-levels-p + (> (oref obj level) transient--default-prefix-level)) + (transient-highlight-higher-levels + (> (max (oref obj level) transient--max-group-level) + transient--default-prefix-level))) + (setq desc (transient--add-face desc 'transient-higher-level))) + (when-let ((inapt-face (and (oref obj inapt) + (transient--get-face obj 'inapt-face)))) + (setq desc (transient--add-face desc inapt-face))) + (when (and (slot-boundp obj 'key) + (transient--key-unreachable-p obj)) + (setq desc (transient--add-face desc 'transient-unreachable))) + desc)) + +(cl-defgeneric transient-format-value (obj) + "Format OBJ's value for display and return the result.") + +(cl-defmethod transient-format-value ((obj transient-suffix)) + (propertize (oref obj argument) + 'face (if (oref obj value) + (if (oref obj inapt) + 'transient-inapt-argument + 'transient-argument) + 'transient-inactive-argument))) + +(cl-defmethod transient-format-value ((obj transient-option)) + (let ((argument (prin1-to-string (oref obj argument) t))) + (if-let ((value (oref obj value))) + (let* ((inapt (oref obj inapt)) + (aface (if inapt 'transient-inapt-argument 'transient-argument)) + (vface (if inapt 'transient-inapt-argument 'transient-value))) + (pcase-exhaustive (oref obj multi-value) + ('nil + (concat (propertize argument 'face aface) + (propertize value 'face vface))) + ((or 't 'rest) + (concat (propertize (if (string-suffix-p " " argument) + argument + (concat argument " ")) + 'face aface) + (propertize (mapconcat #'prin1-to-string value " ") + 'face vface))) + ('repeat + (mapconcat (lambda (value) + (concat (propertize argument 'face aface) + (propertize value 'face vface))) + value " ")))) + (propertize argument 'face 'transient-inactive-argument)))) + +(cl-defmethod transient-format-value ((obj transient-switches)) + (with-slots (value argument-format choices) obj + (format (propertize argument-format + 'face (if value + 'transient-argument + 'transient-inactive-argument)) + (format + (propertize "[%s]" 'face 'transient-delimiter) + (mapconcat + (lambda (choice) + (propertize choice 'face + (if (equal (format argument-format choice) value) + (if (oref obj inapt) + 'transient-inapt-argument + 'transient-value) + 'transient-inactive-value))) + choices + (propertize "|" 'face 'transient-delimiter)))))) + +(cl-defmethod transient--get-description ((obj transient-child)) + (cond-let* [[desc (oref obj description)]] + ((functionp desc) + (condition-case nil + (funcall desc obj) + (wrong-number-of-arguments (funcall desc)))) + (desc))) + +(cl-defmethod transient--get-face ((obj transient-suffix) slot) + (cond-let* ((not (slot-boundp obj slot)) nil) + [[face (slot-value obj slot)]] + ((facep face) face) + ((functionp face) + (let ((transient--pending-suffix obj)) + (condition-case nil + (funcall face obj) + (wrong-number-of-arguments (funcall face))))))) + +(defun transient--add-face (string face &optional append beg end) + (let ((str (copy-sequence string))) + (add-face-text-property (or beg 0) (or end (length str)) face append str) + str)) + +(defun transient--key-face (cmd key &optional enforce-type) + (or (and transient-semantic-coloring + (not transient--helpp) + (not transient--editp) + (get (transient--get-pre-command cmd key enforce-type) + 'transient-face)) + (if cmd 'transient-key 'transient-key-noop))) + +(defun transient--key-unreachable-p (obj) + (and transient--redisplay-key + (let ((key (oref obj key))) + (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list) + (length transient--redisplay-key)) + transient--redisplay-key) + (transient--lookup-key transient-sticky-map (kbd key))))))) + +(defun transient--lookup-key (keymap key) + (let ((val (lookup-key keymap key))) + (and val (not (integerp val)) val))) + +(defun transient--maybe-pad-keys (group &optional parent) + (when-let ((pad (or (oref group pad-keys) + (and parent (oref parent pad-keys))))) + (oset group pad-keys + (apply #'max + (if (integerp pad) pad 0) + (seq-keep (lambda (suffix) + (and (eieio-object-p suffix) + (slot-boundp suffix 'key) + (length (oref suffix key)))) + (oref group suffixes)))))) + +(defun transient--pixel-width (string) + (save-window-excursion + (with-temp-buffer + (insert string) + (set-window-dedicated-p nil nil) + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size + nil (line-beginning-position) (point)))))) + +(defun transient--column-stops (columns) + (let* ((var-pitch (or transient-align-variable-pitch + (oref transient--prefix variable-pitch))) + (char-width (and var-pitch (transient--pixel-width " ")))) + (transient--seq-reductions-from + (apply-partially #'+ (* 2 (if var-pitch char-width 1))) + (transient--mapn + (lambda (cells min) + (apply #'max + (if min (if var-pitch (* min char-width) min) 0) + (mapcar (if var-pitch #'transient--pixel-width #'length) cells))) + columns + (oref transient--prefix column-widths)) + 0))) + +(defun transient--align-to (stop) + (unless (zerop stop) + (insert (if (or transient-align-variable-pitch + (oref transient--prefix variable-pitch)) + (propertize " " 'display `(space :align-to (,stop))) + (make-string (max 0 (- stop (current-column))) ?\s))))) + +(defun transient-command-summary-or-name (obj) + "Return the summary or name of the command represented by OBJ. + +If the command has a doc-string, then return the first line of +that, else its name. + +Intended to be temporarily used as the `:suffix-description' of +a prefix command, while porting a regular keymap to a transient." + (let ((command (oref obj command))) + (if-let ((doc (documentation command))) + (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face) + (propertize (symbol-name command) 'face 'font-lock-function-name-face)))) + +;;; Help + +(cl-defgeneric transient-show-help (obj) + "Show documentation for the command represented by OBJ.") + +(cl-defmethod transient-show-help ((obj transient-prefix)) + "Call `show-help' if non-nil, else show `info-manual', +if non-nil, else show the `man-page' if non-nil, else use +`describe-function'." + (with-slots (show-help info-manual man-page command) obj + (cond (show-help (funcall show-help obj)) + (info-manual (transient--show-manual info-manual)) + (man-page (transient--show-manpage man-page)) + ((transient--describe-function command))))) + +(cl-defmethod transient-show-help ((obj transient-suffix)) + "Call `show-help' if non-nil, else use `describe-function'. +Also used to dispatch showing documentation for the current +prefix. If the suffix is a sub-prefix, then also call the +prefix method." + (cond-let + ((eq this-command 'transient-help) + (transient-show-help transient--prefix)) + ([prefix (get (oref obj command) 'transient--prefix)] + [_(not (eq (oref transient--prefix command) this-command))] + (transient-show-help prefix)) + ([show-help (oref obj show-help)] + (funcall show-help obj)) + ((transient--describe-function this-command)))) + +(cl-defmethod transient-show-help ((obj transient-infix)) + "Call `show-help' if non-nil, else show the `man-page' +if non-nil, else use `describe-function'. When showing the +manpage, then try to jump to the correct location." + (cond-let + ([show-help (oref obj show-help)] + (funcall show-help obj)) + ([man-page (oref transient--prefix man-page)] + [argument (and (slot-boundp obj 'argument) + (oref obj argument))] + (transient--show-manpage man-page argument)) + ((transient--describe-function this-command)))) + +;; `cl-generic-generalizers' doesn't support `command' et al. +(cl-defmethod transient-show-help (cmd) + "Show the command doc-string." + (transient--describe-function cmd)) + +(defmacro transient-with-help-window (&rest body) + "Evaluate BODY, send output to *Help* buffer, and display it in a window. +Select the help window, and make the help buffer current and return it." + (declare (indent 0)) + `(let ((buffer nil) + (help-window-select t)) + (with-help-window (help-buffer) + ,@body + (setq buffer (current-buffer))) + (set-buffer buffer))) + +(defun transient--display-help (helper target) + (let ((winconf (current-window-configuration))) + (funcall (cond (helper) + ((symbolp target) #'transient--describe-function) + ((stringp target) + (if (string-prefix-p "(" target) + #'transient--show-manual + #'transient--show-manpage)) + ((error "Unknown how to show help for %S" target))) + target) + (setq-local transient--restore-winconf winconf)) + (fit-window-to-buffer nil (frame-height) (window-height)) + (transient-resume-mode) + (message (substitute-command-keys "Type \\`q' to resume transient command."))) + +(defun transient--describe-function (fn) + (let* ((buffer nil) + (help-window-select t) + (temp-buffer-window-setup-hook + (cons (lambda () (setq buffer (current-buffer))) + temp-buffer-window-setup-hook))) + (describe-function fn) + (set-buffer buffer))) + +(defun transient--show-manual (manual) + (info manual)) + +(defun transient--show-manpage (manpage &optional argument) + (require 'man) + (let* ((Man-notify-method 'meek) + (buf (Man-getpage-in-background manpage)) + (proc (get-buffer-process buf))) + (while (and proc (eq (process-status proc) 'run)) + (accept-process-output proc)) + (switch-to-buffer buf) + (when argument + (transient--goto-argument-description argument)))) + +(defun transient--goto-argument-description (arg) + (goto-char (point-min)) + (let ((case-fold-search nil) + ;; This matches preceding/proceeding options. Options + ;; such as "-a", "-S[]", and "--grep=" + ;; are matched by this regex without the shy group. + ;; The ". " in the shy group is for options such as + ;; "-m parent-number", and the "-[^[:space:]]+ " is + ;; for options such as "--mainline parent-number" + (others "-\\(?:. \\|-[^[:space:]]+ \\)?[^[:space:]]+")) + (when (re-search-forward + (if (equal arg "--") + ;; Special case. + "^[\t\s]+\\(--\\(?: \\|$\\)\\|\\[--\\]\\)" + ;; Should start with whitespace and may have + ;; any number of options before and/or after. + (format + "^[\t\s]+\\(?:%s, \\)*?\\(?1:%s\\)%s\\(?:, %s\\)*$" + others + ;; Options don't necessarily end in an "=" + ;; (e.g., "--gpg-sign[=]") + (string-remove-suffix "=" arg) + ;; Simple options don't end in an "=". Splitting this + ;; into 2 cases should make getting false positives + ;; less likely. + (if (string-suffix-p "=" arg) + ;; "[^[:space:]]*[^.[:space:]]" matches the option + ;; value, which is usually after the option name + ;; and either '=' or '[='. The value can't end in + ;; a period, as that means it's being used at the + ;; end of a sentence. The space is for options + ;; such as '--mainline parent-number'. + "\\(?: \\|\\[?=\\)[^[:space:]]*[^.[:space:]]" + ;; Either this doesn't match anything (e.g., "-a"), + ;; or the option is followed by a value delimited + ;; by a "[", "<", or ":". A space might appear + ;; before this value, as in "-f ". The + ;; space alternative is for options such as + ;; "-m parent-number". + "\\(?:\\(?: \\| ?[\\[<:]\\)[^[:space:]]*[^.[:space:]]\\)?") + others)) + nil t) + (goto-char (match-beginning 1))))) + +(defun transient--insert-help () + (unless (looking-back "\n\n" 2) + (insert "\n")) + (when transient--helpp + (insert + (format + (propertize "\ +Type a %s to show help for that suffix command, or %s to show manual. +Type %s to exit help.\n" + 'face 'transient-heading) + (propertize "" 'face 'transient-key) + (propertize "?" 'face 'transient-key) + (propertize "C-g" 'face 'transient-key)))) + (when transient--editp + (unless transient--helpp + (insert + (format + (propertize "\ +Type %s and then %s to put the respective suffix command on level %s. +Type %s and then %s to display suffixes up to level %s in this menu. +Type %s and then %s to describe the respective suffix command.\n" + 'face 'transient-heading) + (propertize "" 'face 'transient-key) + (propertize "" 'face 'transient-key) + (propertize " N " 'face 'transient-enabled-suffix) + (propertize (concat transient-common-command-prefix " l") + 'face 'transient-key) + (propertize "" 'face 'transient-key) + (propertize " N " 'face 'transient-enabled-suffix) + (propertize "C-h" 'face 'transient-key) + (propertize "" 'face 'transient-key)))) + (with-slots (level) transient--prefix + (insert + (format + (propertize " +The current level of this menu is %s, so + commands on levels %s are displayed, and + commands on levels %s and %s are not displayed.\n" + 'face 'transient-heading) + (propertize (format " %s " level) 'face 'transient-enabled-suffix) + (propertize (format " 1..%s " level) 'face 'transient-enabled-suffix) + (propertize (format " >= %s " (1+ level)) + 'face 'transient-disabled-suffix) + (propertize " 0 " 'face 'transient-disabled-suffix)))))) + +(cl-defgeneric transient-show-summary (obj &optional return) + "Show brief summary about the command at point in the echo area. + +If OBJ's `summary' slot is a string, use that. If it is a function, +call that with OBJ as the only argument and use the returned string. +If `summary' is or returns something other than a string or nil, +show no summary. If `summary' is or returns nil, use the first line +of the documentation string, if any. + +If RETURN is non-nil, return the summary instead of showing it. +This is used when a tooltip is needed.") + +(cl-defmethod transient-show-summary ((obj transient-suffix) &optional return) + (with-slots (command summary) obj + (when-let* + ((doc (cond ((functionp summary) + (funcall summary obj)) + (summary) + ((documentation command) + (car (split-string (documentation command) "\n"))))) + (_(stringp doc)) + (_(not (equal doc + (car (split-string (documentation + 'transient--default-infix-command) + "\n")))))) + (when (string-suffix-p "." doc) + (setq doc (substring doc 0 -1))) + (if return + doc + (let ((message-log-max nil)) + (message "%s" doc)))))) + +;;; Menu Navigation + +(defun transient-scroll-up (&optional arg) + "Scroll text of transient's menu window upward ARG lines. +If ARG is nil scroll near full screen. This is a wrapper +around `scroll-up-command' (which see)." + (interactive "^P") + (with-selected-window transient--window + (scroll-up-command arg))) + +(defun transient-scroll-down (&optional arg) + "Scroll text of transient's menu window down ARG lines. +If ARG is nil scroll near full screen. This is a wrapper +around `scroll-down-command' (which see)." + (interactive "^P") + (with-selected-window transient--window + (scroll-down-command arg))) + +(defun transient-backward-button (n) + "Move to the previous button in transient's menu buffer. +See `backward-button' for information about N." + (interactive "p") + (with-selected-window transient--window + (backward-button n t) + (when (eq transient-enable-popup-navigation 'verbose) + (transient-show-summary (get-text-property (point) 'suffix))))) + +(defun transient-forward-button (n) + "Move to the next button in transient's menu buffer. +See `forward-button' for information about N." + (interactive "p") + (with-selected-window transient--window + (forward-button n t) + (when (eq transient-enable-popup-navigation 'verbose) + (transient-show-summary (get-text-property (point) 'suffix))))) + +(define-button-type 'transient + 'face nil + 'keymap transient-button-map + 'help-echo (lambda (win buf pos) + (with-selected-window win + (with-current-buffer buf + (transient-show-summary + (get-text-property pos 'suffix) t))))) + +(defun transient--goto-button (command) + (cond + ((stringp command) + (when (re-search-forward (concat "^" (regexp-quote command)) nil t) + (goto-char (match-beginning 0)))) + (command + (cl-flet ((found () + (and$ (button-at (point)) + (eq (button-get $ 'command) command)))) + (while (and (ignore-errors (forward-button 1)) + (not (found)))) + (unless (found) + (goto-char (point-min)) + (ignore-errors (forward-button 1)) + (unless (found) + (goto-char (point-min)))))))) + +(defun transient--heading-at-point () + (and (eq (get-text-property (point) 'face) 'transient-heading) + (let ((beg (line-beginning-position))) + (buffer-substring-no-properties + beg (next-single-property-change + beg 'face nil (line-end-position)))))) + +;;; Compatibility +;;;; Menu Isearch + +(defvar-keymap transient--isearch-mode-map + :parent isearch-mode-map + "" #'transient-isearch-exit + " " #'transient-isearch-exit + " " #'transient-isearch-cancel + " " #'transient-isearch-abort) + +(defun transient-isearch-backward (&optional regexp-p) + "Do incremental search backward. +With a prefix argument, do an incremental regular expression +search instead." + (interactive "P") + (transient--isearch-setup) + (let ((isearch-mode-map transient--isearch-mode-map)) + (isearch-mode nil regexp-p))) + +(defun transient-isearch-forward (&optional regexp-p) + "Do incremental search forward. +With a prefix argument, do an incremental regular expression +search instead." + (interactive "P") + (transient--isearch-setup) + (let ((isearch-mode-map transient--isearch-mode-map)) + (isearch-mode t regexp-p))) + +(defun transient-isearch-exit () + "Like `isearch-exit' but adapted for `transient'." + (interactive) + (isearch-exit) + (transient--isearch-exit)) + +(defun transient-isearch-cancel () + "Like `isearch-cancel' but adapted for `transient'." + (interactive) + (condition-case nil (isearch-cancel) (quit)) + (transient--isearch-exit)) + +(defun transient-isearch-abort () + "Like `isearch-abort' but adapted for `transient'." + (interactive) + (let ((around (lambda (fn) + (condition-case nil (funcall fn) (quit)) + (transient--isearch-exit)))) + (advice-add 'isearch-cancel :around around) + (unwind-protect + (isearch-abort) + (advice-remove 'isearch-cancel around)))) + +(defun transient--isearch-setup () + (select-window transient--window) + (transient--suspend-override t)) + +(defun transient--isearch-exit () + (select-window transient--original-window) + (transient--resume-override)) + +;;;; Edebug + +(defun transient--edebug-command-p () + (and (bound-and-true-p edebug-active) + (or (memq this-command '(top-level abort-recursive-edit)) + (string-prefix-p "edebug" (symbol-name this-command))))) + +;;;; Miscellaneous + +(cl-pushnew (list nil (concat "^\\s-*(" + (eval-when-compile + (regexp-opt + '("transient-define-prefix" + "transient-define-suffix" + "transient-define-infix" + "transient-define-argument") + t)) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)") + 2) + lisp-imenu-generic-expression :test #'equal) + +(defun transient--suspend-text-conversion-style () + (static-if (boundp 'overriding-text-conversion-style) ; since Emacs 30.1 + (when text-conversion-style + (letrec ((suspended overriding-text-conversion-style) + (fn (lambda () + (setq overriding-text-conversion-style nil) + (remove-hook 'transient-exit-hook fn)))) + (setq overriding-text-conversion-style suspended) + (add-hook 'transient-exit-hook fn))))) + +(declare-function which-key-mode "ext:which-key" (&optional arg)) + +(defun transient--suspend-which-key-mode () + (when (bound-and-true-p which-key-mode) + (which-key-mode -1) + (add-hook 'transient-exit-hook #'transient--resume-which-key-mode))) + +(defun transient--resume-which-key-mode () + (unless transient--prefix + (which-key-mode 1) + (remove-hook 'transient-exit-hook #'transient--resume-which-key-mode))) + +(defun transient-bind-q-to-quit () + "Modify some keymaps to bind \\`q' to the appropriate quit command. + +\\`C-g' is the default binding for such commands now, but Transient's +predecessor Magit-Popup used \\`q' instead. If you would like to get +that binding back, then call this function in your init file like so: + + (with-eval-after-load \\='transient + (transient-bind-q-to-quit)) + +Individual transients may already bind \\`q' to something else +and such a binding would shadow the quit binding. If that is the +case then \\`Q' is bound to whatever \\`q' would have been bound +to, by setting `transient-substitute-key-function' to a function +that does that. Of course \\`Q' may already be bound to something +else, so that function binds \\`M-q' to that command instead. +Of course \\`M-q' may already be bound to something else, but +we stop there." + (keymap-set transient-base-map "q" #'transient-quit-one) + (keymap-set transient-sticky-map "q" #'transient-quit-seq) + (setq transient-substitute-key-function + #'transient-rebind-quit-commands)) + +(defun transient-rebind-quit-commands (obj) + "See `transient-bind-q-to-quit'." + (let ((key (oref obj key))) + (cond ((string-equal key "q") "Q") + ((string-equal key "Q") "M-q") + (key)))) + +(defun transient--force-fixed-pitch () + (require 'face-remap) + (face-remap-reset-base 'default) + (face-remap-add-relative 'default 'fixed-pitch)) + +(defun transient--seq-reductions-from (function sequence initial-value) + (let ((acc (list initial-value))) + (seq-doseq (elt sequence) + (push (funcall function (car acc) elt) acc)) + (nreverse acc))) + +(defun transient--mapn (function &rest lists) + "Apply FUNCTION to elements of LISTS. +Like `cl-mapcar' but while that stops when the shortest list +is exhausted, continue until the longest list is, using nil +as stand-in for elements of exhausted lists." + (let (result) + (while (catch 'more (mapc (lambda (l) (and l (throw 'more t))) lists) nil) + (push (apply function (mapcar #'car-safe lists)) result) + (setq lists (mapcar #'cdr lists))) + (nreverse result))) + +;;; Font-Lock + +(defconst transient-font-lock-keywords + (eval-when-compile + `((,(concat "(" + (regexp-opt (list "transient-define-prefix" + "transient-define-group" + "transient-define-infix" + "transient-define-argument" + "transient-define-suffix") + t) + "\\_>[ \t'(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face nil t))))) + +(font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords) + +;;; Auxiliary Classes +;;;; `transient-lisp-variable' + +(defclass transient-lisp-variable (transient-variable) + ((reader :initform #'transient-lisp-variable--reader) + (always-read :initform t) + (set-value :initarg :set-value :initform #'set)) + "[Experimental] Class used for Lisp variables.") + +(cl-defmethod transient-init-value ((obj transient-lisp-variable)) + (oset obj value (symbol-value (oref obj variable)))) + +(cl-defmethod transient-infix-set ((obj transient-lisp-variable) value) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value value))) + +(cl-defmethod transient-format-description ((obj transient-lisp-variable)) + (or (cl-call-next-method obj) + (symbol-name (oref obj variable)))) + +(cl-defmethod transient-format-value ((obj transient-lisp-variable)) + (propertize (prin1-to-string (oref obj value)) + 'face 'transient-value)) + +(cl-defmethod transient-prompt ((obj transient-lisp-variable)) + (if (and (slot-boundp obj 'prompt) + (oref obj prompt)) + (cl-call-next-method obj) + (format "Set %s: " (oref obj variable)))) + +(defun transient-lisp-variable--reader (prompt initial-input _history) + (read--expression prompt initial-input)) + +;;;; `transient-cons-option' + +(defclass transient-cons-option (transient-option) + ((format :initform " %k %d: %v")) + "[Experimental] Class used for unencoded key-value pairs.") + +(cl-defmethod transient-infix-value ((obj transient-cons-option)) + "Return ARGUMENT and VALUE as a cons-cell or nil if the latter is nil." + (and$ (oref obj value) + (cons (oref obj argument) $))) + +(cl-defmethod transient-format-description ((obj transient-cons-option)) + (or (oref obj description) + (let ((description (prin1-to-string (oref obj argument) t))) + (if (string-prefix-p ":" description) + (substring description 1) + description)))) + +(cl-defmethod transient-format-value ((obj transient-cons-option)) + (let ((value (oref obj value))) + (propertize (prin1-to-string value t) 'face + (if value 'transient-value 'transient-inactive-value)))) + +;;; _ +(provide 'transient) +;; Local Variables: +;; checkdoc-symbol-words: ("command-line" "edit-mode" "help-mode") +;; indent-tabs-mode: nil +;; lisp-indent-local-overrides: ( +;; (cond . 0) +;; (interactive . 0)) +;; read-symbol-shorthands: ( +;; ("and$" . "cond-let--and$") +;; ("and-let" . "cond-let--and-let") +;; ("if-let" . "cond-let--if-let") +;; ("when$" . "cond-let--when$") +;; ("when-let" . "cond-let--when-let") +;; ("while-let" . "cond-let--while-let")) +;; End: +;;; transient.el ends here diff --git a/.config/emacs/lisp/libs/transient.elc b/.config/emacs/lisp/libs/transient.elc new file mode 100644 index 0000000..6d0fce3 Binary files /dev/null and b/.config/emacs/lisp/libs/transient.elc differ diff --git a/.config/emacs/lisp/libs/with-editor.el b/.config/emacs/lisp/libs/with-editor.el new file mode 100644 index 0000000..34866e0 --- /dev/null +++ b/.config/emacs/lisp/libs/with-editor.el @@ -0,0 +1,998 @@ +;;; with-editor.el --- Use the Emacsclient as $EDITOR -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2026 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Homepage: https://github.com/magit/with-editor +;; Keywords: processes terminals + +;; Package-Version: 3.4.8 +;; Package-Requires: ((emacs "26.1") (compat "30.1")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This library makes it possible to reliably use the Emacsclient as +;; the `$EDITOR' of child processes. It makes sure that they know how +;; to call home. For remote processes a substitute is provided, which +;; communicates with Emacs on standard output/input instead of using a +;; socket as the Emacsclient does. + +;; It provides the commands `with-editor-async-shell-command' and +;; `with-editor-shell-command', which are intended as replacements +;; for `async-shell-command' and `shell-command'. They automatically +;; export `$EDITOR' making sure the executed command uses the current +;; Emacs instance as "the editor". With a prefix argument these +;; commands prompt for an alternative environment variable such as +;; `$GIT_EDITOR'. To always use these variants add this to your init +;; file: +;; +;; (keymap-global-set " " +;; #'with-editor-async-shell-command) +;; (keymap-global-set " " +;; #'with-editor-shell-command) + +;; Alternatively use the global `shell-command-with-editor-mode', +;; which always sets `$EDITOR' for all Emacs commands which ultimately +;; use `shell-command' to asynchronously run some shell command. + +;; The command `with-editor-export-editor' exports `$EDITOR' or +;; another such environment variable in `shell-mode', `eshell-mode', +;; `term-mode' and `vterm-mode' buffers. Use this Emacs command +;; before executing a shell command which needs the editor set, or +;; always arrange for the current Emacs instance to be used as editor +;; by adding it to the appropriate mode hooks: +;; +;; (add-hook 'shell-mode-hook #'with-editor-export-editor) +;; (add-hook 'eshell-mode-hook #'with-editor-export-editor) +;; (add-hook 'term-exec-hook #'with-editor-export-editor) +;; (add-hook 'vterm-mode-hook #'with-editor-export-editor) + +;; Some variants of this function exist, these two forms are +;; equivalent: +;; +;; (add-hook 'shell-mode-hook +;; (apply-partially #'with-editor-export-editor "GIT_EDITOR")) +;; (add-hook 'shell-mode-hook #'with-editor-export-git-editor) + +;; This library can also be used by other packages which need to use +;; the current Emacs instance as editor. In fact this library was +;; written for Magit and its `git-commit-mode' and `git-rebase-mode'. +;; Consult `git-rebase.el' and the related code in `magit-sequence.el' +;; for a simple example. + +;;; Code: + +(require 'cl-lib) +(require 'compat) +(require 'server) +(require 'shell) +(eval-when-compile (require 'subr-x)) + +(declare-function dired-get-filename "dired" + (&optional localp no-error-if-not-filep)) +(declare-function term-emulate-terminal "term" (proc str)) +(defvar eshell-preoutput-filter-functions) +(defvar git-commit-post-finish-hook) +(defvar vterm--process) +(defvar warning-minimum-level) +(defvar warning-minimum-log-level) + +;;; Options + +(defgroup with-editor nil + "Use the Emacsclient as $EDITOR." + :group 'external + :group 'server) + +(defun with-editor-locate-emacsclient () + "Search for a suitable Emacsclient executable." + (or (with-editor-locate-emacsclient-1 + (with-editor-emacsclient-path) + (length (split-string emacs-version "\\."))) + (prog1 nil (display-warning 'with-editor "\ +Cannot determine a suitable Emacsclient + +Determining an Emacsclient executable suitable for the +current Emacs instance failed. For more information +please see https://github.com/magit/magit/wiki/Emacsclient.")))) + +(defvar with-editor-emacsclient-program-suffixes + (list "-snapshot" ".emacs-snapshot") + "Suffixes to append to append when looking for a Emacsclient executables.") + +(defun with-editor-locate-emacsclient-1 (path depth) + (let* ((version-lst (cl-subseq (split-string emacs-version "\\.") 0 depth)) + (version-reg (concat "^" (string-join version-lst "\\.")))) + (or (locate-file + (cond ((equal (downcase invocation-name) "remacs") + "remacsclient") + ((bound-and-true-p emacsclient-program-name)) + ("emacsclient")) + path + (mapcan (lambda (v) (cl-mapcar (lambda (e) (concat v e)) exec-suffixes)) + (nconc (and (boundp 'debian-emacs-flavor) + (list (format ".%s" debian-emacs-flavor))) + (cl-mapcon (lambda (v) + (setq v (string-join (reverse v) ".")) + (list v + (concat "-" v) + (concat ".emacs" v))) + (reverse version-lst)) + (cons "" with-editor-emacsclient-program-suffixes))) + (lambda (exec) + (ignore-errors + (string-match-p version-reg + (with-editor-emacsclient-version exec))))) + (and (> depth 1) + (with-editor-locate-emacsclient-1 path (1- depth)))))) + +(defun with-editor-emacsclient-version (exec) + (let ((default-directory (file-name-directory exec))) + (ignore-errors + (cadr (split-string (car (process-lines exec "--version"))))))) + +(defun with-editor-emacsclient-path () + (let ((path exec-path)) + (when invocation-directory + (push (directory-file-name invocation-directory) path) + (let* ((linkname (expand-file-name invocation-name invocation-directory)) + (truename (file-chase-links linkname))) + (unless (equal truename linkname) + (push (directory-file-name (file-name-directory truename)) path))) + (when (eq system-type 'darwin) + (let ((dir (expand-file-name "bin" invocation-directory))) + (when (file-directory-p dir) + (push dir path))) + (cond + ((string-search "Cellar" invocation-directory) + (let ((dir (expand-file-name "../../../bin" invocation-directory))) + (when (file-directory-p dir) + (push dir path)))) + ((string-search "Emacs.app" invocation-directory) + (let ((dir (expand-file-name "../../../../bin" invocation-directory))) + (when (file-directory-p dir) + (push dir path))))))) + (cl-remove-duplicates path :test #'equal))) + +(defcustom with-editor-emacsclient-executable (with-editor-locate-emacsclient) + "The Emacsclient executable used by the `with-editor' macro." + :group 'with-editor + :type '(choice (string :tag "Executable") + (const :tag "Don't use Emacsclient" nil))) + +(defcustom with-editor-sleeping-editor "\ +sh -c '\ +printf \"\\nWITH-EDITOR: $$ OPEN $0\\037$1\\037 IN $(pwd)\\n\"; \ +sleep 604800 & sleep=$!; \ +trap \"kill $sleep; exit 0\" USR1; \ +trap \"kill $sleep; exit 1\" USR2; \ +wait $sleep'" + "The sleeping editor, used when the Emacsclient cannot be used. + +This fallback is used for asynchronous processes started inside +the macro `with-editor', when the process runs on a remote machine +or for local processes when `with-editor-emacsclient-executable' +is nil (i.e., when no suitable Emacsclient was found, or the user +decided not to use it). + +Where the latter uses a socket to communicate with Emacs' server, +this substitute prints edit requests to its standard output on +which a process filter listens for such requests. As such it is +not a complete substitute for a proper Emacsclient, it can only +be used as $EDITOR of child process of the current Emacs instance. + +Some shells do not execute traps immediately when waiting for a +child process, but by default we do use such a blocking child +process. + +If you use such a shell (e.g., `csh' on FreeBSD, but not Debian), +then you have to edit this option. You can either replace \"sh\" +with \"bash\" (and install that), or you can use the older, less +performant implementation: + + \"sh -c '\\ + echo -e \\\"\\nWITH-EDITOR: $$ OPEN $0$1 IN $(pwd)\\n\\\"; \\ + trap \\\"exit 0\\\" USR1; \\ + trap \\\"exit 1\" USR2; \\ + while true; do sleep 1; done'\" + +Note that the two unit separator characters () right after $0 +and $1 are required. Normally $0 is the file name and $1 is +missing or else gets ignored. But if $0 has the form \"+N[:N]\", +then it is treated as a position in the file and $1 is expected +to be the file. + +Also note that using this alternative implementation leads to a +delay of up to a second. The delay can be shortened by replacing +\"sleep 1\" with \"sleep 0.01\", or if your implementation does +not support floats, then by using \"nanosleep\" instead." + :package-version '(with-editor . "2.8.0") + :group 'with-editor + :type 'string) + +(defcustom with-editor-finish-query-functions nil + "List of functions called to query before finishing session. + +The buffer in question is current while the functions are called. +If any of them returns nil, then the session is not finished and +the buffer is not killed. The user should then fix the issue and +try again. The functions are called with one argument. If it is +non-nil then that indicates that the user used a prefix argument +to force finishing the session despite issues. Functions should +usually honor that and return non-nil." + :group 'with-editor + :type 'hook) +(put 'with-editor-finish-query-functions 'permanent-local t) + +(defcustom with-editor-cancel-query-functions nil + "List of functions called to query before canceling session. + +The buffer in question is current while the functions are called. +If any of them returns nil, then the session is not canceled and +the buffer is not killed. The user should then fix the issue and +try again. The functions are called with one argument. If it is +non-nil then that indicates that the user used a prefix argument +to force canceling the session despite issues. Functions should +usually honor that and return non-nil." + :group 'with-editor + :type 'hook) +(put 'with-editor-cancel-query-functions 'permanent-local t) + +(defcustom with-editor-mode-lighter " WE" + "The mode-line lighter of the With-Editor mode." + :group 'with-editor + :type '(choice (const :tag "No lighter" "") string)) + +(defvar with-editor-server-window-alist nil + "Alist of filename patterns vs corresponding `server-window'. + +Each element looks like (REGEXP . FUNCTION). Files matching +REGEXP are selected using FUNCTION instead of the default in +`server-window'. + +Note that when a package adds an entry here then it probably +has a reason to disrespect `server-window' and it likely is +not a good idea to change such entries.") + +(defvar with-editor-file-name-history-exclude nil + "List of regexps for filenames `server-visit' should not remember. +When a filename matches any of the regexps, then `server-visit' +does not add it to the variable `file-name-history', which is +used when reading a filename in the minibuffer.") + +(defcustom with-editor-shell-command-use-emacsclient t + "Whether to use the emacsclient when running shell commands. + +This affects `with-editor-async-shell-command' and, if the input +ends with \"&\" `with-editor-shell-command' . + +If `shell-command-with-editor-mode' is enabled, then it also +affects `shell-command-async' and, if the input ends with \"&\" +`shell-command'. + +This is a temporary kludge that lets you choose between two +possible defects, the ones described in the issues #23 and #40. + +When t, then use the emacsclient. This has the disadvantage that +`with-editor-mode' won't be enabled because we don't know whether +this package was involved at all in the call to the emacsclient, +and when it is not, then we really should. The problem is that +the emacsclient doesn't pass along any environment variables to +the server. This will hopefully be fixed in Emacs eventually. + +When nil, then use the sleeping editor. Because in this case we +know that this package is involved, we can enable the mode. But +this makes it necessary that you invoke $EDITOR in shell scripts +like so: + + eval \"$EDITOR\" file + +And some tools that do not handle $EDITOR properly also break." + :package-version '(with-editor . "2.7.1") + :group 'with-editor + :type 'boolean) + +;;; Mode Commands + +(defvar with-editor-pre-finish-hook nil) +(defvar with-editor-pre-cancel-hook nil) +(defvar with-editor-post-finish-hook nil) +(defvar with-editor-post-finish-hook-1 nil) +(defvar with-editor-post-cancel-hook nil) +(defvar with-editor-post-cancel-hook-1 nil) +(defvar with-editor-cancel-alist nil) +(put 'with-editor-pre-finish-hook 'permanent-local t) +(put 'with-editor-pre-cancel-hook 'permanent-local t) +(put 'with-editor-post-finish-hook 'permanent-local t) +(put 'with-editor-post-cancel-hook 'permanent-local t) + +(defvar-local with-editor-show-usage t) +(defvar-local with-editor-cancel-message nil) +(defvar-local with-editor-previous-winconf nil) +(put 'with-editor-cancel-message 'permanent-local t) +(put 'with-editor-previous-winconf 'permanent-local t) + +(defvar-local with-editor--pid nil "For internal use.") +(put 'with-editor--pid 'permanent-local t) + +(defun with-editor-finish (force) + "Finish the current edit session." + (interactive "P") + (when (run-hook-with-args-until-failure + 'with-editor-finish-query-functions force) + (let ((post-finish-hook with-editor-post-finish-hook) + (post-commit-hook (bound-and-true-p git-commit-post-finish-hook)) + (dir default-directory)) + (run-hooks 'with-editor-pre-finish-hook) + (with-editor-return nil) + (accept-process-output nil 0.1) + (with-temp-buffer + (setq default-directory dir) + (setq-local with-editor-post-finish-hook post-finish-hook) + (when post-commit-hook + (setq-local git-commit-post-finish-hook post-commit-hook)) + (run-hooks 'with-editor-post-finish-hook))))) + +(defun with-editor-cancel (force) + "Cancel the current edit session." + (interactive "P") + (when (run-hook-with-args-until-failure + 'with-editor-cancel-query-functions force) + (let ((message with-editor-cancel-message)) + (when (functionp message) + (setq message (funcall message))) + (let ((post-cancel-hook with-editor-post-cancel-hook) + (with-editor-cancel-alist nil) + (dir default-directory)) + (run-hooks 'with-editor-pre-cancel-hook) + (with-editor-return t) + (accept-process-output nil 0.1) + (with-temp-buffer + (setq default-directory dir) + (setq-local with-editor-post-cancel-hook post-cancel-hook) + (run-hooks 'with-editor-post-cancel-hook))) + (message (or message "Canceled by user"))))) + +(defun with-editor-return (cancel) + (let ((winconf with-editor-previous-winconf) + (clients server-buffer-clients) + (dir default-directory) + (pid with-editor--pid)) + (remove-hook 'kill-buffer-query-functions + #'with-editor-kill-buffer-noop t) + (cond (cancel + (save-buffer) + (if clients + (let ((buf (current-buffer))) + (dolist (client clients) + (message "client %S" client) + (ignore-errors + (server-send-string client "-error Canceled by user")) + (delete-process client)) + (when (buffer-live-p buf) + (kill-buffer buf))) + ;; Fallback for when emacs was used as $EDITOR + ;; instead of emacsclient or the sleeping editor. + ;; See https://github.com/magit/magit/issues/2258. + (ignore-errors (delete-file buffer-file-name)) + (kill-buffer))) + (t + (save-buffer) + (if clients + ;; Don't use `server-edit' because we do not want to + ;; show another buffer belonging to another client. + ;; See https://github.com/magit/magit/issues/2197. + (server-done) + (kill-buffer)))) + (when pid + (let ((default-directory dir)) + (process-file "kill" nil nil nil + "-s" (if cancel "USR2" "USR1") pid))) + (when (and winconf (eq (window-configuration-frame winconf) + (selected-frame))) + (set-window-configuration winconf)))) + +;;; Mode + +(defvar-keymap with-editor-mode-map + "C-c C-c" #'with-editor-finish + " " #'with-editor-finish + " " #'with-editor-finish + " " #'with-editor-finish + "C-c C-k" #'with-editor-cancel + " " #'with-editor-cancel + " " #'with-editor-cancel + " " #'with-editor-cancel + " " #'with-editor-cancel) + +(define-minor-mode with-editor-mode + "Edit a file as the $EDITOR of an external process." + :lighter with-editor-mode-lighter + ;; Protect the user from enabling or disabling the mode interactively. + ;; Manually enabling the mode is dangerous because canceling the buffer + ;; deletes the visited file. The mode must not be disabled manually, + ;; either `with-editor-finish' or `with-editor-cancel' must be used. + :interactive nil ; >= 28.1 + (when (called-interactively-p 'any) ; < 28.1 + (setq with-editor-mode (not with-editor-mode)) + (user-error "With-Editor mode is not intended for interactive use")) + ;; The buffer must also not be killed using regular kill commands. + (add-hook 'kill-buffer-query-functions + #'with-editor-kill-buffer-noop nil t) + ;; `server-execute' displays a message which is not + ;; correct when using this mode. + (when with-editor-show-usage + (with-editor-usage-message))) + +(put 'with-editor-mode 'permanent-local t) + +(defun with-editor-kill-buffer-noop () + ;; We started doing this in response to #64, but it is not safe + ;; to do so, because the client has already been killed, causing + ;; `with-editor-return' (called by `with-editor-cancel') to delete + ;; the file, see #66. The reason we delete the file in the first + ;; place are https://github.com/magit/magit/issues/2258 and + ;; https://github.com/magit/magit/issues/2248. + ;; (if (memq this-command '(save-buffers-kill-terminal + ;; save-buffers-kill-emacs)) + ;; (let ((with-editor-cancel-query-functions nil)) + ;; (with-editor-cancel nil) + ;; t) + ;; ...) + ;; So go back to always doing this instead: + (user-error (substitute-command-keys (format "\ +Don't kill this buffer %S. Instead cancel using \\[with-editor-cancel]" + (current-buffer))))) + +(defvar-local with-editor-usage-message "\ +Type \\[with-editor-finish] to finish, \ +or \\[with-editor-cancel] to cancel") + +(defun with-editor-usage-message () + ;; Run after `server-execute', which is run using + ;; a timer which starts immediately. + (let ((buffer (current-buffer))) + (run-with-timer + 0.05 nil + (lambda () + (with-current-buffer buffer + (message (substitute-command-keys with-editor-usage-message))))))) + +;;; Wrappers + +(defvar with-editor--envvar nil "For internal use.") + +(defmacro with-editor (&rest body) + "Use the Emacsclient as $EDITOR while evaluating BODY. +Modify the `process-environment' for processes started in BODY, +instructing them to use the Emacsclient as $EDITOR. If optional +ENVVAR is a literal string then bind that environment variable +instead. +\n(fn [ENVVAR] BODY...)" + (declare (indent defun) (debug (body))) + `(let ((with-editor--envvar ,(if (stringp (car body)) + (pop body) + '(or with-editor--envvar "EDITOR"))) + (process-environment process-environment)) + (with-editor--setup) + ,@body)) + +(defmacro with-editor* (envvar &rest body) + "Use the Emacsclient as the editor while evaluating BODY. +Modify the `process-environment' for processes started in BODY, +instructing them to use the Emacsclient as editor. ENVVAR is the +environment variable that is exported to do so, it is evaluated +at run-time. +\n(fn ENVVAR BODY...)" + (declare (indent defun) (debug (sexp body))) + `(let ((with-editor--envvar ,envvar) + (process-environment process-environment)) + (with-editor--setup) + ,@body)) + +(defun with-editor--setup () + (if (or (not with-editor-emacsclient-executable) + (file-remote-p default-directory)) + (push (concat with-editor--envvar "=" with-editor-sleeping-editor) + process-environment) + ;; Make sure server-use-tcp's value is valid. + (unless (featurep 'make-network-process '(:family local)) + (setq server-use-tcp t)) + ;; Make sure the server is running. + (unless (process-live-p server-process) + (when (server-running-p server-name) + (setq server-name (format "server%s" (emacs-pid))) + (when (server-running-p server-name) + (server-force-delete server-name))) + (server-start)) + ;; Tell $EDITOR to use the Emacsclient. + (push (concat with-editor--envvar "=" + ;; Quoting is the right thing to do. Applications that + ;; fail because of that, are the ones that need fixing, + ;; e.g., by using 'eval "$EDITOR" file'. See #121. + (shell-quote-argument + ;; If users set the executable manually, they might + ;; begin the path with "~", which would get quoted. + (if (string-prefix-p "~" with-editor-emacsclient-executable) + (concat (expand-file-name "~") + (substring with-editor-emacsclient-executable 1)) + with-editor-emacsclient-executable)) + ;; Tell the process where the server file is. + (and (not server-use-tcp) + (concat " --socket-name=" + (shell-quote-argument + (expand-file-name server-name + server-socket-dir))))) + process-environment) + (when server-use-tcp + (push (concat "EMACS_SERVER_FILE=" + (expand-file-name server-name server-auth-dir)) + process-environment)) + ;; As last resort fallback to the sleeping editor. + (push (concat "ALTERNATE_EDITOR=" with-editor-sleeping-editor) + process-environment))) + +(defun with-editor-server-window () + (or (and buffer-file-name + (cdr (cl-find-if (lambda (cons) + (string-match-p (car cons) buffer-file-name)) + with-editor-server-window-alist))) + server-window)) + +(define-advice server-switch-buffer + (:around (fn &optional next-buffer &rest args) + with-editor-server-window-alist) + "Honor `with-editor-server-window-alist' (which see)." + (let ((server-window (with-current-buffer + (or next-buffer (current-buffer)) + (when with-editor-mode + (setq with-editor-previous-winconf + (current-window-configuration))) + (with-editor-server-window)))) + (apply fn next-buffer args))) + +(define-advice start-file-process + (:around (fn name buffer program &rest program-args) + with-editor-process-filter) + "When called inside a `with-editor' form and the Emacsclient +cannot be used, then give the process the filter function +`with-editor-process-filter'. To avoid overriding the filter +being added here you should use `with-editor-set-process-filter' +instead of `set-process-filter' inside `with-editor' forms. + +When the `default-directory' is located on a remote machine, +then also manipulate PROGRAM and PROGRAM-ARGS in order to set +the appropriate editor environment variable." + (if (not with-editor--envvar) + (apply fn name buffer program program-args) + (when (file-remote-p default-directory) + (unless (equal program "env") + (push program program-args) + (setq program "env")) + (push (concat with-editor--envvar "=" with-editor-sleeping-editor) + program-args)) + (let ((process (apply fn name buffer program program-args))) + (set-process-filter process #'with-editor-process-filter) + (process-put process 'default-dir default-directory) + process))) + +(advice-add #'make-process :around + #'make-process@with-editor-process-filter) +(cl-defun make-process@with-editor-process-filter + (fn &rest keys &key name buffer command coding noquery stop + connection-type filter sentinel stderr file-handler + &allow-other-keys) + "When called inside a `with-editor' form and the Emacsclient +cannot be used, then give the process the filter function +`with-editor-process-filter'. To avoid overriding the filter +being added here you should use `with-editor-set-process-filter' +instead of `set-process-filter' inside `with-editor' forms. + +When the `default-directory' is located on a remote machine and +FILE-HANDLER is non-nil, then also manipulate COMMAND in order +to set the appropriate editor environment variable." + (if (or (not file-handler) (not with-editor--envvar)) + (apply fn keys) + (when (file-remote-p default-directory) + (unless (equal (car command) "env") + (push "env" command)) + (push (concat with-editor--envvar "=" with-editor-sleeping-editor) + (cdr command))) + (let* ((filter (if filter + (lambda (process output) + (funcall filter process output) + (with-editor-process-filter process output t)) + #'with-editor-process-filter)) + (process (funcall fn + :name name + :buffer buffer + :command command + :coding coding + :noquery noquery + :stop stop + :connection-type connection-type + :filter filter + :sentinel sentinel + :stderr stderr + :file-handler file-handler))) + (process-put process 'default-dir default-directory) + process))) + +(defun with-editor-set-process-filter (process filter) + "Like `set-process-filter' but keep `with-editor-process-filter'. +Give PROCESS the new FILTER but keep `with-editor-process-filter' +if that was added earlier by the advised `start-file-process'. + +Do so by wrapping the two filter functions using a lambda, which +becomes the actual filter. It calls FILTER first, which may or +may not insert the text into the PROCESS's buffer. Then it calls +`with-editor-process-filter', passing t as NO-STANDARD-FILTER." + (set-process-filter + process + (if (eq (process-filter process) 'with-editor-process-filter) + `(lambda (proc str) + (,filter proc str) + (with-editor-process-filter proc str t)) + filter))) + +(defvar with-editor-filter-visit-hook nil) + +(defconst with-editor-sleeping-editor-regexp "^\ +WITH-EDITOR: \\([0-9]+\\) \ +OPEN \\([^]+?\\)\ +\\(?:\\([^]*\\)\\)?\ +\\(?: IN \\([^\r]+?\\)\\)?\r?$") + +(defvar with-editor--max-incomplete-length 1000) + +(defun with-editor-sleeping-editor-filter (process string) + (when-let ((incomplete (and process (process-get process 'incomplete)))) + (setq string (concat incomplete string))) + (save-match-data + (cond + ((and process (not (string-suffix-p "\n" string))) + (let ((length (length string))) + (when (> length with-editor--max-incomplete-length) + (setq string + (substring string + (- length with-editor--max-incomplete-length))))) + (process-put process 'incomplete string) + nil) + ((string-match with-editor-sleeping-editor-regexp string) + (when process + (process-put process 'incomplete nil)) + (let ((pid (match-string 1 string)) + (arg0 (match-string 2 string)) + (arg1 (match-string 3 string)) + (dir (match-string 4 string)) + file line column) + (cond ((string-match "\\`\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\'" arg0) + (setq file arg1) + (setq line (string-to-number (match-string 1 arg0))) + (setq column (match-string 2 arg0)) + (setq column (and column (string-to-number column)))) + ((setq file arg0))) + (unless (file-name-absolute-p file) + (setq file (expand-file-name file dir))) + (when default-directory + (setq file (concat (file-remote-p default-directory) file))) + (with-current-buffer (find-file-noselect file) + (with-editor-mode 1) + (setq with-editor--pid pid) + (setq with-editor-previous-winconf + (current-window-configuration)) + (when line + (let ((pos (save-excursion + (save-restriction + (goto-char (point-min)) + (forward-line (1- line)) + (when column + (move-to-column column)) + (point))))) + (when (and (buffer-narrowed-p) + widen-automatically + (not (<= (point-min) pos (point-max)))) + (widen)) + (goto-char pos))) + (run-hooks 'with-editor-filter-visit-hook) + (funcall (or (with-editor-server-window) #'switch-to-buffer) + (current-buffer)) + (kill-local-variable 'server-window))) + nil) + (t string)))) + +(defun with-editor-process-filter + (process string &optional no-default-filter) + "Listen for edit requests by child processes." + (let ((default-directory (process-get process 'default-dir))) + (with-editor-sleeping-editor-filter process string)) + (unless no-default-filter + (internal-default-process-filter process string))) + +(define-advice server-visit-files + (:after (files _proc &optional _nowait) + with-editor-file-name-history-exclude) + "Prevent certain files from being added to `file-name-history'. +Files matching a regexp in `with-editor-file-name-history-exclude' +are prevented from being added to that list." + (pcase-dolist (`(,file . ,_) files) + (when (cl-find-if (lambda (regexp) + (string-match-p regexp file)) + with-editor-file-name-history-exclude) + (setq file-name-history + (delete (abbreviate-file-name file) file-name-history))))) + +;;; Augmentations + +;;;###autoload +(cl-defun with-editor-export-editor (&optional (envvar "EDITOR")) + "Teach subsequent commands to use current Emacs instance as editor. + +Set and export the environment variable ENVVAR, by default +\"EDITOR\". The value is automatically generated to teach +commands to use the current Emacs instance as \"the editor\". + +This works in `shell-mode', `term-mode', `eshell-mode' and +`vterm'." + (interactive (list (with-editor-read-envvar))) + (cond + ((derived-mode-p 'comint-mode 'term-mode) + (when-let ((process (get-buffer-process (current-buffer)))) + (goto-char (process-mark process)) + (process-send-string + process (format " export %s=%s\n" envvar + (shell-quote-argument with-editor-sleeping-editor))) + (while (accept-process-output process 1 nil t)) + (if (derived-mode-p 'term-mode) + (with-editor-set-process-filter process #'with-editor-emulate-terminal) + (add-hook 'comint-output-filter-functions #'with-editor-output-filter + nil t)))) + ((derived-mode-p 'eshell-mode) + (add-to-list 'eshell-preoutput-filter-functions + #'with-editor-output-filter) + (setenv envvar with-editor-sleeping-editor)) + ((and (derived-mode-p 'vterm-mode) + (fboundp 'vterm-send-return) + (fboundp 'vterm-send-string)) + (if with-editor-emacsclient-executable + (let ((with-editor--envvar envvar) + (process-environment process-environment)) + (with-editor--setup) + (while (accept-process-output vterm--process 1 nil t)) + (when-let ((v (getenv envvar))) + (vterm-send-string (format " export %s=%S" envvar v)) + (vterm-send-return)) + (when-let ((v (getenv "EMACS_SERVER_FILE"))) + (vterm-send-string (format " export EMACS_SERVER_FILE=%S" v)) + (vterm-send-return)) + (vterm-send-string " clear") + (vterm-send-return)) + (error "Cannot use sleeping editor in this buffer"))) + (t + (error "Cannot export environment variables in this buffer"))) + (message "Successfully exported %s" envvar)) + +;;;###autoload +(defun with-editor-export-git-editor () + "Like `with-editor-export-editor' but always set `$GIT_EDITOR'." + (interactive) + (with-editor-export-editor "GIT_EDITOR")) + +;;;###autoload +(defun with-editor-export-hg-editor () + "Like `with-editor-export-editor' but always set `$HG_EDITOR'." + (interactive) + (with-editor-export-editor "HG_EDITOR")) + +(defun with-editor-output-filter (string) + "Handle edit requests on behalf of `comint-mode' and `eshell-mode'." + (with-editor-sleeping-editor-filter nil string)) + +(defun with-editor-emulate-terminal (process string) + "Like `term-emulate-terminal' but also handle edit requests." + (let ((with-editor-sleeping-editor-regexp + (substring with-editor-sleeping-editor-regexp 1))) + (with-editor-sleeping-editor-filter process string)) + (term-emulate-terminal process string)) + +(defvar with-editor-envvars '("EDITOR" "GIT_EDITOR" "HG_EDITOR")) + +(cl-defun with-editor-read-envvar + (&optional (prompt "Set environment variable") + (default "EDITOR")) + (let ((reply (completing-read (if default + (format "%s (%s): " prompt default) + (concat prompt ": ")) + with-editor-envvars nil nil nil nil default))) + (if (string= reply "") (user-error "Nothing selected") reply))) + +;;;###autoload +(define-minor-mode shell-command-with-editor-mode + "Teach `shell-command' to use current Emacs instance as editor. + +Teach `shell-command', and all commands that ultimately call that +command, to use the current Emacs instance as editor by executing +\"EDITOR=CLIENT COMMAND&\" instead of just \"COMMAND&\". + +CLIENT is automatically generated; EDITOR=CLIENT instructs +COMMAND to use to the current Emacs instance as \"the editor\", +assuming no other variable overrides the effect of \"$EDITOR\". +CLIENT may be the path to an appropriate emacsclient executable +with arguments, or a script which also works over Tramp. + +Alternatively you can use the `with-editor-async-shell-command', +which also allows the use of another variable instead of +\"EDITOR\"." + :global t) + +;;;###autoload +(defun with-editor-async-shell-command + (command &optional output-buffer error-buffer envvar) + "Like `async-shell-command' but with `$EDITOR' set. + +Execute string \"ENVVAR=CLIENT COMMAND\" in an inferior shell; +display output, if any. With a prefix argument prompt for an +environment variable, otherwise the default \"EDITOR\" variable +is used. With a negative prefix argument additionally insert +the COMMAND's output at point. + +CLIENT is automatically generated; ENVVAR=CLIENT instructs +COMMAND to use to the current Emacs instance as \"the editor\", +assuming it respects ENVVAR as an \"EDITOR\"-like variable. +CLIENT may be the path to an appropriate emacsclient executable +with arguments, or a script which also works over Tramp. + +Also see `async-shell-command' and `shell-command'." + (interactive (with-editor-shell-command-read-args "Async shell command: " t)) + (let ((with-editor--envvar envvar)) + (with-editor + (async-shell-command command output-buffer error-buffer)))) + +;;;###autoload +(defun with-editor-shell-command + (command &optional output-buffer error-buffer envvar) + "Like `shell-command' or `with-editor-async-shell-command'. +If COMMAND ends with \"&\" behave like the latter, +else like the former." + (interactive (with-editor-shell-command-read-args "Shell command: ")) + (if (string-match "&[ \t]*\\'" command) + (with-editor-async-shell-command + command output-buffer error-buffer envvar) + (shell-command command output-buffer error-buffer))) + +(defun with-editor-shell-command-read-args (prompt &optional async) + (let ((command (read-shell-command + prompt nil nil + (let ((filename (or buffer-file-name + (and (eq major-mode 'dired-mode) + (dired-get-filename nil t))))) + (and filename (file-relative-name filename)))))) + (list command + (if (or async (setq async (string-match-p "&[ \t]*\\'" command))) + (< (prefix-numeric-value current-prefix-arg) 0) + current-prefix-arg) + shell-command-default-error-buffer + (and async current-prefix-arg (with-editor-read-envvar))))) + +(define-advice shell-command + (:around (fn command &optional output-buffer error-buffer) + shell-command-with-editor-mode) + "Set editor envvar, if `shell-command-with-editor-mode' is enabled. +Also take care of that for `with-editor-[async-]shell-command'." + ;; `shell-mode' and its hook are intended for buffers in which an + ;; interactive shell is running, but `shell-command' also turns on + ;; that mode, even though it only runs the shell to run a single + ;; command. The `with-editor-export-editor' hook function is only + ;; intended to be used in buffers in which an interactive shell is + ;; running, so it has to be removed here. + (let ((shell-mode-hook (remove 'with-editor-export-editor shell-mode-hook))) + (cond + ;; If `with-editor-async-shell-command' was used, then `with-editor' + ;; was used, and `with-editor--envvar'. `with-editor-shell-command' + ;; only goes down that path if the command ends with "&". We might + ;; still have to use `with-editor' here, for `async-shell-command' + ;; or `shell-command', if the mode is enabled. + ((and (string-suffix-p "&" command) + (or with-editor--envvar + shell-command-with-editor-mode)) + (if with-editor--envvar + (funcall fn command output-buffer error-buffer) + (with-editor (funcall fn command output-buffer error-buffer))) + ;; The comint filter was overridden with our filter. Use both. + (and-let* ((process (get-buffer-process + (or output-buffer + (get-buffer "*Async Shell Command*"))))) + (prog1 process + (set-process-filter process + (lambda (proc str) + (comint-output-filter proc str) + (with-editor-process-filter proc str t)))))) + ((funcall fn command output-buffer error-buffer))))) + +;;; _ + +(defun with-editor-debug () + "Debug configuration issues. +See info node `(with-editor)Debugging' for instructions." + (interactive) + (require 'warnings) + (with-current-buffer (get-buffer-create "*with-editor-debug*") + (pop-to-buffer (current-buffer)) + (erase-buffer) + (ignore-errors (with-editor)) + (insert + (format "with-editor: %s\n" (locate-library "with-editor.el")) + (format "emacs: %s (%s)\n" + (expand-file-name invocation-name invocation-directory) + emacs-version) + "system:\n" + (format " system-type: %s\n" system-type) + (format " system-configuration: %s\n" system-configuration) + (format " system-configuration-options: %s\n" system-configuration-options) + "server:\n" + (format " server-running-p: %s\n" (server-running-p)) + (format " server-process: %S\n" server-process) + (format " server-use-tcp: %s\n" server-use-tcp) + (format " server-name: %s\n" server-name) + (format " server-socket-dir: %s\n" server-socket-dir)) + (if (and server-socket-dir (file-accessible-directory-p server-socket-dir)) + (dolist (file (directory-files server-socket-dir nil "^[^.]")) + (insert (format " %s\n" file))) + (insert (format " %s: not an accessible directory\n" + (if server-use-tcp "WARNING" "ERROR")))) + (insert (format " server-auth-dir: %s\n" server-auth-dir)) + (if (file-accessible-directory-p server-auth-dir) + (dolist (file (directory-files server-auth-dir nil "^[^.]")) + (insert (format " %s\n" file))) + (insert (format " %s: not an accessible directory\n" + (if server-use-tcp "ERROR" "WARNING")))) + (let ((val with-editor-emacsclient-executable) + (def (default-value 'with-editor-emacsclient-executable)) + (fun (let ((warning-minimum-level :error) + (warning-minimum-log-level :error)) + (with-editor-locate-emacsclient)))) + (insert "with-editor-emacsclient-executable:\n" + (format " value: %s (%s)\n" val + (and val (with-editor-emacsclient-version val))) + (format " default: %s (%s)\n" def + (and def (with-editor-emacsclient-version def))) + (format " funcall: %s (%s)\n" fun + (and fun (with-editor-emacsclient-version fun))))) + (insert "path:\n" + (format " $PATH: %s\n" (split-string (getenv "PATH") ":")) + (format " exec-path: %s\n" exec-path)) + (insert (format " with-editor-emacsclient-path:\n")) + (dolist (dir (with-editor-emacsclient-path)) + (insert (format " %s (%s)\n" dir (car (file-attributes dir)))) + (when (file-directory-p dir) + ;; Don't match emacsclientw.exe, it makes popup windows. + (dolist (exec (directory-files dir t "emacsclient\\(?:[^w]\\|\\'\\)")) + (insert (format " %s (%s)\n" exec + (with-editor-emacsclient-version exec)))))))) + +(defconst with-editor-font-lock-keywords + '(("(\\(with-\\(?:git-\\)?editor\\)\\_>" (1 'font-lock-keyword-face)))) +(font-lock-add-keywords 'emacs-lisp-mode with-editor-font-lock-keywords) + +(provide 'with-editor) +;; Local Variables: +;; byte-compile-warnings: (not docstrings-control-chars) +;; indent-tabs-mode: nil +;; lisp-indent-local-overrides: ((cond . 0) (interactive . 0)) +;; End: +;;; with-editor.el ends here diff --git a/.config/emacs/lisp/libs/with-editor.elc b/.config/emacs/lisp/libs/with-editor.elc new file mode 100644 index 0000000..aa39546 Binary files /dev/null and b/.config/emacs/lisp/libs/with-editor.elc differ -- cgit v1.2.3