diff options
Diffstat (limited to '.config/emacs/lisp/libs')
21 files changed, 0 insertions, 15449 deletions
diff --git a/.config/emacs/lisp/libs/compat-31.el b/.config/emacs/lisp/libs/compat-31.el deleted file mode 100644 index 2b61749..0000000 --- a/.config/emacs/lisp/libs/compat-31.el +++ /dev/null @@ -1,416 +0,0 @@ -;;; 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 <https://www.gnu.org/licenses/>. - -;;; 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) ;; <compat-tests:error-api> - "Return non-nil if SYMBOL is a condition type." - (get symbol 'error-conditions)) - -(compat-defun error-has-type-p (error condition) ;; <compat-tests:error-api> - "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 ;; <compat-tests:error-api> - "Return the symbol which represents the type of ERROR. -\n(fn ERROR)") - -(compat-defalias error-slot-value elt ;; <compat-tests:error-api> - "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) ;; <compat-tests:ensure-proper-list> - "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) ;; <compat-tests:set-local> - "Make VARIABLE buffer local and set it to VALUE." - (set (make-local-variable variable) value)) - -(compat-defun take-while (pred list) ;; <compat-tests:take-while> - "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) ;; <compat-tests:drop-while> - "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) ;; <compat-tests:all> - "Non-nil if PRED is true for all elements in LIST." - (not (drop-while pred list))) - -(compat-defun member-if (pred list) ;; <compat-tests:member-if> - "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-tests:member-if> - -(compat-defun hash-table-contains-p (key table) ;; <compat-tests:hash-table-contains-p> - "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) ;; <compat-tests:static-when> - "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) ;; <compat-tests:static-unless> - "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) ;; <compat-tests:oddp> - "Return t if INTEGER is odd." - (not (eq (% integer 2) 0))) - -(compat-defun evenp (integer) ;; <compat-tests:evenp> - "Return t if INTEGER is even." - (eq (% integer 2) 0)) - -(compat-defun plusp (number) ;; <compat-tests:plusp> - "Return t if NUMBER is positive." - (> number 0)) - -(compat-defun minusp (number) ;; <compat-tests:minusp> - "Return t if NUMBER is negative." - (< number 0)) - -(compat-defmacro incf (place &optional delta) ;; <compat-tests:incf> - "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) ;; <compat-tests:decf> - "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) ;; <compat-tests:color-blend> - "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 ;; <compat-tests: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 ;; <compat-tests:seconds-to-string> - `(("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) ;; <compat-tests:seconds-to-string> - "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) ;; <compat-tests:completion-list-candidate-at-point> - "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) ;; <compat-tests:completion-table-with-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) ;; <compat-tests:add-display-text-property> - "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) ;; <compat-tests:remove-display-text-property> - "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 ;; <compat-tests:with-work-buffer> - "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 ;; <compat-tests:with-work-buffer> - "List of work buffers.") - - (compat-defun work-buffer--get () ;; <compat-tests:with-work-buffer> - "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) ;; <compat-tests:with-work-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) ;; <compat-tests:with-work-buffer> - "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) ;; <compat-tests:buttonize-region> - "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 deleted file mode 100644 index b3206f7..0000000 --- a/.config/emacs/lisp/libs/compat-macs.el +++ /dev/null @@ -1,272 +0,0 @@ -;;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 deleted file mode 100644 index deec131..0000000 --- a/.config/emacs/lisp/libs/compat.el +++ /dev/null @@ -1,93 +0,0 @@ -;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Philip Kaludercic <philipk@posteo.net>, Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Philip Kaludercic <philipk@posteo.net>, Daniel Mendler <mail@daniel-mendler.de> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 deleted file mode 100644 index 825705c..0000000 --- a/.config/emacs/lisp/libs/cond-let.el +++ /dev/null @@ -1,567 +0,0 @@ -;;; 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 <emacs.cond-let@jonas.bernoulli.dev> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 Binary files differdeleted file mode 100644 index bb18a18..0000000 --- a/.config/emacs/lisp/libs/cond-let.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/dash.el b/.config/emacs/lisp/libs/dash.el deleted file mode 100644 index 41d1e53..0000000 --- a/.config/emacs/lisp/libs/dash.el +++ /dev/null @@ -1,4176 +0,0 @@ -;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- - -;; Copyright (C) 2012-2026 Free Software Foundation, Inc. - -;; Author: Magnar Sveen <magnars@gmail.com> -;; Maintainer: Basil L. Contovounesios <basil@contovou.net> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 Binary files differdeleted file mode 100644 index eb21655..0000000 --- a/.config/emacs/lisp/libs/dash.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/elisp-refs.el b/.config/emacs/lisp/libs/elisp-refs.el deleted file mode 100644 index 21b3546..0000000 --- a/.config/emacs/lisp/libs/elisp-refs.el +++ /dev/null @@ -1,913 +0,0 @@ -;;; elisp-refs.el --- find callers of elisp functions or macros -*- lexical-binding: t; -*- - -;; Copyright (C) 2016-2020 Wilfred Hughes <me@wilfred.me.uk> - -;; Author: Wilfred Hughes <me@wilfred.me.uk> -;; 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 <http://www.gnu.org/licenses/>. - -;;; 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 "<tab>") #'elisp-refs-next-match) - (define-key map (kbd "<backtab>") #'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 Binary files differdeleted file mode 100644 index 168e116..0000000 --- a/.config/emacs/lisp/libs/elisp-refs.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/f.el b/.config/emacs/lisp/libs/f.el deleted file mode 100644 index 1ab08d7..0000000 --- a/.config/emacs/lisp/libs/f.el +++ /dev/null @@ -1,799 +0,0 @@ -;;; f.el --- Modern API for working with files and directories -*- lexical-binding: t; -*- - -;; Copyright (C) 2013 Johan Andersson - -;; Author: Johan Andersson <johan.rejeep@gmail.com> -;; Maintainer: Lucien Cartier-Tilet <lucien@phundrak.com> -;; 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 Binary files differdeleted file mode 100644 index b2f72b0..0000000 --- a/.config/emacs/lisp/libs/f.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/ht.el b/.config/emacs/lisp/libs/ht.el deleted file mode 100644 index a85f9ff..0000000 --- a/.config/emacs/lisp/libs/ht.el +++ /dev/null @@ -1,354 +0,0 @@ -;;; ht.el --- The missing hash table library for Emacs -*- lexical-binding: t; -*- - -;; Copyright (C) 2013 Wilfred Hughes - -;; Author: Wilfred Hughes <me@wilfred.me.uk> -;; 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 <http://www.gnu.org/licenses/>. - -;;; 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 Binary files differdeleted file mode 100644 index 74a6a61..0000000 --- a/.config/emacs/lisp/libs/ht.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/llama.el b/.config/emacs/lisp/libs/llama.el deleted file mode 100644 index 4bddfe6..0000000 --- a/.config/emacs/lisp/libs/llama.el +++ /dev/null @@ -1,572 +0,0 @@ -;;; llama.el --- Compact syntax for short lambda -*- lexical-binding:t -*- - -;; Copyright (C) 2020-2026 Jonas Bernoulli - -;; Author: Jonas Bernoulli <emacs.llama@jonas.bernoulli.dev> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 Binary files differdeleted file mode 100644 index 5dacade..0000000 --- a/.config/emacs/lisp/libs/llama.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/s.el b/.config/emacs/lisp/libs/s.el deleted file mode 100644 index cae199b..0000000 --- a/.config/emacs/lisp/libs/s.el +++ /dev/null @@ -1,792 +0,0 @@ -;;; s.el --- The long lost Emacs string manipulation library. -*- lexical-binding: t -*- - -;; Copyright (C) 2012-2022 Magnar Sveen - -;; Author: Magnar Sveen <magnars@gmail.com> -;; Maintainer: Jason Milkins <jasonm23@gmail.com> -;; 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 <http://www.gnu.org/licenses/>. - -;;; 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 Binary files differdeleted file mode 100644 index 16489e9..0000000 --- a/.config/emacs/lisp/libs/s.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/transient.el b/.config/emacs/lisp/libs/transient.el deleted file mode 100644 index a313d90..0000000 --- a/.config/emacs/lisp/libs/transient.el +++ /dev/null @@ -1,5497 +0,0 @@ -;;; transient.el --- Transient commands -*- lexical-binding:t -*- - -;; Copyright (C) 2018-2026 Free Software Foundation, Inc. - -;; Author: Jonas Bernoulli <emacs.transient@jonas.bernoulli.dev> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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. - -\\<transient-map>\ -- 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-popup-navigation-map>\ -- \\[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. -\\<transient-button-map>\ -- \\`<mouse-1>' and \\`<mouse-2>' invoke the clicked on suffix. -\\<transient-popup-navigation-map>\ -- \\[transient-isearch-backward]\ - and \\[transient-isearch-forward] start isearch in the menu buffer. - -\\`<mouse-1>' and \\`<mouse-2>' 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--docstr-hint-1>\\[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--docstr-hint-2>\\[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--docstr-hint-2>\\[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 - "<next>" #'transient-scroll-up - "<prior>" #'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'." - "<down-mouse-1>" #'transient-noop - "<up>" #'transient-backward-button - "<down>" #'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'." - "<mouse-1>" #'transient-push-button - "<mouse-2>" #'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." - "<remap> <Man-quit>" #'transient-resume - "<remap> <Info-exit>" #'transient-resume - "<remap> <quit-window>" #'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-suspend>" #'transient--do-suspend - "<transient-help>" #'transient--do-stay - "<transient-set-level>" #'transient--do-stay - "<transient-history-prev>" #'transient--do-stay - "<transient-history-next>" #'transient--do-stay - "<universal-argument>" #'transient--do-stay - "<universal-argument-more>" #'transient--do-stay - "<negative-argument>" #'transient--do-minus - "<digit-argument>" #'transient--do-stay - "<other-frame-prefix>" #'transient--do-stay - "<other-window-prefix>" #'transient--do-stay - "<top-level>" #'transient--do-quit-all - "<transient-quit-all>" #'transient--do-quit-all - "<transient-quit-one>" #'transient--do-quit-one - "<transient-quit-seq>" #'transient--do-stay - "<transient-show>" #'transient--do-stay - "<transient-update>" #'transient--do-stay - "<transient-set>" #'transient--do-call - "<transient-set-and-exit>" #'transient--do-exit - "<transient-save>" #'transient--do-call - "<transient-save-and-exit>" #'transient--do-exit - "<transient-reset>" #'transient--do-call - "<describe-key-briefly>" #'transient--do-stay - "<describe-key>" #'transient--do-stay - "<transient-scroll-up>" #'transient--do-stay - "<transient-scroll-down>" #'transient--do-stay - "<mwheel-scroll>" #'transient--do-stay - "<scroll-bar-toolkit-scroll>" #'transient--do-stay - "<transient-noop>" #'transient--do-noop - "<transient-mouse-push-button>" #'transient--do-move - "<transient-push-button>" #'transient--do-push-button - "<transient-backward-button>" #'transient--do-move - "<transient-forward-button>" #'transient--do-move - "<transient-isearch-backward>" #'transient--do-move - "<transient-isearch-forward>" #'transient--do-move - "<transient-copy-menu-text>" #'transient--do-stay - "<transient-toggle-docstrings>" #'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. - "<nil>" #'transient--do-warn - ;; Bound to the `mouse-movement' event, this command is similar - ;; to `ignore'. - "<ignore-preserving-kill-region>" #'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 "<kp-subtract>" $)) - (when$ (keymap-lookup map "=") (keymap-set map "<kp-equal>" $)) - (when$ (keymap-lookup map "+") (keymap-set map "<kp-add>" $)) - (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)) - "<mouse-movement>")) - (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[<keyid>]", and "--grep=<pattern>" - ;; 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[=<keyid>]") - (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 <file>". 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 "<KEY>" '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 "<KEY>" 'face 'transient-key) - (propertize "<N>" 'face 'transient-key) - (propertize " N " 'face 'transient-enabled-suffix) - (propertize (concat transient-common-command-prefix " l") - 'face 'transient-key) - (propertize "<N>" 'face 'transient-key) - (propertize " N " 'face 'transient-enabled-suffix) - (propertize "C-h" 'face 'transient-key) - (propertize "<KEY>" '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 - "<t>" #'transient-isearch-exit - "<remap> <isearch-exit>" #'transient-isearch-exit - "<remap> <isearch-cancel>" #'transient-isearch-cancel - "<remap> <isearch-abort>" #'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 Binary files differdeleted file mode 100644 index 6d0fce3..0000000 --- a/.config/emacs/lisp/libs/transient.elc +++ /dev/null diff --git a/.config/emacs/lisp/libs/with-editor.el b/.config/emacs/lisp/libs/with-editor.el deleted file mode 100644 index 34866e0..0000000 --- a/.config/emacs/lisp/libs/with-editor.el +++ /dev/null @@ -1,998 +0,0 @@ -;;; with-editor.el --- Use the Emacsclient as $EDITOR -*- lexical-binding:t -*- - -;; Copyright (C) 2014-2026 The Magit Project Contributors - -;; Author: Jonas Bernoulli <emacs.with-editor@jonas.bernoulli.dev> -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 "<remap> <async-shell-command>" -;; #'with-editor-async-shell-command) -;; (keymap-global-set "<remap> <shell-command>" -;; #'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 - "<remap> <server-edit>" #'with-editor-finish - "<remap> <evil-save-and-close>" #'with-editor-finish - "<remap> <evil-save-modified-and-close>" #'with-editor-finish - "C-c C-k" #'with-editor-cancel - "<remap> <kill-buffer>" #'with-editor-cancel - "<remap> <ido-kill-buffer>" #'with-editor-cancel - "<remap> <iswitchb-kill-buffer>" #'with-editor-cancel - "<remap> <evil-quit>" #'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 Binary files differdeleted file mode 100644 index aa39546..0000000 --- a/.config/emacs/lisp/libs/with-editor.elc +++ /dev/null |