Archived
1
0
Fork 0

Compare commits

..

No commits in common. "9aad3f21939fb39e60e587ef694d642553f2d7d3" and "ea7d9387e7831b5744f50c39af732ead21c2dd0a" have entirely different histories.

412 changed files with 127932 additions and 28959 deletions

View file

@ -1,8 +1,6 @@
(define-package "all-the-icons" "20230615.2016" "A library for inserting Developer icons" (define-package "all-the-icons" "20230316.1906" "A library for inserting Developer icons"
'((emacs "24.3")) '((emacs "24.3"))
:commit "f491f39c21336d354e85bdb4cca281e0a0c2f880" :authors :commit "d922aff57ac8308d3ed067f9151cc76d342855f2" :authors
'(("Dominic Charlesworth" . "dgc336@gmail.com"))
:maintainers
'(("Dominic Charlesworth" . "dgc336@gmail.com")) '(("Dominic Charlesworth" . "dgc336@gmail.com"))
:maintainer :maintainer
'("Dominic Charlesworth" . "dgc336@gmail.com") '("Dominic Charlesworth" . "dgc336@gmail.com")

View file

@ -284,8 +284,6 @@
("tsx" all-the-icons-fileicon "tsx" :height 1.0 :v-adjust -0.1 :face all-the-icons-cyan-alt) ("tsx" all-the-icons-fileicon "tsx" :height 1.0 :v-adjust -0.1 :face all-the-icons-cyan-alt)
("njs" all-the-icons-alltheicon "nodejs" :height 1.2 :face all-the-icons-lgreen) ("njs" all-the-icons-alltheicon "nodejs" :height 1.2 :face all-the-icons-lgreen)
("vue" all-the-icons-fileicon "vue" :face all-the-icons-lgreen) ("vue" all-the-icons-fileicon "vue" :face all-the-icons-lgreen)
("wasm" all-the-icons-fileicon "wasm" :height 1.0 :face all-the-icons-purple-alt)
("wat" all-the-icons-fileicon "wasm" :height 1.0 :face all-the-icons-purple-alt)
("sbt" all-the-icons-fileicon "sbt" :face all-the-icons-red) ("sbt" all-the-icons-fileicon "sbt" :face all-the-icons-red)
("scala" all-the-icons-alltheicon "scala" :face all-the-icons-red) ("scala" all-the-icons-alltheicon "scala" :face all-the-icons-red)
@ -412,7 +410,7 @@
("pps" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange) ("pps" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange)
("ppt" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange) ("ppt" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange)
("pptsx" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange) ("pptsx" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange)
("pptx" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange) ("ppttx" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange)
("knt" all-the-icons-fileicon "powerpoint" :face all-the-icons-cyan) ("knt" all-the-icons-fileicon "powerpoint" :face all-the-icons-cyan)
("xlsx" all-the-icons-fileicon "excel" :face all-the-icons-dgreen) ("xlsx" all-the-icons-fileicon "excel" :face all-the-icons-dgreen)
("xlsm" all-the-icons-fileicon "excel" :face all-the-icons-dgreen) ("xlsm" all-the-icons-fileicon "excel" :face all-the-icons-dgreen)
@ -611,7 +609,6 @@ for performance sake.")
(ibuffer-mode all-the-icons-faicon "files-o" :v-adjust 0.0 :face all-the-icons-dsilver) (ibuffer-mode all-the-icons-faicon "files-o" :v-adjust 0.0 :face all-the-icons-dsilver)
(messages-buffer-mode all-the-icons-faicon "file-o" :v-adjust 0.0 :face all-the-icons-dsilver) (messages-buffer-mode all-the-icons-faicon "file-o" :v-adjust 0.0 :face all-the-icons-dsilver)
(help-mode all-the-icons-faicon "info" :v-adjust -0.1 :face all-the-icons-purple) (help-mode all-the-icons-faicon "info" :v-adjust -0.1 :face all-the-icons-purple)
(helpful-mode all-the-icons-faicon "info" :v-adjust -0.1 :face all-the-icons-purple)
(benchmark-init/tree-mode all-the-icons-octicon "dashboard" :v-adjust 0.0) (benchmark-init/tree-mode all-the-icons-octicon "dashboard" :v-adjust 0.0)
(jenkins-mode all-the-icons-fileicon "jenkins" :face all-the-icons-blue) (jenkins-mode all-the-icons-fileicon "jenkins" :face all-the-icons-blue)
(magit-popup-mode all-the-icons-alltheicon "git" :face all-the-icons-red) (magit-popup-mode all-the-icons-alltheicon "git" :face all-the-icons-red)
@ -1257,6 +1254,8 @@ FONT-NAME is the name of the .ttf file providing the font, defaults to FAMILY."
(interactive "P") (interactive "P")
(all-the-icons-insert arg (quote ,name))))) (all-the-icons-insert arg (quote ,name)))))
(define-obsolete-function-alias 'define-icon 'all-the-icons-define-icon "4.0.0")
(all-the-icons-define-icon alltheicon all-the-icons-data/alltheicons-alist "all-the-icons") (all-the-icons-define-icon alltheicon all-the-icons-data/alltheicons-alist "all-the-icons")
(all-the-icons-define-icon fileicon all-the-icons-data/file-icon-alist "file-icons") (all-the-icons-define-icon fileicon all-the-icons-data/file-icon-alist "file-icons")
(all-the-icons-define-icon faicon all-the-icons-data/fa-icon-alist "FontAwesome") (all-the-icons-define-icon faicon all-the-icons-data/fa-icon-alist "FontAwesome")

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,214 @@
;;; async-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "async" "async.el" (0 0 0 0))
;;; Generated autoloads from async.el
(autoload 'async-start-process "async" "\
Start the executable PROGRAM asynchronously named NAME. See `async-start'.
PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
process object when done. If FINISH-FUNC is nil, the future
object will return the process object when the program is
finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
working directory.
\(fn NAME PROGRAM FINISH-FUNC &rest PROGRAM-ARGS)" nil nil)
(autoload 'async-start "async" "\
Execute START-FUNC (often a lambda) in a subordinate Emacs process.
When done, the return value is passed to FINISH-FUNC. Example:
(async-start
;; What to do in the child process
(lambda ()
(message \"This is a test\")
(sleep-for 3)
222)
;; What to do when it finishes
(lambda (result)
(message \"Async process done, result should be 222: %s\"
result)))
If FINISH-FUNC is nil or missing, a future is returned that can
be inspected using `async-get', blocking until the value is
ready. Example:
(let ((proc (async-start
;; What to do in the child process
(lambda ()
(message \"This is a test\")
(sleep-for 3)
222))))
(message \"I'm going to do some work here\") ;; ....
(message \"Waiting on async process, result should be 222: %s\"
(async-get proc)))
If you don't want to use a callback, and you don't care about any
return value from the child process, pass the `ignore' symbol as
the second argument (if you don't, and never call `async-get', it
will leave *emacs* process buffers hanging around):
(async-start
(lambda ()
(delete-file \"a remote file on a slow link\" nil))
\\='ignore)
Special case:
If the output of START-FUNC is a string with properties
e.g. (buffer-string) RESULT will be transformed in a list where the
car is the string itself (without props) and the cdr the rest of
properties, this allows using in FINISH-FUNC the string without
properties and then apply the properties in cdr to this string (if
needed).
Properties handling special objects like markers are returned as
list to allow restoring them later.
See <https://github.com/jwiegley/emacs-async/issues/145> for more infos.
Note: Even when FINISH-FUNC is present, a future is still
returned except that it yields no value (since the value is
passed to FINISH-FUNC). Call `async-get' on such a future always
returns nil. It can still be useful, however, as an argument to
`async-ready' or `async-wait'.
\(fn START-FUNC &optional FINISH-FUNC)" nil nil)
(register-definition-prefixes "async" '("async-"))
;;;***
;;;### (autoloads nil "async-bytecomp" "async-bytecomp.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from async-bytecomp.el
(autoload 'async-byte-recompile-directory "async-bytecomp" "\
Compile all *.el files in DIRECTORY asynchronously.
All *.elc files are systematically deleted before proceeding.
\(fn DIRECTORY &optional QUIET)" nil nil)
(defvar async-bytecomp-package-mode nil "\
Non-nil if Async-Bytecomp-Package mode is enabled.
See the `async-bytecomp-package-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `async-bytecomp-package-mode'.")
(custom-autoload 'async-bytecomp-package-mode "async-bytecomp" nil)
(autoload 'async-bytecomp-package-mode "async-bytecomp" "\
Byte compile asynchronously packages installed with package.el.
Async compilation of packages can be controlled by
`async-bytecomp-allowed-packages'.
This is a minor mode. If called interactively, toggle the
`Async-Bytecomp-Package mode' mode. If the prefix argument is
positive, enable the mode, and if it is zero or negative, disable
the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `(default-value \\='async-bytecomp-package-mode)'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
\(fn &optional ARG)" t nil)
(autoload 'async-byte-compile-file "async-bytecomp" "\
Byte compile Lisp code FILE asynchronously.
Same as `byte-compile-file' but asynchronous.
\(fn FILE)" t nil)
(register-definition-prefixes "async-bytecomp" '("async-"))
;;;***
;;;### (autoloads nil "dired-async" "dired-async.el" (0 0 0 0))
;;; Generated autoloads from dired-async.el
(defvar dired-async-mode nil "\
Non-nil if Dired-Async mode is enabled.
See the `dired-async-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `dired-async-mode'.")
(custom-autoload 'dired-async-mode "dired-async" nil)
(autoload 'dired-async-mode "dired-async" "\
Do dired actions asynchronously.
This is a minor mode. If called interactively, toggle the
`Dired-Async mode' mode. If the prefix argument is positive,
enable the mode, and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `(default-value \\='dired-async-mode)'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
\(fn &optional ARG)" t nil)
(autoload 'dired-async-do-copy "dired-async" "\
Run dired-do-copy asynchronously.
\(fn &optional ARG)" t nil)
(autoload 'dired-async-do-symlink "dired-async" "\
Run dired-do-symlink asynchronously.
\(fn &optional ARG)" t nil)
(autoload 'dired-async-do-hardlink "dired-async" "\
Run dired-do-hardlink asynchronously.
\(fn &optional ARG)" t nil)
(autoload 'dired-async-do-rename "dired-async" "\
Run dired-do-rename asynchronously.
\(fn &optional ARG)" t nil)
(register-definition-prefixes "dired-async" '("dired-async-"))
;;;***
;;;### (autoloads nil "smtpmail-async" "smtpmail-async.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from smtpmail-async.el
(register-definition-prefixes "smtpmail-async" '("async-smtpmail-"))
;;;***
;;;### (autoloads nil nil ("async-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; async-autoloads.el ends here

View file

@ -1,9 +1,7 @@
(define-package "async" "20230528.622" "Asynchronous processing in Emacs" (define-package "async" "20230216.559" "Asynchronous processing in Emacs"
'((emacs "24.4")) '((emacs "24.4"))
:commit "3ae74c0a4ba223ba373e0cb636c385e08d8838be" :authors :commit "71cc50f27ffc598a89aeaa593488d87818647d02" :authors
'(("John Wiegley" . "jwiegley@gmail.com")) '(("John Wiegley" . "jwiegley@gmail.com"))
:maintainers
'(("Thierry Volpiatto" . "thievol@posteo.net"))
:maintainer :maintainer
'("Thierry Volpiatto" . "thievol@posteo.net") '("Thierry Volpiatto" . "thievol@posteo.net")
:keywords :keywords

View file

@ -0,0 +1,453 @@
;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: John Wiegley <jwiegley@gmail.com>
;; Maintainer: Thierry Volpiatto <thievol@posteo.net>
;; Created: 18 Jun 2012
;; Version: 1.9.7
;; Package-Requires: ((emacs "24.4"))
;; Keywords: async
;; X-URL: https://github.com/jwiegley/emacs-async
;; 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:
;; Adds the ability to call asynchronous functions and process with ease. See
;; the documentation for `async-start' and `async-start-process'.
;;; Code:
(eval-when-compile (require 'cl-lib))
(defgroup async nil
"Simple asynchronous processing in Emacs"
:group 'lisp)
(defcustom async-variables-noprops-function #'async--purecopy
"Default function to remove text properties in variables."
:type 'function)
(defvar async-debug nil)
(defvar async-send-over-pipe t)
(defvar async-in-child-emacs nil)
(defvar async-callback nil)
(defvar async-callback-for-process nil)
(defvar async-callback-value nil)
(defvar async-callback-value-set nil)
(defvar async-current-process nil)
(defvar async--procvar nil)
(defvar async-child-init nil
"Initialisation file for async child Emacs.
If defined this allows for an init file to setup the child Emacs. It
should not be your normal init.el as that would likely load more
things that you require. It should limit itself to ensuring paths have
been setup so any async code can load libraries you expect.")
;; For emacs<29 (only exists in emacs-29+).
(defvar print-symbols-bare)
(defun async--purecopy (object)
"Remove text properties in OBJECT.
Argument OBJECT may be a list or a string, if anything else it
is returned unmodified."
(cond ((stringp object)
(substring-no-properties object))
((consp object)
(cl-loop for elm in object
;; A string.
if (stringp elm)
collect (substring-no-properties elm)
else
;; Proper lists.
if (and (consp elm) (null (cdr (last elm))))
collect (async--purecopy elm)
else
;; Dotted lists.
;; We handle here only dotted list where car and cdr
;; are atoms i.e. (x . y) and not (x . (x . y)) or
;; (x . (x y)) which should fit most cases.
if (and (consp elm) (cdr (last elm)))
collect (let ((key (car elm))
(val (cdr elm)))
(cons (if (stringp key)
(substring-no-properties key)
key)
(if (stringp val)
(substring-no-properties val)
val)))
else
collect elm))
(t object)))
(defun async-inject-variables
(include-regexp &optional predicate exclude-regexp noprops)
"Return a `setq' form that replicates part of the calling environment.
It sets the value for every variable matching INCLUDE-REGEXP and
also PREDICATE. It will not perform injection for any variable
matching EXCLUDE-REGEXP (if present) or representing a `syntax-table'
i.e. ending by \"-syntax-table\".
When NOPROPS is non nil it tries to strip out text properties of each
variable's value with `async-variables-noprops-function'.
It is intended to be used as follows:
(async-start
\\=`(lambda ()
(require \\='smtpmail)
(with-temp-buffer
(insert ,(buffer-substring-no-properties (point-min) (point-max)))
;; Pass in the variable environment for smtpmail
,(async-inject-variables \"\\\\=`\\(smtpmail\\|\\(user-\\)?mail\\)-\")
(smtpmail-send-it)))
\\='ignore)"
`(setq
,@(let (bindings)
(mapatoms
(lambda (sym)
(let* ((sname (and (boundp sym) (symbol-name sym)))
(value (and sname (symbol-value sym))))
(when (and sname
(or (null include-regexp)
(string-match include-regexp sname))
(or (null exclude-regexp)
(not (string-match exclude-regexp sname)))
(not (string-match "-syntax-table\\'" sname)))
(unless (or (stringp value)
(memq value '(nil t))
(numberp value)
(vectorp value))
(setq value `(quote ,value)))
(when noprops
(setq value (funcall async-variables-noprops-function
value)))
(when (or (null predicate)
(funcall predicate sym))
(setq bindings (cons value bindings)
bindings (cons sym bindings)))))))
bindings)))
(defalias 'async-inject-environment 'async-inject-variables)
(defun async-handle-result (func result buf)
(if (null func)
(progn
(set (make-local-variable 'async-callback-value) result)
(set (make-local-variable 'async-callback-value-set) t))
(unwind-protect
(if (and (listp result)
(eq 'async-signal (nth 0 result)))
(signal (car (nth 1 result))
(cdr (nth 1 result)))
(funcall func result))
(unless async-debug
(kill-buffer buf)))))
(defun async-when-done (proc &optional _change)
"Process sentinel used to retrieve the value from the child process."
(when (eq 'exit (process-status proc))
(with-current-buffer (process-buffer proc)
(let ((async-current-process proc))
(if (= 0 (process-exit-status proc))
(if async-callback-for-process
(if async-callback
(prog1
(funcall async-callback proc)
(unless async-debug
(kill-buffer (current-buffer))))
(set (make-local-variable 'async-callback-value) proc)
(set (make-local-variable 'async-callback-value-set) t))
;; Maybe strip out unreadable "#"; They are replaced by
;; empty string unless they are prefixing a special
;; object like a marker. See issue #145.
(goto-char (point-min))
(save-excursion
;; Transform markers in list like
;; (marker (moves after insertion) at 2338 in
;; test\.org) so that remap text properties function
;; can parse it to restitute marker.
(while (re-search-forward "#<\\([^>]*\\)>" nil t)
(replace-match (concat "(" (match-string 1) ")") t t)))
(while (re-search-forward "#(" nil t)
(replace-match "(" t t))
(goto-char (point-max))
(backward-sexp)
(async-handle-result async-callback (read (current-buffer))
(current-buffer)))
(set (make-local-variable 'async-callback-value)
(list 'error
(format "Async process '%s' failed with exit code %d"
(process-name proc) (process-exit-status proc))))
(set (make-local-variable 'async-callback-value-set) t))))))
(defun async--receive-sexp (&optional stream)
;; FIXME: Why use `utf-8-auto' instead of `utf-8-unix'? This is
;; a communication channel over which we have complete control,
;; so we get to choose exactly which encoding and EOL we use, isn't
;; it?
;; UPDATE: We use now `utf-8-emacs-unix' instead of `utf-8-auto' as
;; recommended in bug#165.
(let ((sexp (decode-coding-string (base64-decode-string (read stream))
'utf-8-emacs-unix))
;; Parent expects UTF-8 encoded text.
(coding-system-for-write 'utf-8-emacs-unix))
(if async-debug
(message "Received sexp {{{%s}}}" (pp-to-string sexp)))
(setq sexp (read sexp))
(if async-debug
(message "Read sexp {{{%s}}}" (pp-to-string sexp)))
(eval sexp t)))
(defun async--insert-sexp (sexp)
(let (print-level
print-length
(print-escape-nonascii t)
(print-circle t)
;; Fix bug#153 in emacs-29 with symbol's positions.
(print-symbols-bare t))
(prin1 sexp (current-buffer))
;; Just in case the string we're sending might contain EOF
(encode-coding-region (point-min) (point-max) 'utf-8-emacs-unix)
(base64-encode-region (point-min) (point-max) t)
(goto-char (point-min)) (insert ?\")
(goto-char (point-max)) (insert ?\" ?\n)))
(defun async--transmit-sexp (process sexp)
(with-temp-buffer
(if async-debug
(message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))
(async--insert-sexp sexp)
(process-send-region process (point-min) (point-max))))
(defun async-batch-invoke ()
"Called from the child Emacs process' command line."
;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent
;; process expects.
(let ((coding-system-for-write 'utf-8-emacs-unix)
(args-left command-line-args-left))
(setq async-in-child-emacs t
debug-on-error async-debug
command-line-args-left nil)
(condition-case-unless-debug err
(prin1 (funcall
(async--receive-sexp (unless async-send-over-pipe
args-left))))
(error
(prin1 (list 'async-signal err))))))
(defun async-ready (future)
"Query a FUTURE to see if it is ready.
I.e., if no blocking would result from a call to `async-get' on that FUTURE."
(and (memq (process-status future) '(exit signal))
(let ((buf (process-buffer future)))
(if (buffer-live-p buf)
(with-current-buffer buf
async-callback-value-set)
t))))
(defun async-wait (future)
"Wait for FUTURE to become ready."
(while (not (async-ready future))
(sleep-for 0.05)))
(defun async-get (future)
"Get the value from process FUTURE when it is ready.
FUTURE is returned by `async-start' or `async-start-process' when
its FINISH-FUNC is nil."
(and future (async-wait future))
(let ((buf (process-buffer future)))
(when (buffer-live-p buf)
(with-current-buffer buf
(async-handle-result
#'identity async-callback-value (current-buffer))))))
(defun async-message-p (value)
"Return non-nil of VALUE is an async.el message packet."
(and (listp value)
(plist-get value :async-message)))
(defun async-send (&rest args)
"Send the given messages to the asynchronous Emacs PROCESS."
(let ((args (append args '(:async-message t))))
(if async-in-child-emacs
(if async-callback
(funcall async-callback args))
(async--transmit-sexp (car args) (list 'quote (cdr args))))))
(defun async-receive ()
"Send the given messages to the asynchronous Emacs PROCESS."
(async--receive-sexp))
;;;###autoload
(defun async-start-process (name program finish-func &rest program-args)
"Start the executable PROGRAM asynchronously named NAME. See `async-start'.
PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
process object when done. If FINISH-FUNC is nil, the future
object will return the process object when the program is
finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
working directory."
(let* ((buf (generate-new-buffer (concat "*" name "*")))
(proc (let ((process-connection-type nil))
(apply #'start-process name buf program program-args))))
(with-current-buffer buf
(set (make-local-variable 'async-callback) finish-func)
(set-process-sentinel proc #'async-when-done)
(unless (string= name "emacs")
(set (make-local-variable 'async-callback-for-process) t))
proc)))
(defvar async-quiet-switch "-Q"
"The Emacs parameter to use to call emacs without config.
Can be one of \"-Q\" or \"-q\".
Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a
enhanced config or some more variables loaded.")
(defun async--emacs-program-args (&optional sexp)
"Return a list of arguments for invoking the child Emacs."
;; Using `locate-library' ensure we use the right file
;; when the .elc have been deleted.
(let ((args (list async-quiet-switch "-l" (locate-library "async"))))
(when async-child-init
(setq args (append args (list "-l" async-child-init))))
(append args (list "-batch" "-f" "async-batch-invoke"
(if sexp
(with-temp-buffer
(async--insert-sexp (list 'quote sexp))
(buffer-string))
"<none>")))))
;;;###autoload
(defun async-start (start-func &optional finish-func)
"Execute START-FUNC (often a lambda) in a subordinate Emacs process.
When done, the return value is passed to FINISH-FUNC. Example:
(async-start
;; What to do in the child process
(lambda ()
(message \"This is a test\")
(sleep-for 3)
222)
;; What to do when it finishes
(lambda (result)
(message \"Async process done, result should be 222: %s\"
result)))
If FINISH-FUNC is nil or missing, a future is returned that can
be inspected using `async-get', blocking until the value is
ready. Example:
(let ((proc (async-start
;; What to do in the child process
(lambda ()
(message \"This is a test\")
(sleep-for 3)
222))))
(message \"I'm going to do some work here\") ;; ....
(message \"Waiting on async process, result should be 222: %s\"
(async-get proc)))
If you don't want to use a callback, and you don't care about any
return value from the child process, pass the `ignore' symbol as
the second argument (if you don't, and never call `async-get', it
will leave *emacs* process buffers hanging around):
(async-start
(lambda ()
(delete-file \"a remote file on a slow link\" nil))
\\='ignore)
Special case:
If the output of START-FUNC is a string with properties
e.g. (buffer-string) RESULT will be transformed in a list where the
car is the string itself (without props) and the cdr the rest of
properties, this allows using in FINISH-FUNC the string without
properties and then apply the properties in cdr to this string (if
needed).
Properties handling special objects like markers are returned as
list to allow restoring them later.
See <https://github.com/jwiegley/emacs-async/issues/145> for more infos.
Note: Even when FINISH-FUNC is present, a future is still
returned except that it yields no value (since the value is
passed to FINISH-FUNC). Call `async-get' on such a future always
returns nil. It can still be useful, however, as an argument to
`async-ready' or `async-wait'."
(let ((sexp start-func)
;; Subordinate Emacs will send text encoded in UTF-8.
(coding-system-for-read 'utf-8-emacs-unix))
(setq async--procvar
(apply 'async-start-process
"emacs" (file-truename
(expand-file-name invocation-name
invocation-directory))
finish-func
(async--emacs-program-args (if (not async-send-over-pipe) sexp))))
(if async-send-over-pipe
(async--transmit-sexp async--procvar (list 'quote sexp)))
async--procvar))
(defmacro async-sandbox(func)
"Evaluate FUNC in a separate Emacs process, synchronously."
`(async-get (async-start ,func)))
(defun async--fold-left (fn forms bindings)
(let ((res forms))
(dolist (binding bindings)
(setq res (funcall fn res
(if (listp binding)
binding
(list binding)))))
res))
(defmacro async-let (bindings &rest forms)
"Implements `let', but each binding is established asynchronously.
For example:
(async-let ((x (foo))
(y (bar)))
(message \"%s %s\" x y))
expands to ==>
(async-start (foo)
(lambda (x)
(async-start (bar)
(lambda (y)
(message \"%s %s\" x y)))))"
(declare (indent 1))
(async--fold-left
(lambda (acc binding)
(let ((fun (pcase (cadr binding)
((and (pred functionp) f) f)
(f `(lambda () ,f)))))
`(async-start ,fun
(lambda (,(car binding))
,acc))))
`(progn ,@forms)
(reverse bindings)))
(provide 'async)
;;; async.el ends here

View file

@ -251,7 +251,7 @@ See `dired-create-files' for the behavior of arguments."
(setq overwrite-query nil) (setq overwrite-query nil)
(let ((total (length fn-list)) (let ((total (length fn-list))
failures async-fn-list skipped callback failures async-fn-list skipped callback
async-quiet-switch create-dir) async-quiet-switch)
(let (to) (let (to)
(dolist (from fn-list) (dolist (from fn-list)
(setq to (funcall name-constructor from)) (setq to (funcall name-constructor from))
@ -344,17 +344,7 @@ ESC or `q' to not overwrite any of the remaining files,
for destp = (file-exists-p to) for destp = (file-exists-p to)
do (and bf destp do (and bf destp
(with-current-buffer bf (with-current-buffer bf
(set-visited-file-name to t t))))))) (set-visited-file-name to t t))))))))
(let ((dirp (file-directory-p to))
(dest (file-name-directory to)))
(when (boundp 'dired-create-destination-dirs)
(setq create-dir
(cl-case dired-create-destination-dirs
(always 'always)
(ask (and (null dirp)
(null (file-directory-p dest))
(y-or-n-p (format "Create directory `%s'? " dest)))
'always))))))
;; Start async process. ;; Start async process.
(when async-fn-list (when async-fn-list
(process-put (process-put
@ -363,8 +353,7 @@ ESC or `q' to not overwrite any of the remaining files,
,(async-inject-variables dired-async-env-variables-regexp) ,(async-inject-variables dired-async-env-variables-regexp)
(let ((dired-recursive-copies (quote always)) (let ((dired-recursive-copies (quote always))
(dired-copy-preserve-time (dired-copy-preserve-time
,dired-copy-preserve-time) ,dired-copy-preserve-time))
(dired-create-destination-dirs ',create-dir))
(setq overwrite-backup-query nil) (setq overwrite-backup-query nil)
;; Inline `backup-file' as long as it is not ;; Inline `backup-file' as long as it is not
;; available in emacs. ;; available in emacs.

View file

@ -0,0 +1,211 @@
;;; async-bytecomp.el --- Compile elisp files asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Authors: John Wiegley <jwiegley@gmail.com>
;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async byte-compile
;; X-URL: https://github.com/jwiegley/emacs-async
;; 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:
;;
;; This package provide the `async-byte-recompile-directory' function
;; which allows, as the name says to recompile a directory outside of
;; your running emacs.
;; The benefit is your files will be compiled in a clean environment without
;; the old *.el files loaded.
;; Among other things, this fix a bug in package.el which recompile
;; the new files in the current environment with the old files loaded, creating
;; errors in most packages after upgrades.
;;
;; NB: This package is advicing the function `package--compile'.
;;; Code:
(require 'cl-lib)
(require 'async)
(require 'bytecomp)
(declare-function package-desc-name "package.el")
(declare-function package-desc-dir "package.el")
(defcustom async-bytecomp-allowed-packages 'all
"Packages in this list will be compiled asynchronously by `package--compile'.
All the dependencies of these packages will be compiled async too,
so no need to add dependencies to this list.
The value of this variable can also be the symbol `all' (default), in this case
all packages are always compiled asynchronously."
:group 'async
:type '(choice
(const :tag "All packages" all)
(repeat symbol)))
(defvar async-byte-compile-log-file
(concat user-emacs-directory "async-bytecomp.log"))
(defvar async-bytecomp-load-variable-regexp "\\`load-path\\'"
"The variable used by `async-inject-variables' when (re)compiling async.")
;;;###autoload
(defun async-byte-recompile-directory (directory &optional quiet)
"Compile all *.el files in DIRECTORY asynchronously.
All *.elc files are systematically deleted before proceeding."
(cl-loop with dir = (directory-files directory t "\\.elc\\'")
unless dir return nil
for f in dir
when (file-exists-p f) do (delete-file f))
;; Ensure async is reloaded when async.elc is deleted.
;; This happen when recompiling its own directory.
(load "async")
(let ((call-back
(lambda (&optional _ignore)
(if (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer))
(n 0))
(with-current-buffer buf
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)
(unless quiet
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^.*:Error:" nil t)
(cl-incf n)))
(if (> n 0)
(message "Failed to compile %d files in directory `%s'" n directory)
(message "Directory `%s' compiled asynchronously with warnings" directory)))))
(unless quiet
(message "Directory `%s' compiled asynchronously with success" directory))))))
(async-start
`(lambda ()
(require 'bytecomp)
,(async-inject-variables async-bytecomp-load-variable-regexp)
(let ((default-directory (file-name-as-directory ,directory))
error-data)
(add-to-list 'load-path default-directory)
(byte-recompile-directory ,directory 0 t)
(when (get-buffer byte-compile-log-buffer)
(setq error-data (with-current-buffer byte-compile-log-buffer
(buffer-substring-no-properties (point-min) (point-max))))
(unless (string= error-data "")
(with-temp-file ,async-byte-compile-log-file
(erase-buffer)
(insert error-data))))))
call-back)
(unless quiet (message "Started compiling asynchronously directory %s" directory))))
(defvar package-archive-contents)
(defvar package-alist)
(declare-function package-desc-reqs "package.el" (cl-x))
(defun async-bytecomp--get-package-deps (pkgs)
;; Same as `package--get-deps' but parse instead `package-archive-contents'
;; because PKG is not already installed and not present in `package-alist'.
;; However fallback to `package-alist' in case PKG no more present
;; in `package-archive-contents' due to modification to `package-archives'.
;; See issue #58.
(let ((seen '()))
(while pkgs
(let ((pkg (pop pkgs)))
(unless (memq pkg seen)
(let ((pkg-desc (cadr (or (assq pkg package-archive-contents)
(assq pkg package-alist)))))
(when pkg-desc
(push pkg seen)
(setq pkgs (append (mapcar #'car (package-desc-reqs pkg-desc))
pkgs)))))))
seen))
(defun async--package-compile (orig-fun pkg-desc &rest args)
(let ((cur-package (package-desc-name pkg-desc))
(pkg-dir (package-desc-dir pkg-desc)))
(if (or (member async-bytecomp-allowed-packages '(t all (all)))
(memq cur-package (async-bytecomp--get-package-deps
async-bytecomp-allowed-packages)))
(progn
;; FIXME: Why do we use (eq cur-package 'async) once
;; and (string= cur-package "async") afterwards?
(when (eq cur-package 'async)
(fmakunbound 'async-byte-recompile-directory))
;; Add to `load-path' the latest version of async and
;; reload it when reinstalling async.
(when (string= cur-package "async")
(cl-pushnew pkg-dir load-path)
(load "async-bytecomp"))
;; `async-byte-recompile-directory' will add directory
;; as needed to `load-path'.
(async-byte-recompile-directory (package-desc-dir pkg-desc) t))
(apply orig-fun pkg-desc args))))
;;;###autoload
(define-minor-mode async-bytecomp-package-mode
"Byte compile asynchronously packages installed with package.el.
Async compilation of packages can be controlled by
`async-bytecomp-allowed-packages'."
:group 'async
:global t
(if async-bytecomp-package-mode
(advice-add 'package--compile :around #'async--package-compile)
(advice-remove 'package--compile #'async--package-compile)))
;;;###autoload
(defun async-byte-compile-file (file)
"Byte compile Lisp code FILE asynchronously.
Same as `byte-compile-file' but asynchronous."
(interactive "fFile: ")
(let ((call-back
(lambda (&optional _ignore)
(let ((bn (file-name-nondirectory file)))
(if (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer))
start)
(with-current-buffer buf
(goto-char (setq start (point-max)))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)
(save-excursion
(goto-char start)
(if (re-search-forward "^.*:Error:" nil t)
(message "Failed to compile `%s'" bn)
(message "`%s' compiled asynchronously with warnings" bn)))))
(message "`%s' compiled asynchronously with success" bn))))))
(async-start
`(lambda ()
(require 'bytecomp)
,(async-inject-variables async-bytecomp-load-variable-regexp)
(let ((default-directory ,(file-name-directory file)))
(add-to-list 'load-path default-directory)
(byte-compile-file ,file)
(when (get-buffer byte-compile-log-buffer)
(setq error-data (with-current-buffer byte-compile-log-buffer
(buffer-substring-no-properties (point-min) (point-max))))
(unless (string= error-data "")
(with-temp-file ,async-byte-compile-log-file
(erase-buffer)
(insert error-data))))))
call-back)))
(provide 'async-bytecomp)
;;; async-bytecomp.el ends here

View file

@ -0,0 +1,12 @@
(define-package "async" "20230323.643" "Asynchronous processing in Emacs"
'((emacs "24.4"))
:commit "34feabe1142863a2c96f75afda1a2ae4aa0813f6" :authors
'(("John Wiegley" . "jwiegley@gmail.com"))
:maintainer
'("Thierry Volpiatto" . "thievol@posteo.net")
:keywords
'("async")
:url "https://github.com/jwiegley/emacs-async")
;; Local Variables:
;; no-byte-compile: t
;; End:

View file

@ -0,0 +1,455 @@
;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
;; Copyright (C) 2012-2019 Free Software Foundation, Inc.
;; Authors: John Wiegley <jwiegley@gmail.com>
;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async network
;; X-URL: https://github.com/jwiegley/emacs-async
;; 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:
;; This file provide a redefinition of `dired-create-file' function,
;; performs copies, moves and all what is handled by `dired-create-file'
;; in the background using a slave Emacs process,
;; by means of the async.el module.
;; To use it, put this in your .emacs:
;; (dired-async-mode 1)
;; This will enable async copy/rename etc...
;; in dired and helm.
;;; Code:
(require 'cl-lib)
(require 'dired-aux)
(require 'async)
(eval-when-compile
(defvar async-callback))
(defgroup dired-async nil
"Copy rename files asynchronously from dired."
:group 'dired)
(defcustom dired-async-env-variables-regexp
"\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
"Variables matching this regexp will be loaded on Child Emacs."
:type 'regexp)
(defcustom dired-async-message-function 'dired-async-mode-line-message
"Function to use to notify result when operation finish.
Should take same args as `message'."
:type 'function)
(defcustom dired-async-log-file "/tmp/dired-async.log"
"File use to communicate errors from Child Emacs to host Emacs."
:type 'string)
(defcustom dired-async-mode-lighter '(:eval
(when (eq major-mode 'dired-mode)
" Async"))
"Mode line lighter used for `dired-async-mode'."
:risky t
:type 'sexp)
(defcustom dired-async-skip-fast nil
"If non-nil, skip async for fast operations.
Same device renames and copying and renaming files smaller than
`dired-async-small-file-max' are considered fast."
:risky t
:type 'boolean)
(defcustom dired-async-small-file-max 5000000
"Files smaller than this in bytes are considered fast to copy
or rename for `dired-async-skip-fast'."
:risky t
:type 'integer)
(defface dired-async-message
'((t (:foreground "yellow")))
"Face used for mode-line message.")
(defface dired-async-failures
'((t (:foreground "red")))
"Face used for mode-line message.")
(defface dired-async-mode-message
'((t (:foreground "Gold")))
"Face used for `dired-async--modeline-mode' lighter.")
(define-minor-mode dired-async--modeline-mode
"Notify mode-line that an async process run."
:global t
:lighter (:eval (propertize (format " [%s Async job(s) running]"
(length (dired-async-processes)))
'face 'dired-async-mode-message))
(unless dired-async--modeline-mode
(let ((visible-bell t)) (ding))))
(defun dired-async-mode-line-message (text face &rest args)
"Notify end of operation in `mode-line'."
(message nil)
(let ((mode-line-format (concat
" " (propertize
(if args
(apply #'format text args)
text)
'face face))))
(force-mode-line-update)
(sit-for 3)
(force-mode-line-update)))
(defun dired-async-processes ()
(cl-loop for p in (process-list)
when (process-get p 'dired-async-process)
collect p))
(defun dired-async-kill-process ()
(interactive)
(let* ((processes (dired-async-processes))
(proc (car (last processes))))
(and proc (delete-process proc))
(unless (> (length processes) 1)
(dired-async--modeline-mode -1))))
(defun dired-async-after-file-create (total operation failures skipped)
"Callback function used for operation handled by `dired-create-file'."
(unless (dired-async-processes)
;; Turn off mode-line notification
;; only when last process end.
(dired-async--modeline-mode -1))
(when operation
(if (file-exists-p dired-async-log-file)
(progn
(pop-to-buffer (get-buffer-create dired-log-buffer))
(goto-char (point-max))
(setq inhibit-read-only t)
(insert "Error: ")
(insert-file-contents dired-async-log-file)
(special-mode)
(shrink-window-if-larger-than-buffer)
(delete-file dired-async-log-file))
(run-with-timer
0.1 nil
(lambda ()
;; First send error messages.
(cond (failures
(funcall dired-async-message-function
"%s failed for %d of %d file%s -- See *Dired log* buffer"
'dired-async-failures
(car operation) (length failures)
total (dired-plural-s total)))
(skipped
(funcall dired-async-message-function
"%s: %d of %d file%s skipped -- See *Dired log* buffer"
'dired-async-failures
(car operation) (length skipped) total
(dired-plural-s total))))
(when dired-buffers
(cl-loop for (_f . b) in dired-buffers
when (buffer-live-p b)
do (with-current-buffer b
(when (and (not (file-remote-p default-directory nil t))
(file-exists-p default-directory))
(revert-buffer nil t)))))
;; Finally send the success message.
(funcall dired-async-message-function
"Asynchronous %s of %s on %s file%s done"
'dired-async-message
(car operation) (cadr operation)
total (dired-plural-s total)))))))
(defun dired-async-maybe-kill-ftp ()
"Return a form to kill ftp process in child emacs."
(quote
(progn
(require 'cl-lib)
(let ((buf (cl-loop for b in (buffer-list)
thereis (and (string-match
"\\`\\*ftp.*"
(buffer-name b)) b))))
(when buf (kill-buffer buf))))))
(defsubst dired-async--directory-p (attributes)
"Return non-nil if ATTRIBUTES is for a directory.
See `file-attributes'."
;; Can also be a string for symlinks, so check for t explicitly.
(eq (file-attribute-type attributes) t))
(defsubst dired-async--same-device-p (f1 f2)
"Return non-nil if F1 and F2 have the same device number."
;; file-attribute-device-number may be a cons cell, so use equal for
;; testing (See Emacs bug/58446).
(equal (file-attribute-device-number (file-attributes f1))
(file-attribute-device-number (file-attributes f2))))
(defun dired-async--small-file-p (file)
"Return non-nil if FILE is considered small.
File is considered small if it size is smaller than
`dired-async-small-file-max'."
(let ((a (file-attributes file)))
;; Directories are always large since we can't easily figure out
;; their total size.
(and (not (dired-async--directory-p a))
(< (file-attribute-size a) dired-async-small-file-max))))
(defun dired-async--skip-async-p (file-creator file name-constructor)
"Return non-nil if we should skip async for FILE.
See `dired-create-files' for FILE-CREATOR and NAME-CONSTRUCTOR."
;; Skip async for small files.
(or (dired-async--small-file-p file)
;; Also skip async for same device renames.
(and (eq file-creator 'dired-rename-file)
(let ((new (funcall name-constructor file)))
(dired-async--same-device-p file (file-name-directory new))))))
(defun dired-async--smart-create-files (old-func file-creator
operation fn-list name-constructor
&optional marker-char)
"Around advice for `dired-create-files'.
Uses async like `dired-async-create-files' but skips certain fast
cases if `dired-async-skip-fast' is non-nil."
(let (async-list quick-list)
(if (or (eq file-creator 'backup-file)
(null dired-async-skip-fast))
(setq async-list fn-list)
(dolist (old fn-list)
(if (dired-async--skip-async-p file-creator old name-constructor)
(push old quick-list)
(push old async-list))))
(when async-list
(dired-async-create-files
file-creator operation (nreverse async-list)
name-constructor marker-char))
(when quick-list
(funcall old-func file-creator operation
(nreverse quick-list) name-constructor marker-char))))
(defvar overwrite-query)
(defun dired-async-create-files (file-creator operation fn-list name-constructor
&optional _marker-char)
"Same as `dired-create-files' but asynchronous.
See `dired-create-files' for the behavior of arguments."
(setq overwrite-query nil)
(let ((total (length fn-list))
failures async-fn-list skipped callback
async-quiet-switch)
(let (to)
(dolist (from fn-list)
(setq to (funcall name-constructor from))
(if (and (equal to from)
(null (eq file-creator 'backup-file)))
(progn
(setq to nil)
(dired-log "Cannot %s to same file: %s\n"
(downcase operation) from)))
(if (not to)
(setq skipped (cons (dired-make-relative from) skipped))
(let* ((overwrite (and (null (eq file-creator 'backup-file))
(file-exists-p to)))
(dired-overwrite-confirmed ; for dired-handle-overwrite
(and overwrite
(let ((help-form `(format "\
Type SPC or `y' to overwrite file `%s',
DEL or `n' to skip to next,
ESC or `q' to not overwrite any of the remaining files,
`!' to overwrite all remaining files with no more questions." ,to)))
(dired-query 'overwrite-query "Overwrite `%s'?" to)))))
;; Handle the `dired-copy-file' file-creator specially
;; When copying a directory to another directory or
;; possibly to itself or one of its subdirectories.
;; e.g "~/foo/" => "~/test/"
;; or "~/foo/" =>"~/foo/"
;; or "~/foo/ => ~/foo/bar/")
;; In this case the 'name-constructor' have set the destination
;; TO to "~/test/foo" because the old emacs23 behavior
;; of `copy-directory' was to not create the subdirectory
;; and instead copy the contents.
;; With the new behavior of `copy-directory'
;; (similar to the `cp' shell command) we don't
;; need such a construction of the target directory,
;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
(let ((destname (file-name-directory to)))
(when (and (file-directory-p from)
(file-directory-p to)
(eq file-creator 'dired-copy-file))
(setq to destname))
;; If DESTNAME is a subdirectory of FROM, not a symlink,
;; and the method in use is copying, signal an error.
(and (eq t (car (file-attributes destname)))
(eq file-creator 'dired-copy-file)
(file-in-directory-p destname from)
(error "Cannot copy `%s' into its subdirectory `%s'"
from to)))
(if overwrite
(or (and dired-overwrite-confirmed
(push (cons from to) async-fn-list))
(progn
(push (dired-make-relative from) failures)
(dired-log "%s `%s' to `%s' failed\n"
operation from to)))
(push (cons from to) async-fn-list)))))
;; Fix tramp issue #80 with emacs-26, use "-q" only when needed.
(setq async-quiet-switch
(if (and (boundp 'tramp-cache-read-persistent-data)
async-fn-list
(cl-loop for (_from . to) in async-fn-list
thereis (file-remote-p to)))
"-q" "-Q"))
;; When failures have been printed to dired log add the date at bob.
(when (or failures skipped) (dired-log t))
;; When async-fn-list is empty that's mean only one file
;; had to be copied and user finally answer NO.
;; In this case async process will never start and callback
;; will have no chance to run, so notify failures here.
(unless async-fn-list
(cond (failures
(funcall dired-async-message-function
"%s failed for %d of %d file%s -- See *Dired log* buffer"
'dired-async-failures
operation (length failures)
total (dired-plural-s total)))
(skipped
(funcall dired-async-message-function
"%s: %d of %d file%s skipped -- See *Dired log* buffer"
'dired-async-failures
operation (length skipped) total
(dired-plural-s total)))))
;; Setup callback.
(setq callback
(lambda (&optional _ignore)
(dired-async-after-file-create
total (list operation (length async-fn-list)) failures skipped)
(when (string= (downcase operation) "rename")
(cl-loop for (file . to) in async-fn-list
for bf = (get-file-buffer file)
for destp = (file-exists-p to)
do (and bf destp
(with-current-buffer bf
(set-visited-file-name to t t))))))))
;; Start async process.
(when async-fn-list
(process-put
(async-start `(lambda ()
(require 'cl-lib) (require 'dired-aux) (require 'dired-x)
,(async-inject-variables dired-async-env-variables-regexp)
(let ((dired-recursive-copies (quote always))
(dired-copy-preserve-time
,dired-copy-preserve-time))
(setq overwrite-backup-query nil)
;; Inline `backup-file' as long as it is not
;; available in emacs.
(defalias 'backup-file
;; Same feature as "cp -f --backup=numbered from to"
;; Symlinks are copied as file from source unlike
;; `dired-copy-file' which is same as cp -d.
;; Directories are omitted.
(lambda (from to ok)
(cond ((file-directory-p from) (ignore))
(t (let ((count 0))
(while (let ((attrs (file-attributes to)))
(and attrs (null (nth 0 attrs))))
(cl-incf count)
(setq to (concat (file-name-sans-versions to)
(format ".~%s~" count)))))
(condition-case err
(copy-file from to ok dired-copy-preserve-time)
(file-date-error
(dired-log "Can't set date on %s:\n%s\n" from err)))))))
;; Now run the FILE-CREATOR function on files.
(cl-loop with fn = (quote ,file-creator)
for (from . dest) in (quote ,async-fn-list)
do (condition-case err
(funcall fn from dest t)
(file-error
(dired-log "%s: %s\n" (car err) (cdr err))
nil)))
(when (get-buffer dired-log-buffer)
(dired-log t)
(with-current-buffer dired-log-buffer
(write-region (point-min) (point-max)
,dired-async-log-file))))
,(dired-async-maybe-kill-ftp))
callback)
'dired-async-process t)
;; Run mode-line notifications while process running.
(dired-async--modeline-mode 1)
(message "%s proceeding asynchronously..." operation))))
(defvar wdired-use-interactive-rename)
(defun dired-async-wdired-do-renames (old-fn &rest args)
;; Perhaps a better fix would be to ask for renaming BEFORE starting
;; OLD-FN when `wdired-use-interactive-rename' is non-nil. For now
;; just bind it to nil to ensure no questions will be asked between
;; each rename.
(let (wdired-use-interactive-rename)
(apply old-fn args)))
;;;###autoload
(define-minor-mode dired-async-mode
"Do dired actions asynchronously."
:lighter dired-async-mode-lighter
:global t
(if dired-async-mode
(progn
(advice-add 'dired-create-files :around #'dired-async--smart-create-files)
(advice-add 'wdired-do-renames :around #'dired-async-wdired-do-renames))
(progn
(advice-remove 'dired-create-files #'dired-async--smart-create-files)
(advice-remove 'wdired-do-renames #'dired-async-wdired-do-renames))))
(defmacro dired-async--with-async-create-files (&rest body)
"Evaluate BODY with dired-create-files set to dired-async-create-files."
(declare (indent 0))
`(cl-letf (((symbol-function 'dired-create-files) #'dired-async-create-files))
,@body))
;;;###autoload
(defun dired-async-do-copy (&optional arg)
"Run dired-do-copy asynchronously."
(interactive "P")
(dired-async--with-async-create-files
(dired-do-copy arg)))
;;;###autoload
(defun dired-async-do-symlink (&optional arg)
"Run dired-do-symlink asynchronously."
(interactive "P")
(dired-async--with-async-create-files
(dired-do-symlink arg)))
;;;###autoload
(defun dired-async-do-hardlink (&optional arg)
"Run dired-do-hardlink asynchronously."
(interactive "P")
(dired-async--with-async-create-files
(dired-do-hardlink arg)))
;;;###autoload
(defun dired-async-do-rename (&optional arg)
"Run dired-do-rename asynchronously."
(interactive "P")
(dired-async--with-async-create-files
(dired-do-rename arg)))
(provide 'dired-async)
;;; dired-async.el ends here

View file

@ -0,0 +1,71 @@
;;; smtpmail-async.el --- Send e-mail with smtpmail.el asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: John Wiegley <jwiegley@gmail.com>
;; Created: 18 Jun 2012
;; Keywords: email async
;; X-URL: https://github.com/jwiegley/emacs-async
;; 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:
;; Send e-mail with smtpmail.el asynchronously. To use:
;;
;; (require 'smtpmail-async)
;;
;; (setq send-mail-function 'async-smtpmail-send-it
;; message-send-mail-function 'async-smtpmail-send-it)
;;
;; This assumes you already have smtpmail.el working.
;;; Code:
(defgroup smtpmail-async nil
"Send e-mail with smtpmail.el asynchronously"
:group 'smptmail)
(require 'async)
(require 'smtpmail)
(require 'message)
(defvar async-smtpmail-before-send-hook nil
"Hook running in the child emacs in `async-smtpmail-send-it'.
It is called just before calling `smtpmail-send-it'.")
(defun async-smtpmail-send-it ()
(let ((to (message-field-value "To"))
(buf-content (buffer-substring-no-properties
(point-min) (point-max))))
(message "Delivering message to %s..." to)
(async-start
`(lambda ()
(require 'smtpmail)
(with-temp-buffer
(insert ,buf-content)
(set-buffer-multibyte nil)
;; Pass in the variable environment for smtpmail
,(async-inject-variables
"\\`\\(smtpmail\\|async-smtpmail\\|\\(user-\\)?mail\\)-\\|auth-sources\\|epg\\|nsm"
nil "\\`\\(mail-header-format-function\\|smtpmail-address-buffer\\|mail-mode-abbrev-table\\)")
(run-hooks 'async-smtpmail-before-send-hook)
(smtpmail-send-it)))
(lambda (&optional _ignore)
(message "Delivering message to %s...done" to)))))
(provide 'smtpmail-async)
;;; smtpmail-async.el ends here

View file

@ -168,31 +168,10 @@ Default is 'hand. The following scopes are possible:
;;; Icons ;;; Icons
;; ;;
(defcustom centaur-tabs-set-icons nil (defcustom centaur-tabs-set-icons nil
"When non nil, display an icon based on `centaur-tabs-icon-type' alongside the tab name." "When non nil, display an icon from all-the-icons alongside the tab name."
:group 'centaur-tabs :group 'centaur-tabs
:type 'boolean) :type 'boolean)
(defcustom centaur-tabs-icon-type (and centaur-tabs-set-icons
(or (require 'all-the-icons nil t)
(require 'nerd-icons nil t)))
"Icon type. It should be one of `all-the-icons' and `nerd-icons'."
:group 'centaur-tabs
:type 'symbol
:set
(lambda (k v)
(pcase v
('all-the-icons
(unless (require 'all-the-icons nil t)
(setq v nil)))
('nerd-icons
(unless (require 'nerd-icons nil t)
(setq v nil)))
(type
(if (require 'all-the-icons nil t)
(setq v 'all-the-icons)
(setq v nil))))
(set k v)))
(defvar centaur-tabs-icon-scale-factor (defvar centaur-tabs-icon-scale-factor
1.0 1.0
"The base scale factor for the `height' face property of tab icons.") "The base scale factor for the `height' face property of tab icons.")
@ -212,41 +191,19 @@ Default is 'hand. The following scopes are possible:
:group 'centaur-tabs :group 'centaur-tabs
:type 'boolean) :type 'boolean)
(defun centaur-tabs--icon-for-file (file &rest args)
"Get the formatted icon for FILE.
ARGS should be a plist containing `:height', `:v-adjust', or `:face' properties."
(pcase centaur-tabs-icon-type
('all-the-icons (apply #'all-the-icons-icon-for-file file args))
('nerd-icons (apply #'nerd-icons-icon-for-file file args))))
(defun centaur-tabs--icon-for-mode (mode &rest args)
"Get the formatted icon for MODE.
ARG-OVERRIDES should be a plist containining `:height',
`:v-adjust' or `:face' properties like in the normal icon
inserting functions."
(pcase centaur-tabs-icon-type
('all-the-icons (apply #'all-the-icons-icon-for-mode mode args))
('nerd-icons (apply #'nerd-icons-icon-for-mode mode args))))
(defun centaur-tabs--auto-mode-match? (&optional file)
"Whether or not FILE's `major-mode' match against its `auto-mode-alist'."
(pcase centaur-tabs-icon-type
('all-the-icons (apply #'all-the-icons-auto-mode-match? file))
('nerd-icons (apply #'nerd-icons-auto-mode-match? file))))
(defun centaur-tabs-icon (tab face selected) (defun centaur-tabs-icon (tab face selected)
"Generate icon for TAB using FACE's background. "Generate all-the-icons icon for TAB using FACE's background.
If icon gray out option enabled, gray out icon if not SELECTED." If icon gray out option enabled, gray out icon if not SELECTED."
(if centaur-tabs-icon-type (if (featurep 'all-the-icons)
(with-current-buffer (car tab) (with-current-buffer (car tab)
(let* ((icon (let* ((icon
(if (and (buffer-file-name) (if (and (buffer-file-name)
(centaur-tabs--auto-mode-match?)) (all-the-icons-auto-mode-match?))
(centaur-tabs--icon-for-file (all-the-icons-icon-for-file
(file-name-nondirectory (buffer-file-name)) (file-name-nondirectory (buffer-file-name))
:v-adjust centaur-tabs-icon-v-adjust :v-adjust centaur-tabs-icon-v-adjust
:height centaur-tabs-icon-scale-factor) :height centaur-tabs-icon-scale-factor)
(centaur-tabs--icon-for-mode (all-the-icons-icon-for-mode
major-mode major-mode
:v-adjust centaur-tabs-icon-v-adjust :v-adjust centaur-tabs-icon-v-adjust
:height centaur-tabs-icon-scale-factor))) :height centaur-tabs-icon-scale-factor)))

View file

@ -36,10 +36,6 @@
(declare-function all-the-icons-auto-mode-match? "ext:all-the-icons.el" t t) (declare-function all-the-icons-auto-mode-match? "ext:all-the-icons.el" t t)
(declare-function all-the-icons-icon-for-file "ext:all-the-icons.el" t t) (declare-function all-the-icons-icon-for-file "ext:all-the-icons.el" t t)
(declare-function all-the-icons-icon-for-mode "ext:all-the-icons.el" t t) (declare-function all-the-icons-icon-for-mode "ext:all-the-icons.el" t t)
(declare-function nerd-icons-match? "ext:nerd-icons.el" t t)
(declare-function nerd-icons-auto-mode-match? "ext:nerd-icons.el" t t)
(declare-function nerd-icons-icon-for-file "ext:nerd-icons.el" t t)
(declare-function nerd-icons-icon-for-mode "ext:nerd-icons.el" t t)
(declare-function projectile-project-root "ext:projectile.el" t t) (declare-function projectile-project-root "ext:projectile.el" t t)
(declare-function projectile-project-name "ext:projectile.el" t t) (declare-function projectile-project-name "ext:projectile.el" t t)
(defvar helm-source-centaur-tabs-group) (defvar helm-source-centaur-tabs-group)

View file

@ -1,10 +1,8 @@
(define-package "centaur-tabs" "20230607.1501" "Aesthetic, modern looking customizable tabs plugin" (define-package "centaur-tabs" "20230109.457" "Aesthetic, modern looking customizable tabs plugin"
'((emacs "24.4") '((emacs "24.4")
(powerline "2.4") (powerline "2.4")
(cl-lib "0.5")) (cl-lib "0.5"))
:commit "0bb1aa18d475319df85f192dce3327802866c3c3" :authors :commit "a2890d968d877b269a814a691356fc5877833c39" :authors
'(("Emmanuel Bustos" . "ema2159@gmail.com"))
:maintainers
'(("Emmanuel Bustos" . "ema2159@gmail.com")) '(("Emmanuel Bustos" . "ema2159@gmail.com"))
:maintainer :maintainer
'("Emmanuel Bustos" . "ema2159@gmail.com") '("Emmanuel Bustos" . "ema2159@gmail.com")

View file

@ -1,8 +1,6 @@
(define-package "dash" "20230714.723" "A modern list library for Emacs" (define-package "dash" "20221013.836" "A modern list library for Emacs"
'((emacs "24")) '((emacs "24"))
:commit "f46268c75cb7c18361d3cee942cd4dc14a03aef4" :authors :commit "3df46d7d9fe74f52a661565888e4d31fd760f0df" :authors
'(("Magnar Sveen" . "magnars@gmail.com"))
:maintainers
'(("Magnar Sveen" . "magnars@gmail.com")) '(("Magnar Sveen" . "magnars@gmail.com"))
:maintainer :maintainer
'("Magnar Sveen" . "magnars@gmail.com") '("Magnar Sveen" . "magnars@gmail.com")

File diff suppressed because it is too large Load diff

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,87 @@
;;; dash-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "dash" "dash.el" (0 0 0 0))
;;; Generated autoloads from dash.el
(autoload 'dash-fontify-mode "dash" "\
Toggle fontification of Dash special variables.
This is a minor mode. If called interactively, toggle the
`Dash-Fontify mode' mode. If the prefix argument is positive,
enable the mode, and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `dash-fontify-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
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'.
\(fn &optional ARG)" t nil)
(put 'global-dash-fontify-mode 'globalized-minor-mode t)
(defvar global-dash-fontify-mode nil "\
Non-nil if Global Dash-Fontify mode is enabled.
See the `global-dash-fontify-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `global-dash-fontify-mode'.")
(custom-autoload 'global-dash-fontify-mode "dash" nil)
(autoload 'global-dash-fontify-mode "dash" "\
Toggle Dash-Fontify mode in all buffers.
With prefix ARG, enable Global Dash-Fontify mode if ARG is positive;
otherwise, disable it.
If called from Lisp, toggle the mode if ARG is `toggle'.
Enable the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
Dash-Fontify mode is enabled in all buffers where
`dash--turn-on-fontify-mode' would do it.
See `dash-fontify-mode' for more information on Dash-Fontify mode.
\(fn &optional ARG)" t nil)
(autoload 'dash-register-info-lookup "dash" "\
Register the Dash Info manual with `info-lookup-symbol'.
This allows Dash symbols to be looked up with \\[info-lookup-symbol]." t nil)
(register-definition-prefixes "dash" '("!cdr" "!cons" "--" "->" "-a" "-butlast" "-c" "-d" "-e" "-f" "-gr" "-i" "-juxt" "-keep" "-l" "-m" "-no" "-o" "-p" "-r" "-s" "-t" "-u" "-value-to-list" "-when-let" "-zip" "dash-"))
;;;***
;;;### (autoloads nil nil ("dash-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; dash-autoloads.el ends here

View file

@ -0,0 +1,12 @@
(define-package "dash" "20230304.2223" "A modern list library for Emacs"
'((emacs "24"))
:commit "bdf4a5d868618532d34c7b5bae6ac382c3b58f67" :authors
'(("Magnar Sveen" . "magnars@gmail.com"))
:maintainer
'("Magnar Sveen" . "magnars@gmail.com")
:keywords
'("extensions" "lisp")
:url "https://github.com/magnars/dash.el")
;; Local Variables:
;; no-byte-compile: t
;; End:

View file

@ -35,11 +35,11 @@
(unless (fboundp 'gv-define-setter) (unless (fboundp 'gv-define-setter)
(require 'cl)) (require 'cl))
;; - 24.3 started complaining about unknown `declare' props. ;; TODO: Emacs versions 24.3..24.5 complain about unknown `declare'
;; - 25 introduced `pure' and `side-effect-free'. ;; props, so remove this when support for those versions is dropped.
;; - 30 introduced `important-return-value'. (and (< emacs-major-version 25)
(when (boundp 'defun-declarations-alist) (boundp 'defun-declarations-alist)
(dolist (prop '(important-return-value pure side-effect-free)) (dolist (prop '(pure side-effect-free))
(unless (assq prop defun-declarations-alist) (unless (assq prop defun-declarations-alist)
(push (list prop #'ignore) defun-declarations-alist))))) (push (list prop #'ignore) defun-declarations-alist)))))
@ -223,7 +223,6 @@ This function's anaphoric counterpart is `--dotimes'."
"Apply FN to each item in LIST and return the list of results. "Apply FN to each item in LIST and return the list of results.
This function's anaphoric counterpart is `--map'." This function's anaphoric counterpart is `--map'."
(declare (important-return-value t))
(mapcar fn list)) (mapcar fn list))
(defmacro --map (form list) (defmacro --map (form list)
@ -259,7 +258,6 @@ etc. If LIST is empty, return INIT without calling FN.
This function's anaphoric counterpart is `--reduce-from'. This function's anaphoric counterpart is `--reduce-from'.
For other folds, see also `-reduce' and `-reduce-r'." For other folds, see also `-reduce' and `-reduce-r'."
(declare (important-return-value t))
(--reduce-from (funcall fn acc it) init list)) (--reduce-from (funcall fn acc it) init list))
(defmacro --reduce (form list) (defmacro --reduce (form list)
@ -291,7 +289,6 @@ arguments.
This function's anaphoric counterpart is `--reduce'. This function's anaphoric counterpart is `--reduce'.
For other folds, see also `-reduce-from' and `-reduce-r'." For other folds, see also `-reduce-from' and `-reduce-r'."
(declare (important-return-value t))
(if list (if list
(-reduce-from fn (car list) (cdr list)) (-reduce-from fn (car list) (cdr list))
(funcall fn))) (funcall fn)))
@ -323,7 +320,6 @@ its last link with INIT, and evaluating the resulting expression.
This function's anaphoric counterpart is `--reduce-r-from'. This function's anaphoric counterpart is `--reduce-r-from'.
For other folds, see also `-reduce-r' and `-reduce'." For other folds, see also `-reduce-r' and `-reduce'."
(declare (important-return-value t))
(--reduce-r-from (funcall fn it acc) init list)) (--reduce-r-from (funcall fn it acc) init list))
(defmacro --reduce-r (form list) (defmacro --reduce-r (form list)
@ -353,7 +349,6 @@ ignoring its last link, and evaluating the resulting expression.
This function's anaphoric counterpart is `--reduce-r'. This function's anaphoric counterpart is `--reduce-r'.
For other folds, see also `-reduce-r-from' and `-reduce'." For other folds, see also `-reduce-r-from' and `-reduce'."
(declare (important-return-value t))
(if list (if list
(--reduce-r (funcall fn it acc) list) (--reduce-r (funcall fn it acc) list)
(funcall fn))) (funcall fn)))
@ -379,7 +374,6 @@ arguments.
This function's anaphoric counterpart is `--reductions-from'. This function's anaphoric counterpart is `--reductions-from'.
For other folds, see also `-reductions' and `-reductions-r'." For other folds, see also `-reductions' and `-reductions-r'."
(declare (important-return-value t))
(--reductions-from (funcall fn acc it) init list)) (--reductions-from (funcall fn acc it) init list))
(defmacro --reductions (form list) (defmacro --reductions (form list)
@ -406,7 +400,6 @@ when `-reduce' (which see) is called with the same arguments.
This function's anaphoric counterpart is `--reductions'. This function's anaphoric counterpart is `--reductions'.
For other folds, see also `-reductions' and `-reductions-r'." For other folds, see also `-reductions' and `-reductions-r'."
(declare (important-return-value t))
(if list (if list
(--reductions-from (funcall fn acc it) (car list) (cdr list)) (--reductions-from (funcall fn acc it) (car list) (cdr list))
(list (funcall fn)))) (list (funcall fn))))
@ -431,7 +424,6 @@ arguments.
This function's anaphoric counterpart is `--reductions-r-from'. This function's anaphoric counterpart is `--reductions-r-from'.
For other folds, see also `-reductions' and `-reductions-r'." For other folds, see also `-reductions' and `-reductions-r'."
(declare (important-return-value t))
(--reductions-r-from (funcall fn it acc) init list)) (--reductions-r-from (funcall fn it acc) init list))
(defmacro --reductions-r (form list) (defmacro --reductions-r (form list)
@ -461,7 +453,6 @@ This function's anaphoric counterpart is `--reductions-r'.
For other folds, see also `-reductions-r-from' and For other folds, see also `-reductions-r-from' and
`-reductions'." `-reductions'."
(declare (important-return-value t))
(if list (if list
(--reductions-r (funcall fn it acc) list) (--reductions-r (funcall fn it acc) list)
(list (funcall fn)))) (list (funcall fn))))
@ -486,7 +477,6 @@ Alias: `-select'.
This function's anaphoric counterpart is `--filter'. This function's anaphoric counterpart is `--filter'.
For similar operations, see also `-keep' and `-remove'." For similar operations, see also `-keep' and `-remove'."
(declare (important-return-value t))
(--filter (funcall pred it) list)) (--filter (funcall pred it) list))
(defalias '-select '-filter) (defalias '-select '-filter)
@ -509,7 +499,6 @@ Alias: `-reject'.
This function's anaphoric counterpart is `--remove'. This function's anaphoric counterpart is `--remove'.
For similar operations, see also `-keep' and `-filter'." For similar operations, see also `-keep' and `-filter'."
(declare (important-return-value t))
(--remove (funcall pred it) list)) (--remove (funcall pred it) list))
(defalias '-reject '-remove) (defalias '-reject '-remove)
@ -545,7 +534,6 @@ Alias: `-reject-first'.
This function's anaphoric counterpart is `--remove-first'. This function's anaphoric counterpart is `--remove-first'.
See also `-map-first', `-remove-item', and `-remove-last'." See also `-map-first', `-remove-item', and `-remove-last'."
(declare (important-return-value t))
(--remove-first (funcall pred it) list)) (--remove-first (funcall pred it) list))
;; TODO: #'-quoting the macro upsets Emacs 24. ;; TODO: #'-quoting the macro upsets Emacs 24.
@ -571,7 +559,6 @@ Alias: `-reject-last'.
This function's anaphoric counterpart is `--remove-last'. This function's anaphoric counterpart is `--remove-last'.
See also `-map-last', `-remove-item', and `-remove-first'." See also `-map-last', `-remove-item', and `-remove-first'."
(declare (important-return-value t))
(--remove-last (funcall pred it) list)) (--remove-last (funcall pred it) list))
(defalias '-reject-last '-remove-last) (defalias '-reject-last '-remove-last)
@ -602,12 +589,11 @@ Like `-filter', but returns the non-nil results of FN instead of
the corresponding elements of LIST. the corresponding elements of LIST.
Its anaphoric counterpart is `--keep'." Its anaphoric counterpart is `--keep'."
(declare (important-return-value t))
(--keep (funcall fn it) list)) (--keep (funcall fn it) list))
(defun -non-nil (list) (defun -non-nil (list)
"Return a copy of LIST with all nil items removed." "Return a copy of LIST with all nil items removed."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(--filter it list)) (--filter it list))
(defmacro --map-indexed (form list) (defmacro --map-indexed (form list)
@ -632,7 +618,6 @@ current element within LIST, and the element itself.
This function's anaphoric counterpart is `--map-indexed'. This function's anaphoric counterpart is `--map-indexed'.
For a side-effecting variant, see also `-each-indexed'." For a side-effecting variant, see also `-each-indexed'."
(declare (important-return-value t))
(--map-indexed (funcall fn it-index it) list)) (--map-indexed (funcall fn it-index it) list))
(defmacro --map-when (pred rep list) (defmacro --map-when (pred rep list)
@ -651,7 +636,6 @@ are unchanged, and the rest are mapped through the REP function.
Alias: `-replace-where' Alias: `-replace-where'
See also: `-update-at'" See also: `-update-at'"
(declare (important-return-value t))
(--map-when (funcall pred it) (funcall rep it) list)) (--map-when (funcall pred it) (funcall rep it) list))
(defalias '-replace-where '-map-when) (defalias '-replace-where '-map-when)
@ -663,7 +647,6 @@ 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. non-nil is replaced with the result of calling REP on that item.
See also: `-map-when', `-replace-first'" See also: `-map-when', `-replace-first'"
(declare (important-return-value t))
(let (front) (let (front)
(while (and list (not (funcall pred (car list)))) (while (and list (not (funcall pred (car list))))
(push (car list) front) (push (car list) front)
@ -685,7 +668,6 @@ 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. non-nil is replaced with the result of calling REP on that item.
See also: `-map-when', `-replace-last'" See also: `-map-when', `-replace-last'"
(declare (important-return-value t))
(nreverse (-map-first pred rep (reverse list)))) (nreverse (-map-first pred rep (reverse list))))
(defmacro --map-last (pred rep list) (defmacro --map-last (pred rep list)
@ -730,7 +712,6 @@ See also: `-map-last'"
(defun -mapcat (fn list) (defun -mapcat (fn list)
"Return the concatenation of the result of mapping FN over LIST. "Return the concatenation of the result of mapping FN over LIST.
Thus function FN should return a list." Thus function FN should return a list."
(declare (important-return-value t))
(--mapcat (funcall fn it) list)) (--mapcat (funcall fn it) list))
(defmacro --iterate (form init n) (defmacro --iterate (form init n)
@ -754,7 +735,6 @@ This means a list of the form:
(INIT (FUN INIT) (FUN (FUN INIT)) ...) (INIT (FUN INIT) (FUN (FUN INIT)) ...)
N is the length of the returned list." N is the length of the returned list."
(declare (important-return-value t))
(--iterate (funcall fun it) init n)) (--iterate (funcall fun it) init n))
(defun -flatten (l) (defun -flatten (l)
@ -836,14 +816,12 @@ marked positions (for example with keywords).
This function's anaphoric counterpart is `--splice'. This function's anaphoric counterpart is `--splice'.
See also: `-splice-list', `-insert-at'." See also: `-splice-list', `-insert-at'."
(declare (important-return-value t))
(--splice (funcall pred it) (funcall fun it) list)) (--splice (funcall pred it) (funcall fun it) list))
(defun -splice-list (pred new-list list) (defun -splice-list (pred new-list list)
"Splice NEW-LIST in place of elements matching PRED in LIST. "Splice NEW-LIST in place of elements matching PRED in LIST.
See also: `-splice', `-insert-at'" See also: `-splice', `-insert-at'"
(declare (important-return-value t))
(-splice pred (lambda (_) new-list) list)) (-splice pred (lambda (_) new-list) list))
(defmacro --splice-list (pred new-list list) (defmacro --splice-list (pred new-list list)
@ -856,7 +834,7 @@ See also: `-splice', `-insert-at'"
The last 2 elements of ARGS are used as the final cons of the 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 result, so if the final element of ARGS is not a list, the result
is a dotted list. With no ARGS, return nil." is a dotted list. With no ARGS, return nil."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(let* ((len (length args)) (let* ((len (length args))
(tail (nthcdr (- len 2) args)) (tail (nthcdr (- len 2) args))
(last (cdr tail))) (last (cdr tail)))
@ -871,7 +849,6 @@ is a dotted list. With no ARGS, return nil."
This is like `cons', but operates on the end of list. This is like `cons', but operates on the end of list.
If any ELEMENTS are given, append them to the list as well." If any ELEMENTS are given, append them to the list as well."
(declare (side-effect-free t))
(-concat list (list elem) elements)) (-concat list (list elem) elements))
(defmacro --first (form list) (defmacro --first (form list)
@ -897,7 +874,6 @@ use `-first-item'.
Alias: `-find'. Alias: `-find'.
This function's anaphoric counterpart is `--first'." This function's anaphoric counterpart is `--first'."
(declare (important-return-value t))
(--first (funcall pred it) list)) (--first (funcall pred it) list))
(defalias '-find #'-first) (defalias '-find #'-first)
@ -921,7 +897,6 @@ This is the anaphoric counterpart to `-some'."
Alias: `-any'. Alias: `-any'.
This function's anaphoric counterpart is `--some'." This function's anaphoric counterpart is `--some'."
(declare (important-return-value t))
(--some (funcall pred it) list)) (--some (funcall pred it) list))
(defalias '-any '-some) (defalias '-any '-some)
@ -955,7 +930,6 @@ This function is like `-every-p', but on success returns the last
non-nil result of PRED instead of just t. non-nil result of PRED instead of just t.
This function's anaphoric counterpart is `--every'." This function's anaphoric counterpart is `--every'."
(declare (important-return-value t))
(--every (funcall pred it) list)) (--every (funcall pred it) list))
(defmacro --last (form list) (defmacro --last (form list)
@ -969,7 +943,6 @@ This function's anaphoric counterpart is `--every'."
(defun -last (pred list) (defun -last (pred list)
"Return the last x in LIST where (PRED x) is non-nil, else nil." "Return the last x in LIST where (PRED x) is non-nil, else nil."
(declare (important-return-value t))
(--last (funcall pred it) list)) (--last (funcall pred it) list))
(defalias '-first-item #'car (defalias '-first-item #'car
@ -1060,7 +1033,6 @@ See also: `-first-item', etc."
(defun -count (pred list) (defun -count (pred list)
"Counts the number of items in LIST where (PRED item) is non-nil." "Counts the number of items in LIST where (PRED item) is non-nil."
(declare (important-return-value t))
(--count (funcall pred it) list)) (--count (funcall pred it) list))
(defun ---truthy? (obj) (defun ---truthy? (obj)
@ -1077,7 +1049,6 @@ See also: `-first-item', etc."
"Return t if (PRED X) is non-nil for any X in LIST, else nil. "Return t if (PRED X) is non-nil for any X in LIST, else nil.
Alias: `-any-p', `-some?', `-some-p'" Alias: `-any-p', `-some?', `-some-p'"
(declare (important-return-value t))
(--any? (funcall pred it) list)) (--any? (funcall pred it) list))
(defalias '-some? '-any?) (defalias '-some? '-any?)
@ -1116,7 +1087,6 @@ success.
Alias: `-all-p', `-every-p', `-every?'. Alias: `-all-p', `-every-p', `-every?'.
This function's anaphoric counterpart is `--all?'." This function's anaphoric counterpart is `--all?'."
(declare (important-return-value t))
(--all? (funcall pred it) list)) (--all? (funcall pred it) list))
(defalias '-every? '-all?) (defalias '-every? '-all?)
@ -1135,7 +1105,6 @@ This function's anaphoric counterpart is `--all?'."
"Return t if (PRED X) is nil for all X in LIST, else nil. "Return t if (PRED X) is nil for all X in LIST, else nil.
Alias: `-none-p'" Alias: `-none-p'"
(declare (important-return-value t))
(--none? (funcall pred it) list)) (--none? (funcall pred it) list))
(defalias '-none-p '-none?) (defalias '-none-p '-none?)
@ -1158,7 +1127,6 @@ non-nil for at least one other item in LIST. Return nil if all
items satisfy the predicate or none of them do. items satisfy the predicate or none of them do.
Alias: `-only-some-p'" Alias: `-only-some-p'"
(declare (important-return-value t))
(--only-some? (funcall pred it) list)) (--only-some? (funcall pred it) list))
(defalias '-only-some-p '-only-some?) (defalias '-only-some-p '-only-some?)
@ -1172,7 +1140,7 @@ modulo the length of the list.
If STEP is a number, only each STEPth item in the resulting If STEP is a number, only each STEPth item in the resulting
section is returned. Defaults to 1." section is returned. Defaults to 1."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(let ((length (length list)) (let ((length (length list))
(new-list nil)) (new-list nil))
;; to defaults to the end of the list ;; to defaults to the end of the list
@ -1213,7 +1181,6 @@ non-nil.
This function's anaphoric counterpart is `--take-while'. This function's anaphoric counterpart is `--take-while'.
For another variant, see also `-drop-while'." For another variant, see also `-drop-while'."
(declare (important-return-value t))
(--take-while (funcall pred it) list)) (--take-while (funcall pred it) list))
(defmacro --drop-while (form list) (defmacro --drop-while (form list)
@ -1238,7 +1205,6 @@ nil.
This function's anaphoric counterpart is `--drop-while'. This function's anaphoric counterpart is `--drop-while'.
For another variant, see also `-take-while'." For another variant, see also `-take-while'."
(declare (important-return-value t))
(--drop-while (funcall pred it) list)) (--drop-while (funcall pred it) list))
(defun -take (n list) (defun -take (n list)
@ -1247,7 +1213,7 @@ Return a copy of LIST if it contains N items or fewer.
Return nil if N is zero or less. Return nil if N is zero or less.
See also: `-take-last'." See also: `-take-last'."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(--take-while (< it-index n) list)) (--take-while (< it-index n) list))
(defun -take-last (n list) (defun -take-last (n list)
@ -1256,7 +1222,7 @@ Return a copy of LIST if it contains N items or fewer.
Return nil if N is zero or less. Return nil if N is zero or less.
See also: `-take'." See also: `-take'."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(copy-sequence (last list n))) (copy-sequence (last list n)))
(defalias '-drop #'nthcdr (defalias '-drop #'nthcdr
@ -1273,7 +1239,7 @@ Return a copy of LIST if N is zero or less.
Return nil if LIST contains N items or fewer. Return nil if LIST contains N items or fewer.
See also: `-drop'." See also: `-drop'."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(nbutlast (copy-sequence list) n)) (nbutlast (copy-sequence list) n))
(defun -split-at (n list) (defun -split-at (n list)
@ -1283,7 +1249,7 @@ 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 remaining elements of LIST (not a copy). TAKE and DROP are like
the results of `-take' and `-drop', respectively, but the split the results of `-take' and `-drop', respectively, but the split
is done in a single list traversal." is done in a single list traversal."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(let (result) (let (result)
(--each-while list (< it-index n) (--each-while list (< it-index n)
(push (pop list) result)) (push (pop list) result))
@ -1322,7 +1288,6 @@ Return a copy of LIST where the Nth element is replaced with the
result of calling FUNC on it. result of calling FUNC on it.
See also: `-map-when'" See also: `-map-when'"
(declare (important-return-value t))
(let ((split-list (-split-at n list))) (let ((split-list (-split-at n list)))
(nconc (car split-list) (nconc (car split-list)
(cons (funcall func (car (cadr split-list))) (cons (funcall func (car (cadr split-list)))
@ -1396,7 +1361,6 @@ that do not. The result is like performing
((-take-while PRED LIST) (-drop-while PRED LIST)) ((-take-while PRED LIST) (-drop-while PRED LIST))
but in no more than a single pass through LIST." but in no more than a single pass through LIST."
(declare (important-return-value t))
(--split-with (funcall pred it) list)) (--split-with (funcall pred it) list))
(defmacro -split-on (item list) (defmacro -split-on (item list)
@ -1424,7 +1388,6 @@ the results. Empty lists are also removed from the result.
This function can be thought of as a generalization of This function can be thought of as a generalization of
`split-string'." `split-string'."
(declare (important-return-value t))
(let (r s) (let (r s)
(while list (while list
(if (not (funcall fn (car list))) (if (not (funcall fn (car list)))
@ -1451,7 +1414,6 @@ The result is like performing
((-filter PRED LIST) (-remove PRED LIST)) ((-filter PRED LIST) (-remove PRED LIST))
but in a single pass through LIST." but in a single pass through LIST."
(declare (important-return-value t))
(--separate (funcall pred it) list)) (--separate (funcall pred it) list))
(defun dash--partition-all-in-steps-reversed (n step list) (defun dash--partition-all-in-steps-reversed (n step list)
@ -1524,7 +1486,6 @@ those items are discarded."
(defun -partition-by (fn list) (defun -partition-by (fn list)
"Apply FN to each item in LIST, splitting it each time FN returns a new value." "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)) (--partition-by (funcall fn it) list))
(defmacro --partition-by-header (form list) (defmacro --partition-by-header (form list)
@ -1563,7 +1524,6 @@ those items are discarded."
value. Apply FN to each item in LIST, splitting it each time FN value. Apply FN to each item in LIST, splitting it each time FN
returns the header value, but only after seeing at least one returns the header value, but only after seeing at least one
other value (the body)." other value (the body)."
(declare (important-return-value t))
(--partition-by-header (funcall fn it) list)) (--partition-by-header (funcall fn it) list))
(defmacro --partition-after-pred (form list) (defmacro --partition-after-pred (form list)
@ -1590,24 +1550,20 @@ This is the anaphoric counterpart to `-partition-after-pred'."
"Partition LIST after each element for which PRED returns non-nil. "Partition LIST after each element for which PRED returns non-nil.
This function's anaphoric counterpart is `--partition-after-pred'." This function's anaphoric counterpart is `--partition-after-pred'."
(declare (important-return-value t))
(--partition-after-pred (funcall pred it) list)) (--partition-after-pred (funcall pred it) list))
(defun -partition-before-pred (pred list) (defun -partition-before-pred (pred list)
"Partition directly before each time PRED is true on an element of LIST." "Partition directly before each time PRED is true on an element of LIST."
(declare (important-return-value t))
(nreverse (-map #'reverse (nreverse (-map #'reverse
(-partition-after-pred pred (reverse list))))) (-partition-after-pred pred (reverse list)))))
(defun -partition-after-item (item list) (defun -partition-after-item (item list)
"Partition directly after each time ITEM appears in 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)) (-partition-after-pred (lambda (ele) (equal ele item))
list)) list))
(defun -partition-before-item (item list) (defun -partition-before-item (item list)
"Partition directly before each time ITEM appears in 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)) (-partition-before-pred (lambda (ele) (equal ele item))
list)) list))
@ -1636,12 +1592,11 @@ This function's anaphoric counterpart is `--partition-after-pred'."
(defun -group-by (fn list) (defun -group-by (fn list)
"Separate LIST into an alist whose keys are FN applied to the "Separate LIST into an alist whose keys are FN applied to the
elements of LIST. Keys are compared by `equal'." elements of LIST. Keys are compared by `equal'."
(declare (important-return-value t))
(--group-by (funcall fn it) list)) (--group-by (funcall fn it) list))
(defun -interpose (sep list) (defun -interpose (sep list)
"Return a new list of all elements in LIST separated by SEP." "Return a new list of all elements in LIST separated by SEP."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(let (result) (let (result)
(when list (when list
(!cons (car list) result) (!cons (car list) result)
@ -1653,7 +1608,7 @@ elements of LIST. Keys are compared by `equal'."
(defun -interleave (&rest lists) (defun -interleave (&rest lists)
"Return a new list of the first item in each list, then the second etc." "Return a new list of the first item in each list, then the second etc."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(when lists (when lists
(let (result) (let (result)
(while (-none? 'null lists) (while (-none? 'null lists)
@ -1692,7 +1647,6 @@ shorter list.
This function's anaphoric counterpart is `--zip-with'. This function's anaphoric counterpart is `--zip-with'.
For other zips, see also `-zip-lists' and `-zip-fill'." For other zips, see also `-zip-lists' and `-zip-fill'."
(declare (important-return-value t))
(--zip-with (funcall fn it other) list1 list2)) (--zip-with (funcall fn it other) list1 list2))
(defun -zip-lists (&rest lists) (defun -zip-lists (&rest lists)
@ -1890,7 +1844,6 @@ corresponding element of LIST, and RESULT is the value obtained
by calling FN on ITEM. by calling FN on ITEM.
This function's anaphoric counterpart is `--annotate'." This function's anaphoric counterpart is `--annotate'."
(declare (important-return-value t))
(--annotate (funcall fn it) list)) (--annotate (funcall fn it) list))
(defun dash--table-carry (lists restore-lists &optional re) (defun dash--table-carry (lists restore-lists &optional re)
@ -1919,7 +1872,6 @@ combinations created by taking one element from each list in
order. The dimension of the result is (length lists). order. The dimension of the result is (length lists).
See also: `-table-flat'" See also: `-table-flat'"
(declare (important-return-value t))
(let ((restore-lists (copy-sequence lists)) (let ((restore-lists (copy-sequence lists))
(last-list (last lists)) (last-list (last lists))
(re (make-list (length lists) nil))) (re (make-list (length lists) nil)))
@ -1946,7 +1898,6 @@ of the result. This is equivalent to calling:
but the implementation here is much more efficient. but the implementation here is much more efficient.
See also: `-flatten-n', `-table'" See also: `-flatten-n', `-table'"
(declare (important-return-value t))
(let ((restore-lists (copy-sequence lists)) (let ((restore-lists (copy-sequence lists))
(last-list (last lists)) (last-list (last lists))
re) re)
@ -1976,7 +1927,6 @@ it returns non-nil, at which point the search terminates.
This function's anaphoric counterpart is `--find-index'. This function's anaphoric counterpart is `--find-index'.
See also: `-first', `-find-last-index'." See also: `-first', `-find-last-index'."
(declare (important-return-value t))
(--find-index (funcall pred it) list)) (--find-index (funcall pred it) list))
(defun -elem-index (elem list) (defun -elem-index (elem list)
@ -2007,7 +1957,6 @@ the same order as they appear in LIST.
This function's anaphoric counterpart is `--find-indices'. This function's anaphoric counterpart is `--find-indices'.
See also: `-find-index', `-elem-indices'." See also: `-find-index', `-elem-indices'."
(declare (important-return-value t))
(--find-indices (funcall pred it) list)) (--find-indices (funcall pred it) list))
(defun -elem-indices (elem list) (defun -elem-indices (elem list)
@ -2040,7 +1989,6 @@ current list element.
This function's anaphoric counterpart is `--find-last-index'. This function's anaphoric counterpart is `--find-last-index'.
See also: `-last', `-find-index'." See also: `-last', `-find-index'."
(declare (important-return-value t))
(--find-last-index (funcall pred it) list)) (--find-last-index (funcall pred it) list))
(defun -select-by-indices (indices list) (defun -select-by-indices (indices list)
@ -2186,7 +2134,6 @@ Note: `it' need not be used in each form."
"Grade elements of LIST using COMPARATOR relation. "Grade elements of LIST using COMPARATOR relation.
This yields a permutation vector such that applying this This yields a permutation vector such that applying this
permutation to LIST sorts it in ascending order." permutation to LIST sorts it in ascending order."
(declare (important-return-value t))
(->> (--map-indexed (cons it it-index) list) (->> (--map-indexed (cons it it-index) list)
(-sort (lambda (it other) (funcall comparator (car it) (car other)))) (-sort (lambda (it other) (funcall comparator (car it) (car other))))
(mapcar #'cdr))) (mapcar #'cdr)))
@ -2195,7 +2142,6 @@ permutation to LIST sorts it in ascending order."
"Grade elements of LIST using COMPARATOR relation. "Grade elements of LIST using COMPARATOR relation.
This yields a permutation vector such that applying this This yields a permutation vector such that applying this
permutation to LIST sorts it in descending order." permutation to LIST sorts it in descending order."
(declare (important-return-value t))
(->> (--map-indexed (cons it it-index) list) (->> (--map-indexed (cons it it-index) list)
(-sort (lambda (it other) (funcall comparator (car other) (car it)))) (-sort (lambda (it other) (funcall comparator (car other) (car it))))
(mapcar #'cdr))) (mapcar #'cdr)))
@ -2919,7 +2865,7 @@ Return nil if `-compare-fn' is not a known test function."
(declare (side-effect-free error-free)) (declare (side-effect-free error-free))
;; In theory this could also recognize values that are custom ;; In theory this could also recognize values that are custom
;; `hash-table-test's, but too often the :test name is different ;; `hash-table-test's, but too often the :test name is different
;; from the equality function, so it doesn't seem worthwhile. ;; from the equality function, so it doesn't seem worthwile.
(car (memq (or -compare-fn #'equal) '(equal eq eql)))) (car (memq (or -compare-fn #'equal) '(equal eq eql))))
(defvar dash--short-list-length 32 (defvar dash--short-list-length 32
@ -2935,7 +2881,6 @@ The test for equality is done with `equal', or with `-compare-fn'
if that is non-nil. if that is non-nil.
Alias: `-uniq'." Alias: `-uniq'."
(declare (important-return-value t))
(let (test len) (let (test len)
(cond ((null list) ()) (cond ((null list) ())
;; Use a hash table if `-compare-fn' is a known hash table ;; Use a hash table if `-compare-fn' is a known hash table
@ -2965,7 +2910,6 @@ even in the presence of bignum support."
The test for equality is done with `equal', or with `-compare-fn' The test for equality is done with `equal', or with `-compare-fn'
if that is non-nil." if that is non-nil."
(declare (important-return-value t))
(let ((lists (list list1 list2)) test len union) (let ((lists (list list1 list2)) test len union)
(cond ((null (or list1 list2))) (cond ((null (or list1 list2)))
;; Use a hash table if `-compare-fn' is a known hash table ;; Use a hash table if `-compare-fn' is a known hash table
@ -2988,7 +2932,6 @@ if that is non-nil."
The test for equality is done with `equal', or with `-compare-fn' The test for equality is done with `equal', or with `-compare-fn'
if that is non-nil." if that is non-nil."
(declare (important-return-value t))
(let (test len) (let (test len)
(cond ((null (and list1 list2)) ()) (cond ((null (and list1 list2)) ())
;; Use a hash table if `-compare-fn' is a known hash table ;; Use a hash table if `-compare-fn' is a known hash table
@ -3010,7 +2953,6 @@ if that is non-nil."
The test for equality is done with `equal', or with `-compare-fn' The test for equality is done with `equal', or with `-compare-fn'
if that is non-nil." if that is non-nil."
(declare (important-return-value t))
(let (test len1 len2) (let (test len1 len2)
(cond ((null list1) ()) (cond ((null list1) ())
((null list2) (-distinct list1)) ((null list2) (-distinct list1))
@ -3036,7 +2978,6 @@ if that is non-nil."
(defun -powerset (list) (defun -powerset (list)
"Return the power set of LIST." "Return the power set of LIST."
(declare (pure t) (side-effect-free t))
(if (null list) (list ()) (if (null list) (list ())
(let ((last (-powerset (cdr list)))) (let ((last (-powerset (cdr list))))
(nconc (mapcar (lambda (x) (cons (car list) x)) last) (nconc (mapcar (lambda (x) (cons (car list) x)) last)
@ -3052,7 +2993,6 @@ The test for equality is done with `equal', or with `-compare-fn'
if that is non-nil. if that is non-nil.
See also `-count' and `-group-by'." See also `-count' and `-group-by'."
(declare (important-return-value t))
(let (test len freqs) (let (test len freqs)
(cond ((null list)) (cond ((null list))
((and (setq test (dash--hash-test-fn)) ((and (setq test (dash--hash-test-fn))
@ -3172,7 +3112,6 @@ in LIST, as returned by `-frequencies'."
Duplicate elements of LIST are determined by `equal', or by Duplicate elements of LIST are determined by `equal', or by
`-compare-fn' if that is non-nil." `-compare-fn' if that is non-nil."
(declare (important-return-value t))
(cond ((null list) (list ())) (cond ((null list) (list ()))
;; Optimization: a traversal of `list' is faster than the ;; Optimization: a traversal of `list' is faster than the
;; round trip via `dash--uniq-perms' or `dash--multi-perms'. ;; round trip via `dash--uniq-perms' or `dash--multi-perms'.
@ -3186,7 +3125,6 @@ Duplicate elements of LIST are determined by `equal', or by
(defun -inits (list) (defun -inits (list)
"Return all prefixes of LIST." "Return all prefixes of LIST."
(declare (pure t) (side-effect-free t))
(let ((res (list list))) (let ((res (list list)))
(setq list (reverse list)) (setq list (reverse list))
(while list (while list
@ -3194,9 +3132,8 @@ Duplicate elements of LIST are determined by `equal', or by
res)) res))
(defun -tails (list) (defun -tails (list)
"Return all suffixes of LIST." "Return all suffixes of LIST"
(declare (pure t) (side-effect-free t)) (-reductions-r-from 'cons nil list))
(-reductions-r-from #'cons nil list))
(defun -common-prefix (&rest lists) (defun -common-prefix (&rest lists)
"Return the longest common prefix of LISTS." "Return the longest common prefix of LISTS."
@ -3206,7 +3143,6 @@ Duplicate elements of LIST are determined by `equal', or by
(defun -common-suffix (&rest lists) (defun -common-suffix (&rest lists)
"Return the longest common suffix of LISTS." "Return the longest common suffix of LISTS."
(declare (pure t) (side-effect-free t))
(nreverse (apply #'-common-prefix (mapcar #'reverse lists)))) (nreverse (apply #'-common-prefix (mapcar #'reverse lists))))
(defun -contains? (list element) (defun -contains? (list element)
@ -3217,7 +3153,6 @@ if that is non-nil. As with `member', the return value is
actually the tail of LIST whose car is ELEMENT. actually the tail of LIST whose car is ELEMENT.
Alias: `-contains-p'." Alias: `-contains-p'."
(declare (important-return-value t))
(funcall (dash--member-fn) element list)) (funcall (dash--member-fn) element list))
(defalias '-contains-p #'-contains?) (defalias '-contains-p #'-contains?)
@ -3231,7 +3166,6 @@ elements. The test for equality is done with `equal', or with
`-compare-fn' if that is non-nil. `-compare-fn' if that is non-nil.
Alias: `-same-items-p'." Alias: `-same-items-p'."
(declare (important-return-value t))
(let (test len1 len2) (let (test len1 len2)
(cond ((null (or list1 list2))) (cond ((null (or list1 list2)))
((null (and list1 list2)) nil) ((null (and list1 list2)) nil)
@ -3297,7 +3231,6 @@ Alias: `-is-infix-p'"
Return the sorted list. LIST is NOT modified by side effects. Return the sorted list. LIST is NOT modified by side effects.
COMPARATOR is called with two elements of LIST, and should return non-nil COMPARATOR is called with two elements of LIST, and should return non-nil
if the first element should sort before the second." if the first element should sort before the second."
(declare (important-return-value t))
(sort (copy-sequence list) comparator)) (sort (copy-sequence list) comparator))
(defmacro --sort (form list) (defmacro --sort (form list)
@ -3321,7 +3254,7 @@ backward compatibility and is otherwise deprecated."
(defun -repeat (n x) (defun -repeat (n x)
"Return a new list of length N with each element being X. "Return a new list of length N with each element being X.
Return nil if N is less than 1." Return nil if N is less than 1."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(and (>= n 0) (make-list n x))) (and (>= n 0) (make-list n x)))
(defun -sum (list) (defun -sum (list)
@ -3364,7 +3297,6 @@ the greatest element of the list by the comparison function.
See also combinator `-on' which can transform the values before See also combinator `-on' which can transform the values before
comparing them." comparing them."
(declare (important-return-value t))
(--reduce (if (funcall comparator it acc) it acc) list)) (--reduce (if (funcall comparator it acc) it acc) list))
(defun -min-by (comparator list) (defun -min-by (comparator list)
@ -3373,7 +3305,6 @@ the least element of the list by the comparison function.
See also combinator `-on' which can transform the values before See also combinator `-on' which can transform the values before
comparing them." comparing them."
(declare (important-return-value t))
(--reduce (if (funcall comparator it acc) acc it) list)) (--reduce (if (funcall comparator it acc) acc it) list))
(defmacro --max-by (form list) (defmacro --max-by (form list)
@ -3396,7 +3327,7 @@ Starts from START and adds STEP each time. The default START is
zero, the default STEP is 1. zero, the default STEP is 1.
This function takes its name from the corresponding primitive in This function takes its name from the corresponding primitive in
the APL language." the APL language."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(unless (natnump count) (unless (natnump count)
(signal 'wrong-type-argument (list #'natnump count))) (signal 'wrong-type-argument (list #'natnump count)))
(or start (setq start 0)) (or start (setq start 0))
@ -3409,7 +3340,6 @@ the APL language."
"Compute the (least) fixpoint of FN with initial input LIST. "Compute the (least) fixpoint of FN with initial input LIST.
FN is called at least once, results are compared with `equal'." FN is called at least once, results are compared with `equal'."
(declare (important-return-value t))
(let ((re (funcall fn list))) (let ((re (funcall fn list)))
(while (not (equal list re)) (while (not (equal list re))
(setq list re) (setq list re)
@ -3431,7 +3361,6 @@ seed value and builds a (potentially infinite!) list.
FUN should return nil to stop the generating process, or a 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 cons (A . B), where A will be prepended to the result and B is
the new seed." the new seed."
(declare (important-return-value t))
(let ((last (funcall fun seed)) r) (let ((last (funcall fun seed)) r)
(while last (while last
(push (car last) r) (push (car last) r)
@ -3478,7 +3407,6 @@ INIT-VALUE. See `-reduce-r-from'.
This is the same as calling `-tree-reduce-from' after `-tree-map' This is the same as calling `-tree-reduce-from' after `-tree-map'
but is twice as fast as it only traverse the structure once." but is twice as fast as it only traverse the structure once."
(declare (important-return-value t))
(cond (cond
((null tree) ()) ((null tree) ())
((-cons-pair? tree) (funcall fn tree)) ((-cons-pair? tree) (funcall fn tree))
@ -3506,7 +3434,6 @@ INIT-VALUE. See `-reduce-r-from'.
This is the same as calling `-tree-reduce' after `-tree-map' This is the same as calling `-tree-reduce' after `-tree-map'
but is twice as fast as it only traverse the structure once." but is twice as fast as it only traverse the structure once."
(declare (important-return-value t))
(cond (cond
((null tree) ()) ((null tree) ())
((-cons-pair? tree) (funcall fn tree)) ((-cons-pair? tree) (funcall fn tree))
@ -3523,7 +3450,6 @@ but is twice as fast as it only traverse the structure once."
(defun -tree-map (fn tree) (defun -tree-map (fn tree)
"Apply FN to each element of TREE while preserving the tree structure." "Apply FN to each element of TREE while preserving the tree structure."
(declare (important-return-value t))
(cond (cond
((null tree) ()) ((null tree) ())
((-cons-pair? tree) (funcall fn tree)) ((-cons-pair? tree) (funcall fn tree))
@ -3545,7 +3471,6 @@ then on this result and second element from the list etc.
The initial value is ignored on cons pairs as they always contain The initial value is ignored on cons pairs as they always contain
two elements." two elements."
(declare (important-return-value t))
(cond (cond
((null tree) ()) ((null tree) ())
((-cons-pair? tree) tree) ((-cons-pair? tree) tree)
@ -3569,7 +3494,6 @@ FN is first applied to first element of the list and second
element, then on this result and third element from the list etc. 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." See `-reduce-r' for how exactly are lists of zero or one element handled."
(declare (important-return-value t))
(cond (cond
((null tree) ()) ((null tree) ())
((-cons-pair? tree) tree) ((-cons-pair? tree) tree)
@ -3610,7 +3534,6 @@ CHILDREN is a function of one argument that returns the children
of the passed branch node. of the passed branch node.
Non-branch nodes are simply copied." Non-branch nodes are simply copied."
(declare (important-return-value t))
(cons tree (cons tree
(and (funcall branch tree) (and (funcall branch tree)
(-mapcat (lambda (x) (-tree-seq branch children x)) (-mapcat (lambda (x) (-tree-seq branch children x))
@ -3628,7 +3551,7 @@ Non-branch nodes are simply copied."
The new list has the same elements and structure but all cons are 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 replaced with new ones. This is useful when you need to clone a
structure such as plist or alist." structure such as plist or alist."
(declare (side-effect-free t)) (declare (pure t) (side-effect-free t))
(-tree-map #'identity list)) (-tree-map #'identity list))
;;; Combinators ;;; Combinators
@ -3818,7 +3741,6 @@ In types: (a -> a) -> Int -> a -> a.
This function satisfies the following law: This function satisfies the following law:
(funcall (-iteratefn fn n) init) = (-last-item (-iterate fn init (1+ n)))." (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)) (lambda (x) (--dotimes n (setq x (funcall fn x))) x))
(defun -counter (&optional beg end inc) (defun -counter (&optional beg end inc)
@ -3830,7 +3752,6 @@ defaults to 0, INC defaults to 1, and if END is nil, the counter
will increment indefinitely. will increment indefinitely.
The closure accepts any number of arguments, which are discarded." The closure accepts any number of arguments, which are discarded."
(declare (pure t) (side-effect-free error-free))
(let ((inc (or inc 1)) (let ((inc (or inc 1))
(n (or beg 0))) (n (or beg 0)))
(lambda (&rest _) (lambda (&rest _)
@ -3868,7 +3789,6 @@ iteration halted before converging, a cons with car `halted' and
cdr the final output from HALT-TEST. cdr the final output from HALT-TEST.
In types: (a -> a) -> a -> a." In types: (a -> a) -> a -> a."
(declare (important-return-value t))
(let ((eqfn (or equal-test 'equal)) (let ((eqfn (or equal-test 'equal))
(haltfn (or halt-test (haltfn (or halt-test
(-not (-not

View file

@ -1037,7 +1037,7 @@ Functions reducing lists to a single value (which may also be a list).
⇒ (nil (1)) ⇒ (nil (1))
-- Function: -tails (list) -- Function: -tails (list)
Return all suffixes of LIST. Return all suffixes of LIST
(-tails '(1 2 3 4)) (-tails '(1 2 3 4))
⇒ ((1 2 3 4) (2 3 4) (3 4) (4) nil) ⇒ ((1 2 3 4) (2 3 4) (3 4) (4) nil)
@ -2222,9 +2222,9 @@ Other list functions not fit to be classified elsewhere.
called with two elements of LIST, and should return non-nil if called with two elements of LIST, and should return non-nil if
the first element should sort before the second. the first element should sort before the second.
(-sort #'< '(3 1 2)) (-sort '< '(3 1 2))
⇒ (1 2 3) ⇒ (1 2 3)
(-sort #'> '(3 1 2)) (-sort '> '(3 1 2))
⇒ (3 2 1) ⇒ (3 2 1)
(--sort (< it other) '(3 1 2)) (--sort (< it other) '(3 1 2))
⇒ (1 2 3) ⇒ (1 2 3)
@ -2384,8 +2384,8 @@ Functions pretending lists are trees.
structure but all cons are replaced with new ones. This is useful structure but all cons are replaced with new ones. This is useful
when you need to clone a structure such as plist or alist. when you need to clone a structure such as plist or alist.
(let* ((a (list (list 1))) (b (-clone a))) (setcar (car a) 2) b) (let* ((a '(1 2 3)) (b (-clone a))) (nreverse a) b)
⇒ ((1)) ⇒ (1 2 3)
 
File: dash.info, Node: Threading macros, Next: Binding, Prev: Tree operations, Up: Functions File: dash.info, Node: Threading macros, Next: Binding, Prev: Tree operations, Up: Functions
@ -4792,153 +4792,153 @@ Ref: -product35429
Ref: -running-product35637 Ref: -running-product35637
Ref: -inits35978 Ref: -inits35978
Ref: -tails36223 Ref: -tails36223
Ref: -common-prefix36468 Ref: -common-prefix36467
Ref: -common-suffix36762 Ref: -common-suffix36761
Ref: -min37056 Ref: -min37055
Ref: -min-by37282 Ref: -min-by37281
Ref: -max37803 Ref: -max37802
Ref: -max-by38028 Ref: -max-by38027
Ref: -frequencies38554 Ref: -frequencies38553
Node: Unfolding39169 Node: Unfolding39168
Ref: -iterate39410 Ref: -iterate39409
Ref: -unfold39857 Ref: -unfold39856
Ref: -repeat40662 Ref: -repeat40661
Ref: -cycle40946 Ref: -cycle40945
Node: Predicates41343 Node: Predicates41342
Ref: -some41520 Ref: -some41519
Ref: -every41949 Ref: -every41948
Ref: -any?42663 Ref: -any?42662
Ref: -all?43012 Ref: -all?43011
Ref: -none?43754 Ref: -none?43753
Ref: -only-some?44074 Ref: -only-some?44073
Ref: -contains?44619 Ref: -contains?44618
Ref: -is-prefix?45125 Ref: -is-prefix?45124
Ref: -is-suffix?45457 Ref: -is-suffix?45456
Ref: -is-infix?45789 Ref: -is-infix?45788
Ref: -cons-pair?46149 Ref: -cons-pair?46148
Node: Partitioning46480 Node: Partitioning46479
Ref: -split-at46668 Ref: -split-at46667
Ref: -split-with47332 Ref: -split-with47331
Ref: -split-on47972 Ref: -split-on47971
Ref: -split-when48643 Ref: -split-when48642
Ref: -separate49286 Ref: -separate49285
Ref: -partition49820 Ref: -partition49819
Ref: -partition-all50269 Ref: -partition-all50268
Ref: -partition-in-steps50694 Ref: -partition-in-steps50693
Ref: -partition-all-in-steps51240 Ref: -partition-all-in-steps51239
Ref: -partition-by51754 Ref: -partition-by51753
Ref: -partition-by-header52132 Ref: -partition-by-header52131
Ref: -partition-after-pred52733 Ref: -partition-after-pred52732
Ref: -partition-before-pred53186 Ref: -partition-before-pred53185
Ref: -partition-before-item53571 Ref: -partition-before-item53570
Ref: -partition-after-item53878 Ref: -partition-after-item53877
Ref: -group-by54180 Ref: -group-by54179
Node: Indexing54613 Node: Indexing54612
Ref: -elem-index54815 Ref: -elem-index54814
Ref: -elem-indices55302 Ref: -elem-indices55301
Ref: -find-index55761 Ref: -find-index55760
Ref: -find-last-index56430 Ref: -find-last-index56429
Ref: -find-indices57081 Ref: -find-indices57080
Ref: -grade-up57843 Ref: -grade-up57842
Ref: -grade-down58250 Ref: -grade-down58249
Node: Set operations58664 Node: Set operations58663
Ref: -union58847 Ref: -union58846
Ref: -difference59277 Ref: -difference59276
Ref: -intersection59705 Ref: -intersection59704
Ref: -powerset60134 Ref: -powerset60133
Ref: -permutations60411 Ref: -permutations60410
Ref: -distinct60849 Ref: -distinct60848
Ref: -same-items?61243 Ref: -same-items?61242
Node: Other list operations61852 Node: Other list operations61851
Ref: -rotate62077 Ref: -rotate62076
Ref: -cons*62430 Ref: -cons*62429
Ref: -snoc62852 Ref: -snoc62851
Ref: -interpose63264 Ref: -interpose63263
Ref: -interleave63558 Ref: -interleave63557
Ref: -iota63924 Ref: -iota63923
Ref: -zip-with64407 Ref: -zip-with64406
Ref: -zip-pair65215 Ref: -zip-pair65214
Ref: -zip-lists65781 Ref: -zip-lists65780
Ref: -zip-lists-fill66579 Ref: -zip-lists-fill66578
Ref: -zip67289 Ref: -zip67288
Ref: -zip-fill68316 Ref: -zip-fill68315
Ref: -unzip-lists69230 Ref: -unzip-lists69229
Ref: -unzip69853 Ref: -unzip69852
Ref: -pad70846 Ref: -pad70845
Ref: -table71331 Ref: -table71330
Ref: -table-flat72117 Ref: -table-flat72116
Ref: -first73122 Ref: -first73121
Ref: -last73655 Ref: -last73654
Ref: -first-item74001 Ref: -first-item74000
Ref: -second-item74413 Ref: -second-item74412
Ref: -third-item74830 Ref: -third-item74829
Ref: -fourth-item75205 Ref: -fourth-item75204
Ref: -fifth-item75583 Ref: -fifth-item75582
Ref: -last-item75958 Ref: -last-item75957
Ref: -butlast76319 Ref: -butlast76318
Ref: -sort76564 Ref: -sort76563
Ref: -list77058 Ref: -list77055
Ref: -fix77627 Ref: -fix77624
Node: Tree operations78116 Node: Tree operations78113
Ref: -tree-seq78312 Ref: -tree-seq78309
Ref: -tree-map79173 Ref: -tree-map79170
Ref: -tree-map-nodes79613 Ref: -tree-map-nodes79610
Ref: -tree-reduce80477 Ref: -tree-reduce80474
Ref: -tree-reduce-from81359 Ref: -tree-reduce-from81356
Ref: -tree-mapreduce81959 Ref: -tree-mapreduce81956
Ref: -tree-mapreduce-from82818 Ref: -tree-mapreduce-from82815
Ref: -clone84103 Ref: -clone84100
Node: Threading macros84441 Node: Threading macros84427
Ref: ->84666 Ref: ->84652
Ref: ->>85154 Ref: ->>85140
Ref: -->85657 Ref: -->85643
Ref: -as->86213 Ref: -as->86199
Ref: -some->86667 Ref: -some->86653
Ref: -some->>87052 Ref: -some->>87038
Ref: -some-->87499 Ref: -some-->87485
Ref: -doto88066 Ref: -doto88052
Node: Binding88619 Node: Binding88605
Ref: -when-let88826 Ref: -when-let88812
Ref: -when-let*89287 Ref: -when-let*89273
Ref: -if-let89816 Ref: -if-let89802
Ref: -if-let*90182 Ref: -if-let*90168
Ref: -let90805 Ref: -let90791
Ref: -let*96895 Ref: -let*96881
Ref: -lambda97832 Ref: -lambda97818
Ref: -setq98638 Ref: -setq98624
Node: Side effects99439 Node: Side effects99425
Ref: -each99633 Ref: -each99619
Ref: -each-while100160 Ref: -each-while100146
Ref: -each-indexed100780 Ref: -each-indexed100766
Ref: -each-r101372 Ref: -each-r101358
Ref: -each-r-while101814 Ref: -each-r-while101800
Ref: -dotimes102458 Ref: -dotimes102444
Node: Destructive operations103011 Node: Destructive operations102997
Ref: !cons103229 Ref: !cons103215
Ref: !cdr103433 Ref: !cdr103419
Node: Function combinators103626 Node: Function combinators103612
Ref: -partial103830 Ref: -partial103816
Ref: -rpartial104348 Ref: -rpartial104334
Ref: -juxt104996 Ref: -juxt104982
Ref: -compose105448 Ref: -compose105434
Ref: -applify106055 Ref: -applify106041
Ref: -on106485 Ref: -on106471
Ref: -flip107257 Ref: -flip107243
Ref: -rotate-args107781 Ref: -rotate-args107767
Ref: -const108410 Ref: -const108396
Ref: -cut108752 Ref: -cut108738
Ref: -not109232 Ref: -not109218
Ref: -orfn109776 Ref: -orfn109762
Ref: -andfn110569 Ref: -andfn110555
Ref: -iteratefn111356 Ref: -iteratefn111342
Ref: -fixfn112058 Ref: -fixfn112044
Ref: -prodfn113632 Ref: -prodfn113618
Node: Development114783 Node: Development114769
Node: Contribute115072 Node: Contribute115058
Node: Contributors116084 Node: Contributors116070
Node: FDL118177 Node: FDL118163
Node: GPL143497 Node: GPL143483
Node: Index181246 Node: Index181232
 
End Tag Table End Tag Table

View file

@ -0,0 +1,18 @@
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.

File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* Dash: (dash.info). A modern list library for GNU Emacs.

View file

Before

Width:  |  Height:  |  Size: 43 KiB

After

Width:  |  Height:  |  Size: 43 KiB

View file

Before

Width:  |  Height:  |  Size: 32 KiB

After

Width:  |  Height:  |  Size: 32 KiB

View file

@ -1,9 +1,7 @@
(define-package "dashboard" "20230726.2018" "A startup screen extracted from Spacemacs" (define-package "dashboard" "20230220.1916" "A startup screen extracted from Spacemacs"
'((emacs "26.1")) '((emacs "26.1"))
:commit "6480e0797b41c8ce1de4f37ba8016d177c22ab04" :authors :commit "221ee4b77db77199380c519c4ba52c06abc725e9" :authors
'(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com")) '(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com"))
:maintainers
'(("Jesús Martínez" . "jesusmartinez93@gmail.com"))
:maintainer :maintainer
'("Jesús Martínez" . "jesusmartinez93@gmail.com") '("Jesús Martínez" . "jesusmartinez93@gmail.com")
:keywords :keywords

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,469 @@
;;; dashboard.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*-
;; Copyright (c) 2016-2023 emacs-dashboard maintainers
;;
;; Author : Rakan Al-Hneiti <rakan.alhneiti@gmail.com>
;; Maintainer : Jesús Martínez <jesusmartinez93@gmail.com>
;; Shen, Jen-Chieh <jcs090218@gmail.com>
;; URL : https://github.com/emacs-dashboard/emacs-dashboard
;;
;; This file is not part of GNU Emacs.
;;
;;; License: GPLv3
;;
;; Created: October 05, 2016
;; Package-Version: 1.8.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1"))
;;; Commentary:
;; An extensible Emacs dashboard, with sections for
;; bookmarks, projects (projectile or project.el), org-agenda and more.
;;; Code:
(require 'ffap)
(require 'recentf)
(require 'dashboard-widgets)
(declare-function bookmark-get-filename "ext:bookmark.el")
(declare-function bookmark-all-names "ext:bookmark.el")
(declare-function dashboard-ls--dirs "ext:dashboard-ls.el")
(declare-function dashboard-ls--files "ext:dashboard-ls.el")
(declare-function page-break-lines-mode "ext:page-break-lines.el")
(declare-function projectile-remove-known-project "ext:projectile.el")
(declare-function project-forget-projects-under "ext:project.el")
(defgroup dashboard nil
"Extensible startup screen."
:group 'applications)
;; Custom splash screen
(defvar dashboard-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-p") 'dashboard-previous-line)
(define-key map (kbd "C-n") 'dashboard-next-line)
(define-key map (kbd "<up>") 'dashboard-previous-line)
(define-key map (kbd "<down>") 'dashboard-next-line)
(define-key map (kbd "k") 'dashboard-previous-line)
(define-key map (kbd "j") 'dashboard-next-line)
(define-key map [tab] 'widget-forward)
(define-key map (kbd "C-i") 'widget-forward)
(define-key map [backtab] 'widget-backward)
(define-key map (kbd "RET") 'dashboard-return)
(define-key map [mouse-1] 'dashboard-mouse-1)
(define-key map (kbd "}") #'dashboard-next-section)
(define-key map (kbd "{") #'dashboard-previous-section)
(define-key map (kbd "<backspace>") #'dashboard-remove-item-under)
(define-key map (kbd "<delete>") #'dashboard-remove-item-under)
(define-key map (kbd "DEL") #'dashboard-remove-item-under)
(define-key map (kbd "1") #'dashboard-section-1)
(define-key map (kbd "2") #'dashboard-section-2)
(define-key map (kbd "3") #'dashboard-section-3)
(define-key map (kbd "4") #'dashboard-section-4)
(define-key map (kbd "5") #'dashboard-section-5)
(define-key map (kbd "6") #'dashboard-section-6)
(define-key map (kbd "7") #'dashboard-section-7)
(define-key map (kbd "8") #'dashboard-section-8)
(define-key map (kbd "9") #'dashboard-section-9)
map)
"Keymap for dashboard mode.")
(defcustom dashboard-after-initialize-hook nil
"Hook that is run after dashboard buffer is initialized."
:group 'dashboard
:type 'hook)
(define-derived-mode dashboard-mode special-mode "Dashboard"
"Dashboard major mode for startup screen."
:group 'dashboard
:syntax-table nil
:abbrev-table nil
(buffer-disable-undo)
(when (featurep 'whitespace) (whitespace-mode -1))
(when (featurep 'linum) (linum-mode -1))
(when (featurep 'display-line-numbers) (display-line-numbers-mode -1))
(when (featurep 'page-break-lines) (page-break-lines-mode 1))
(setq-local revert-buffer-function #'dashboard-refresh-buffer)
(setq inhibit-startup-screen t
buffer-read-only t
truncate-lines t))
(defcustom dashboard-center-content nil
"Whether to center content within the window."
:type 'boolean
:group 'dashboard)
(defconst dashboard-buffer-name "*dashboard*"
"Dashboard's buffer name.")
(defvar dashboard-force-refresh nil
"If non-nil, force refresh dashboard buffer.")
(defvar dashboard--section-starts nil
"List of section starting positions.")
;;
;; Util
;;
(defun dashboard--goto-line (line)
"Goto LINE."
(goto-char (point-min)) (forward-line (1- line)))
(defmacro dashboard--save-excursion (&rest body)
"Execute BODY save window point."
(declare (indent 0) (debug t))
`(let ((line (line-number-at-pos nil t))
(column (current-column)))
,@body
(dashboard--goto-line line)
(move-to-column column)))
;;
;; Core
;;
(defun dashboard--current-section ()
"Return section symbol in dashboard."
(save-excursion
(if (and (search-backward dashboard-page-separator nil t)
(search-forward dashboard-page-separator nil t))
(let ((ln (thing-at-point 'line)))
(cond ((string-match-p "Recent Files:" ln) 'recents)
((string-match-p "Bookmarks:" ln) 'bookmarks)
((string-match-p "Projects:" ln) 'projects)
((string-match-p "Agenda for " ln) 'agenda)
((string-match-p "Registers:" ln) 'registers)
((string-match-p "List Directories:" ln) 'ls-directories)
((string-match-p "List Files:" ln) 'ls-files)
(t (user-error "Unknown section from dashboard"))))
(user-error "Failed searching dashboard section"))))
;;
;; Navigation
;;
(defun dashboard-previous-section ()
"Navigate back to previous section."
(interactive)
(let ((current-position (point)) current-section-start previous-section-start)
(dolist (elt dashboard--section-starts)
(when (and current-section-start (not previous-section-start))
(setq previous-section-start elt))
(when (and (not current-section-start) (< elt current-position))
(setq current-section-start elt)))
(goto-char (if (eq current-position current-section-start)
previous-section-start
current-section-start))))
(defun dashboard-next-section ()
"Navigate forward to next section."
(interactive)
(let ((current-position (point)) next-section-start
(section-starts (reverse dashboard--section-starts)))
(dolist (elt section-starts)
(when (and (not next-section-start)
(> elt current-position))
(setq next-section-start elt)))
(when next-section-start
(goto-char next-section-start))))
(defun dashboard--section-lines ()
"Return a list of integer represent the starting line number of each section."
(let (pb-lst)
(save-excursion
(goto-char (point-min))
(while (search-forward dashboard-page-separator nil t)
(when (ignore-errors (dashboard--current-section))
(push (line-number-at-pos) pb-lst))))
(setq pb-lst (reverse pb-lst))
pb-lst))
(defun dashboard--goto-section-by-index (index)
"Navigate to item section by INDEX."
(let* ((pg-lst (dashboard--section-lines))
(items-id (1- index))
(items-pg (nth items-id pg-lst))
(items-len (length pg-lst)))
(when (and items-pg (< items-id items-len))
(dashboard--goto-line items-pg))))
(defun dashboard-section-1 ()
"Navigate to section 1." (interactive) (dashboard--goto-section-by-index 1))
(defun dashboard-section-2 ()
"Navigate to section 2." (interactive) (dashboard--goto-section-by-index 2))
(defun dashboard-section-3 ()
"Navigate to section 3." (interactive) (dashboard--goto-section-by-index 3))
(defun dashboard-section-4 ()
"Navigate to section 4." (interactive) (dashboard--goto-section-by-index 4))
(defun dashboard-section-5 ()
"Navigate to section 5." (interactive) (dashboard--goto-section-by-index 5))
(defun dashboard-section-6 ()
"Navigate to section 6." (interactive) (dashboard--goto-section-by-index 6))
(defun dashboard-section-7 ()
"Navigate to section 7." (interactive) (dashboard--goto-section-by-index 7))
(defun dashboard-section-8 ()
"Navigate to section 8." (interactive) (dashboard--goto-section-by-index 8))
(defun dashboard-section-9 ()
"Navigate to section 9." (interactive) (dashboard--goto-section-by-index 9))
(defun dashboard-previous-line (arg)
"Move point up and position it at that lines item.
Optional prefix ARG says how many lines to move; default is one line."
(interactive "^p")
(dashboard-next-line (- arg)))
(defun dashboard-next-line (arg)
"Move point down and position it at that lines item.
Optional prefix ARG says how many lines to move; default is one line."
;; code heavily inspired by `dired-next-line'
(interactive "^p")
(let (line-move-visual goal-column)
(line-move arg t))
;; We never want to move point into an invisible line. Dashboard doesnt
;; use invisible text currently but when it does were ready!
(while (and (invisible-p (point))
(not (if (and arg (< arg 0)) (bobp) (eobp))))
(forward-char (if (and arg (< arg 0)) -1 1)))
(beginning-of-line-text))
;;
;; ffap
;;
(defun dashboard--goto-section (section)
"Move to SECTION declares in variable `dashboard-item-shortcuts'."
(let ((fnc (intern (format "dashboard-jump-to-%s" section))))
(dashboard-funcall-fboundp fnc)))
(defun dashboard--current-index (section &optional pos)
"Return the idex by SECTION from POS."
(let (target-ln section-line)
(save-excursion
(when pos (goto-char pos))
(setq target-ln (line-number-at-pos))
(dashboard--goto-section section)
(setq section-line (line-number-at-pos)))
(- target-ln section-line)))
(defun dashboard--section-list (section)
"Return the list from SECTION."
(cl-case section
(`recents recentf-list)
(`bookmarks (bookmark-all-names))
(`projects (dashboard-projects-backend-load-projects))
(`ls-directories (dashboard-ls--dirs))
(`ls-files (dashboard-ls--files))
(t (user-error "Unknown section for search: %s" section))))
(defun dashboard--current-item-in-path ()
"Return the path from current dashboard section in path."
(let ((section (dashboard--current-section)) path)
(cl-case section
(`bookmarks (setq path (bookmark-get-filename path)))
(t
(let ((lst (dashboard--section-list section))
(index (dashboard--current-index section)))
(setq path (nth index lst)))))
path))
(defun dashboard--on-path-item-p ()
"Return non-nil if current point is on the item path from dashboard."
(save-excursion
(when (= (point) (line-end-position)) (ignore-errors (forward-char -1)))
(eq (get-char-property (point) 'face) 'dashboard-items-face)))
(defun dashboard--ffap-guesser--adv (fnc &rest args)
"Advice execution around function `ffap-guesser'.
Argument FNC is the adviced function.
Optional argument ARGS adviced function arguments."
(cl-case major-mode
(`dashboard-mode
(or (and (dashboard--on-path-item-p)
(dashboard--current-item-in-path))
(apply fnc args))) ; fallback
(t (apply fnc args))))
(advice-add 'ffap-guesser :around #'dashboard--ffap-guesser--adv)
;;
;; Removal
;;
(defun dashboard-remove-item-under ()
"Remove a item from the current item section."
(interactive)
(cl-case (dashboard--current-section)
(`recents (dashboard-remove-item-recentf))
(`bookmarks (dashboard-remove-item-bookmarks))
(`projects (dashboard-remove-item-projects))
(`agenda (dashboard-remove-item-agenda))
(`registers (dashboard-remove-item-registers)))
(dashboard--save-excursion (dashboard-refresh-buffer)))
(defun dashboard-remove-item-recentf ()
"Remove a file from `recentf-list'."
(interactive)
(let ((path (save-excursion (end-of-line) (ffap-guesser))))
(setq recentf-list (delete path recentf-list)))
(dashboard-mute-apply (recentf-save-list)))
(defun dashboard-remove-item-projects ()
"Remove a path from `project--list'."
(interactive)
(let ((path (save-excursion (end-of-line) (ffap-guesser))))
(dashboard-mute-apply
(cl-case dashboard-projects-backend
(`projectile (projectile-remove-known-project path))
(`project-el (project-forget-projects-under path))))))
(defun dashboard-remove-item-bookmarks ()
"Remove a bookmarks from `bookmark-alist'."
(interactive)) ; TODO: ..
(defun dashboard-remove-item-agenda ()
"Remove an agenda from `org-agenda-files'."
(interactive "P")
(let ((agenda-file (get-text-property (point) 'dashboard-agenda-file))
(agenda-loc (get-text-property (point) 'dashboard-agenda-loc)))
(with-current-buffer (find-file-noselect agenda-file)
(goto-char agenda-loc)
(call-interactively 'org-todo))))
(defun dashboard-remove-item-registers ()
"Remove a registers from `register-alist'."
(interactive)) ; TODO: ..
;;
;; Confirmation
;;
(defun dashboard-return ()
"Hit return key in dashboard buffer."
(interactive)
(let ((start-ln (line-number-at-pos)) (fd-cnt 0) diff-line entry-pt)
(save-excursion
(while (and (not diff-line)
(not (= (point) (point-min)))
(not (get-char-property (point) 'button))
(not (= (point) (point-max))))
(forward-char 1)
(setq fd-cnt (1+ fd-cnt))
(unless (= start-ln (line-number-at-pos))
(setq diff-line t)))
(unless (= (point) (point-max))
(setq entry-pt (point))))
(when (= fd-cnt 1)
(setq entry-pt (1- (point))))
(if entry-pt
(widget-button-press entry-pt)
(call-interactively #'widget-button-press))))
(defun dashboard-mouse-1 ()
"Key for keymap `mouse-1'."
(interactive)
(let ((old-track-mouse track-mouse))
(when (call-interactively #'widget-button-click)
(setq track-mouse old-track-mouse))))
;;
;; Insertion
;;
(defmacro dashboard--with-buffer (&rest body)
"Execute BODY in dashboard buffer."
(declare (indent 0))
`(with-current-buffer (get-buffer-create dashboard-buffer-name)
(let (buffer-read-only) ,@body)
(current-buffer)))
(defun dashboard-maximum-section-length ()
"For the just-inserted section, calculate the length of the longest line."
(let ((max-line-length 0))
(save-excursion
(dashboard-previous-section)
(while (not (eobp))
(setq max-line-length
(max max-line-length
(- (line-end-position) (line-beginning-position))))
(forward-line 1)))
max-line-length))
(defun dashboard-insert-startupify-lists ()
"Insert the list of widgets into the buffer."
(interactive)
(let ((inhibit-redisplay t)
(recentf-is-on (recentf-enabled-p))
(origial-recentf-list recentf-list)
(dashboard-num-recents (or (cdr (assoc 'recents dashboard-items)) 0))
(max-line-length 0))
(when recentf-is-on
(setq recentf-list (dashboard-subseq recentf-list dashboard-num-recents)))
(dashboard--with-buffer
(when (or dashboard-force-refresh (not (eq major-mode 'dashboard-mode)))
(erase-buffer)
(dashboard-insert-banner)
(insert "\n")
(setq dashboard--section-starts nil)
(mapc (lambda (els)
(let* ((el (or (car-safe els) els))
(list-size
(or (cdr-safe els)
dashboard-items-default-length))
(item-generator
(cdr-safe (assoc el dashboard-item-generators))))
(push (point) dashboard--section-starts)
(funcall item-generator list-size)
(goto-char (point-max))
;; add a newline so the next section-name doesn't get include
;; on the same line.
(insert "\n")
(when recentf-is-on
(setq recentf-list origial-recentf-list))
(setq max-line-length
(max max-line-length (dashboard-maximum-section-length)))))
dashboard-items)
(when dashboard-center-content
(dashboard-center-text
(if dashboard--section-starts
(car (last dashboard--section-starts))
(point))
(point-max)))
(save-excursion
(dolist (start dashboard--section-starts)
(goto-char start)
(delete-char -1) ; delete the newline we added previously
(insert dashboard-page-separator)))
(progn
(delete-char -1)
(insert dashboard-page-separator))
(dashboard-insert-footer)
(goto-char (point-min))
(dashboard-mode)))
(when recentf-is-on
(setq recentf-list origial-recentf-list))))
;;;###autoload
(defun dashboard-open (&rest _)
"Open (or refresh) the *dashboard* buffer."
(interactive)
(let ((dashboard-force-refresh t)) (dashboard-insert-startupify-lists))
(switch-to-buffer dashboard-buffer-name))
(defalias #'dashboard-refresh-buffer #'dashboard-open)
;;;###autoload
(defun dashboard-setup-startup-hook ()
"Setup post initialization hooks.
If a command line argument is provided, assume a filename and skip displaying
Dashboard."
(when (< (length command-line-args) 2)
(add-hook 'after-init-hook (lambda ()
;; Display useful lists of items
(dashboard-insert-startupify-lists)))
(add-hook 'emacs-startup-hook (lambda ()
(switch-to-buffer dashboard-buffer-name)
(goto-char (point-min))
(redisplay)
(run-hooks 'dashboard-after-initialize-hook)))))
(provide 'dashboard)
;;; dashboard.el ends here

View file

@ -0,0 +1,8 @@
######## ## ## ### ###### ######
## ### ### ## ## ## ## ## ##
## #### #### ## ## ## ##
###### ## ### ## ## ## ## ######
## ## ## ######### ## ##
## ## ## ## ## ## ## ## ##
######## ## ## ## ## ###### ######

View file

@ -0,0 +1,6 @@
_______ .___ ___. ___ ______ _______.
| ____|| \/ | / \ / | / |
| |__ | \ / | / ^ \ | ,----' | (----`
| __| | |\/| | / /_\ \ | | \ \
| |____ | | | | / _____ \ | `----.----) |
|_______||__| |__| /__/ \__\ \______|_______/

View file

@ -0,0 +1,8 @@
_______ _____ ______ ________ ________ ________
|\ ___ \ |\ _ \ _ \|\ __ \|\ ____\|\ ____\
\ \ __/|\ \ \\\__\ \ \ \ \|\ \ \ \___|\ \ \___|_
\ \ \_|/_\ \ \\|__| \ \ \ __ \ \ \ \ \_____ \
\ \ \_|\ \ \ \ \ \ \ \ \ \ \ \ \____\|____|\ \
\ \_______\ \__\ \ \__\ \__\ \__\ \_______\____\_\ \
\|_______|\|__| \|__|\|__|\|__|\|_______|\_________\
\|_________|

View file

@ -0,0 +1,17 @@
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
_ ___ _
_ _ __ _
___ __ _
__ _
_ _ _
_ _ _
_ _ _
__ ___
_ _ _ _
_ _
_ _
_ _
_
__

Binary file not shown.

After

Width:  |  Height:  |  Size: 43 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 32 KiB

View file

@ -0,0 +1,44 @@
;;; dashboard-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "dashboard" "dashboard.el" (0 0 0 0))
;;; Generated autoloads from dashboard.el
(autoload 'dashboard-open "dashboard" "\
Open (or refresh) the *dashboard* buffer.
\(fn &rest _)" t nil)
(autoload 'dashboard-setup-startup-hook "dashboard" "\
Setup post initialization hooks.
If a command line argument is provided, assume a filename and skip displaying
Dashboard." nil nil)
(register-definition-prefixes "dashboard" '("dashboard-"))
;;;***
;;;### (autoloads nil "dashboard-widgets" "dashboard-widgets.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from dashboard-widgets.el
(register-definition-prefixes "dashboard-widgets" '("dashboard-" "org-time-less-p" "recentf-list"))
;;;***
;;;### (autoloads nil nil ("dashboard-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; dashboard-autoloads.el ends here

View file

@ -0,0 +1,12 @@
(define-package "dashboard" "20230331.2304" "A startup screen extracted from Spacemacs"
'((emacs "26.1"))
:commit "0f970d298931f9de7b511086728af140bf44a642" :authors
'(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com"))
:maintainer
'("Jesús Martínez" . "jesusmartinez93@gmail.com")
:keywords
'("startup" "screen" "tools" "dashboard")
:url "https://github.com/emacs-dashboard/emacs-dashboard")
;; Local Variables:
;; no-byte-compile: t
;; End:

View file

@ -12,7 +12,7 @@
;;; License: GPLv3 ;;; License: GPLv3
;; ;;
;; Created: October 05, 2016 ;; Created: October 05, 2016
;; Package-Version: 1.9.0-SNAPSHOT ;; Package-Version: 1.8.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard ;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1")) ;; Package-Requires: ((emacs "26.1"))
;;; Commentary: ;;; Commentary:
@ -31,11 +31,6 @@
(declare-function all-the-icons-icon-for-file "ext:all-the-icons.el") (declare-function all-the-icons-icon-for-file "ext:all-the-icons.el")
(declare-function all-the-icons-fileicon "ext:data-fileicons.el") (declare-function all-the-icons-fileicon "ext:data-fileicons.el")
(declare-function all-the-icons-octicon "ext:data-octicons.el") (declare-function all-the-icons-octicon "ext:data-octicons.el")
(declare-function nerd-icons-icon-for-dir "ext:nerd-icons.el")
(declare-function nerd-icons-icon-for-file "ext:nerd-icons.el")
(declare-function nerd-icons-sucicon "ext:nerd-icons.el")
(declare-function nerd-icons-octicon "ext:nerd-icons.el")
(declare-function nerd-icons-codicon "ext:nerd-icons.el")
(declare-function bookmark-get-filename "ext:bookmark.el") (declare-function bookmark-get-filename "ext:bookmark.el")
(declare-function bookmark-all-names "ext:bookmark.el") (declare-function bookmark-all-names "ext:bookmark.el")
(declare-function calendar-date-compare "ext:calendar.el") (declare-function calendar-date-compare "ext:calendar.el")
@ -141,70 +136,6 @@ preserved."
:type 'list :type 'list
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-icon-type (and (or dashboard-set-heading-icons
dashboard-set-file-icons)
(or (require 'nerd-icons nil t)
(require 'all-the-icons nil t)))
"Icon type used for dashboard.
The value can be one of: `all-the-icons', `nerd-icons'."
:type 'symbol
:group 'dashboard
:set
(lambda (k v)
(pcase v
('all-the-icons
(unless (require 'all-the-icons nil t)
(setq v nil)))
('nerd-icons
(unless (require 'nerd-icons nil t)
(setq v nil))))
(set k v)))
(defcustom dashboard-heading-icons
(pcase dashboard-icon-type
('all-the-icons '((recents . "history")
(bookmarks . "bookmark")
(agenda . "calendar")
(projects . "rocket")
(registers . "database")))
('nerd-icons '((recents . "nf-oct-history")
(bookmarks . "nf-oct-bookmark")
(agenda . "nf-oct-calendar")
(projects . "nf-oct-rocket")
(registers . "nf-oct-database"))))
"Association list for the icons of the heading sections.
Will be of the form `(list-type . icon-name-string)`.
If nil it is disabled. Possible values for list-type are:
`recents' `bookmarks' `projects' `agenda' `registers'"
:type '(repeat (alist :key-type symbol :value-type string))
:group 'dashboard)
(defcustom dashboard-heading-icon-height 1.2
"The height of the heading icon."
:type 'float
:group 'dashboard)
(defcustom dashboard-heading-icon-v-adjust 0.0
"The v-adjust of the heading icon."
:type 'float
:group 'dashboard)
(defcustom dashboard-agenda-item-icon
(pcase dashboard-icon-type
('all-the-icons (all-the-icons-octicon "primitive-dot" :height 1.0 :v-adjust 0.01))
('nerd-icons (nerd-icons-octicon "nf-oct-dot_fill" :height 1.0 :v-adjust 0.01)))
"Agenda item icon."
:type 'string
:group 'dashboard)
(defcustom dashboard-remote-path-icon
(pcase dashboard-icon-type
('all-the-icons (all-the-icons-octicon "radio-tower" :height 1.0 :v-adjust 0.01))
('nerd-icons (nerd-icons-codicon "nf-cod-radio_tower" :height 1.0 :v-adjust 0.01)))
"Remote path icon."
:type 'string
:group 'dashboard)
(defcustom dashboard-show-shortcuts t (defcustom dashboard-show-shortcuts t
"Whether to show shortcut keys for each section." "Whether to show shortcut keys for each section."
:type 'boolean :type 'boolean
@ -276,66 +207,20 @@ predicate value."
(boolean :tag "Predicate value")) (boolean :tag "Predicate value"))
:group 'dashboard) :group 'dashboard)
(defun dashboard-replace-displayable (str &optional rep)
"Replace non-displayable character from STR.
Optional argument REP is the replacement string of non-displayable character."
(if (stringp str)
(let ((rep (or rep ""))
(results (list)))
(dolist (string (split-string str ""))
(let* ((char (string-to-char string))
(string (if (char-displayable-p char)
string
rep)))
(push string results)))
(string-join (reverse results)))
""))
(defun dashboard-display-icons-p () (defun dashboard-display-icons-p ()
"Assert whether to show icons based on the `dashboard-display-icons-p' variable." "Assert whether to show icons based on the `dashboard-display-icons-p' variable."
(if (functionp dashboard-display-icons-p) (if (functionp dashboard-display-icons-p)
(funcall dashboard-display-icons-p) (funcall dashboard-display-icons-p)
dashboard-display-icons-p)) dashboard-display-icons-p))
(defun dashboard-icon-for-dir (dir &rest args)
"Get the formatted icon for DIR.
ARGS should be a plist containing `:height', `:v-adjust',
or `:face' properties."
(dashboard-replace-displayable
(pcase dashboard-icon-type
('all-the-icons (apply #'all-the-icons-icon-for-dir dir args))
('nerd-icons (apply #'nerd-icons-icon-for-dir dir args)))))
(defun dashboard-icon-for-file (file &rest args)
"Get the formatted icon for FILE.
ARGS should be a plist containing `:height', `:v-adjust', or `:face' properties."
(dashboard-replace-displayable
(pcase dashboard-icon-type
('all-the-icons (apply #'all-the-icons-icon-for-file file args))
('nerd-icons (apply #'nerd-icons-icon-for-file file args)))))
(defun dashboard-octicon (name &rest args)
"Get the formatted octicon.
ARGS should be a plist containing `:height', `:v-adjust', or `:face' properties."
(dashboard-replace-displayable
(pcase dashboard-icon-type
('all-the-icons (apply #'all-the-icons-octicon name args))
('nerd-icons (apply #'nerd-icons-octicon name args)))))
(defcustom dashboard-footer-icon (defcustom dashboard-footer-icon
(if (dashboard-display-icons-p) (if (and (dashboard-display-icons-p)
(pcase dashboard-icon-type (or (fboundp 'all-the-icons-fileicon)
('all-the-icons (require 'all-the-icons nil 'noerror)))
(all-the-icons-fileicon "emacs" (all-the-icons-fileicon "emacs"
:height 1.1 :height 1.1
:v-adjust -0.05 :v-adjust -0.05
:face 'font-lock-keyword-face)) :face 'font-lock-keyword-face)
('nerd-icons
(nerd-icons-sucicon "nf-custom-emacs"
:height 1.1
:v-adjust -0.05
:face 'font-lock-keyword-face)))
(propertize ">" 'face 'dashboard-footer)) (propertize ">" 'face 'dashboard-footer))
"Footer's icon." "Footer's icon."
:type 'string :type 'string
@ -424,6 +309,19 @@ Set to nil for unbounded."
:type 'integer :type 'integer
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-heading-icons
'((recents . "history")
(bookmarks . "bookmark")
(agenda . "calendar")
(projects . "rocket")
(registers . "database"))
"Association list for the icons of the heading sections.
Will be of the form `(list-type . icon-name-string)`.
If nil it is disabled. Possible values for list-type are:
`recents' `bookmarks' `projects' `agenda' `registers'"
:type '(repeat (alist :key-type symbol :value-type string))
:group 'dashboard)
(defcustom dashboard-path-style nil (defcustom dashboard-path-style nil
"Style to display path." "Style to display path."
:type '(choice :type '(choice
@ -580,29 +478,31 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(defun dashboard-insert-heading (heading &optional shortcut icon) (defun dashboard-insert-heading (heading &optional shortcut icon)
"Insert a widget HEADING in dashboard buffer, adding SHORTCUT, ICON if provided." "Insert a widget HEADING in dashboard buffer, adding SHORTCUT, ICON if provided."
(when (and (dashboard-display-icons-p) dashboard-set-heading-icons) (when (and (dashboard-display-icons-p) dashboard-set-heading-icons)
(let ((args `( :height ,dashboard-heading-icon-height ;; Try loading `all-the-icons'
:v-adjust ,dashboard-heading-icon-v-adjust (unless (or (fboundp 'all-the-icons-octicon)
:face dashboard-heading))) (require 'all-the-icons nil 'noerror))
(insert (error "Package `all-the-icons' isn't installed"))
(pcase heading
("Recent Files:" (insert (cond
(apply #'dashboard-octicon (cdr (assoc 'recents dashboard-heading-icons)) args)) ((string-equal heading "Recent Files:")
("Bookmarks:" (all-the-icons-octicon (cdr (assoc 'recents dashboard-heading-icons))
(apply #'dashboard-octicon (cdr (assoc 'bookmarks dashboard-heading-icons)) args)) :height 1.2 :v-adjust 0.0 :face 'dashboard-heading))
((or "Agenda for today:" ((string-equal heading "Bookmarks:")
"Agenda for the coming week:") (all-the-icons-octicon (cdr (assoc 'bookmarks dashboard-heading-icons))
(apply #'dashboard-octicon (cdr (assoc 'agenda dashboard-heading-icons)) args)) :height 1.2 :v-adjust 0.0 :face 'dashboard-heading))
("Registers:" ((or (string-equal heading "Agenda for today:")
(apply #'dashboard-octicon (cdr (assoc 'registers dashboard-heading-icons)) args)) (string-equal heading "Agenda for the coming week:"))
("Projects:" (all-the-icons-octicon (cdr (assoc 'agenda dashboard-heading-icons))
(apply #'dashboard-octicon (cdr (assoc 'projects dashboard-heading-icons)) args)) :height 1.2 :v-adjust 0.0 :face 'dashboard-heading))
("List Directories:" ((string-equal heading "Registers:")
(apply #'dashboard-octicon (cdr (assoc 'ls-directories dashboard-heading-icons)) args)) (all-the-icons-octicon (cdr (assoc 'registers dashboard-heading-icons))
("List Files:" :height 1.2 :v-adjust 0.0 :face 'dashboard-heading))
(apply #'dashboard-octicon (cdr (assoc 'ls-files dashboard-heading-icons)) args)) ((string-equal heading "Projects:")
(_ (all-the-icons-octicon (cdr (assoc 'projects dashboard-heading-icons))
(if (null icon) " " icon)))) :height 1.2 :v-adjust 0.0 :face 'dashboard-heading))
(insert " "))) ((not (null icon)) icon)
(t " ")))
(insert " "))
(insert (propertize heading 'face 'dashboard-heading)) (insert (propertize heading 'face 'dashboard-heading))
@ -849,18 +749,20 @@ to widget creation."
(insert "\n ") (insert "\n ")
(when (and (dashboard-display-icons-p) (when (and (dashboard-display-icons-p)
dashboard-set-file-icons) dashboard-set-file-icons
(or (fboundp 'all-the-icons-icon-for-dir)
(require 'all-the-icons nil 'noerror)))
(let* ((path (car (last (split-string ,@rest " - ")))) (let* ((path (car (last (split-string ,@rest " - "))))
(icon (if (and (not (file-remote-p path)) (icon (if (and (not (file-remote-p path))
(file-directory-p path)) (file-directory-p path))
(dashboard-icon-for-dir path nil "") (all-the-icons-icon-for-dir path nil "")
(cond (cond
((or (string-equal ,section-name "Agenda for today:") ((or (string-equal ,section-name "Agenda for today:")
(string-equal ,section-name "Agenda for the coming week:")) (string-equal ,section-name "Agenda for the coming week:"))
dashboard-agenda-item-icon) (all-the-icons-octicon "primitive-dot" :height 1.0 :v-adjust 0.01))
((file-remote-p path) ((file-remote-p path)
dashboard-remote-path-icon) (all-the-icons-octicon "radio-tower" :height 1.0 :v-adjust 0.01))
(t (dashboard-icon-for-file (file-name-nondirectory path) (t (all-the-icons-icon-for-file (file-name-nondirectory path)
:v-adjust -0.05)))))) :v-adjust -0.05))))))
(setq tag (concat icon " " ,@rest)))) (setq tag (concat icon " " ,@rest))))
@ -884,11 +786,8 @@ to widget creation."
(when-let ((footer (and dashboard-set-footer (dashboard-random-footer)))) (when-let ((footer (and dashboard-set-footer (dashboard-random-footer))))
(insert "\n") (insert "\n")
(dashboard-insert-center (dashboard-insert-center
(dashboard-replace-displayable dashboard-footer-icon) dashboard-footer-icon
(if (and (stringp dashboard-footer-icon)
(not (string-empty-p dashboard-footer-icon)))
" " " "
"")
(propertize footer 'face 'dashboard-footer) (propertize footer 'face 'dashboard-footer)
"\n"))) "\n")))

View file

@ -12,7 +12,7 @@
;;; License: GPLv3 ;;; License: GPLv3
;; ;;
;; Created: October 05, 2016 ;; Created: October 05, 2016
;; Package-Version: 1.9.0-SNAPSHOT ;; Package-Version: 1.8.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard ;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1")) ;; Package-Requires: ((emacs "26.1"))
;;; Commentary: ;;; Commentary:
@ -453,25 +453,12 @@ Optional argument ARGS adviced function arguments."
(defalias #'dashboard-refresh-buffer #'dashboard-open) (defalias #'dashboard-refresh-buffer #'dashboard-open)
(defun dashboard-resize-on-hook (&optional _)
"Re-render dashboard on window size change."
(let ((space-win (get-buffer-window dashboard-buffer-name))
(frame-win (frame-selected-window)))
(when (and space-win
(not (window-minibuffer-p frame-win)))
(with-selected-window space-win
(dashboard-insert-startupify-lists)))))
;;;###autoload ;;;###autoload
(defun dashboard-setup-startup-hook () (defun dashboard-setup-startup-hook ()
"Setup post initialization hooks. "Setup post initialization hooks.
If a command line argument is provided, assume a filename and skip displaying If a command line argument is provided, assume a filename and skip displaying
Dashboard." Dashboard."
(when (< (length command-line-args) 2) (when (< (length command-line-args) 2)
(add-hook 'window-setup-hook (lambda ()
;; 100 means `dashboard-resize-on-hook' will run last
(add-hook 'window-size-change-functions 'dashboard-resize-on-hook 100)
(dashboard-resize-on-hook)))
(add-hook 'after-init-hook (lambda () (add-hook 'after-init-hook (lambda ()
;; Display useful lists of items ;; Display useful lists of items
(dashboard-insert-startupify-lists))) (dashboard-insert-startupify-lists)))

View file

@ -59,10 +59,6 @@ When all of them are nil, all installed docs are used." t nil)
(register-definition-prefixes "devdocs-browser" '("devdocs-browser-")) (register-definition-prefixes "devdocs-browser" '("devdocs-browser-"))
;;;***
;;;### (autoloads nil nil ("devdocs-browser-pkg.el") (0 0 0 0))
;;;*** ;;;***
;; Local Variables: ;; Local Variables:

View file

@ -0,0 +1,2 @@
;;; Generated package description from devdocs-browser.el -*- no-byte-compile: t -*-
(define-package "devdocs-browser" "20230112.1554" "Browse devdocs.io documents using EWW" '((emacs "27.1")) :commit "c316c93306527fcb4069adde94402a48605d42d5" :authors '(("blahgeek" . "i@blahgeek.com")) :maintainer '("blahgeek" . "i@blahgeek.com") :keywords '("docs" "help" "tools") :url "https://github.com/blahgeek/emacs-devdocs-browser")

View file

@ -4,6 +4,8 @@
;; Author: blahgeek <i@blahgeek.com> ;; Author: blahgeek <i@blahgeek.com>
;; URL: https://github.com/blahgeek/emacs-devdocs-browser ;; URL: https://github.com/blahgeek/emacs-devdocs-browser
;; Package-Version: 20230112.1554
;; Package-Commit: c316c93306527fcb4069adde94402a48605d42d5
;; Version: 20210525 ;; Version: 20210525
;; Keywords: docs, help, tools ;; Keywords: docs, help, tools
;; Package-Requires: ((emacs "27.1")) ;; Package-Requires: ((emacs "27.1"))
@ -319,8 +321,6 @@ Can be used as `imenu-create-index-function'."
(h5 . devdocs-browser--eww-tag-h5)))) (h5 . devdocs-browser--eww-tag-h5))))
(setq-local imenu-create-index-function (setq-local imenu-create-index-function
#'devdocs-browser--imenu-create-index) #'devdocs-browser--imenu-create-index)
(when (boundp 'eww-auto-rename-buffer)
(setq-local eww-auto-rename-buffer nil))
(advice-add 'shr-expand-url :filter-return #'devdocs-browser--eww-fix-url) (advice-add 'shr-expand-url :filter-return #'devdocs-browser--eww-fix-url)
(advice-add 'eww-display-html :filter-return #'devdocs-browser--eww-recenter-advice) (advice-add 'eww-display-html :filter-return #'devdocs-browser--eww-recenter-advice)
(advice-add 'eww-browse-url :filter-args #'devdocs-browser--eww-browse-url-new-window-advice) (advice-add 'eww-browse-url :filter-args #'devdocs-browser--eww-browse-url-new-window-advice)

View file

@ -1,14 +0,0 @@
(define-package "devdocs-browser" "20230423.444" "Browse devdocs.io documents using EWW"
'((emacs "27.1"))
:commit "ef7686e4ff4ecab42e1b4a1a5d079bcf947a5b71" :authors
'(("blahgeek" . "i@blahgeek.com"))
:maintainers
'(("blahgeek" . "i@blahgeek.com"))
:maintainer
'("blahgeek" . "i@blahgeek.com")
:keywords
'("docs" "help" "tools")
:url "https://github.com/blahgeek/emacs-devdocs-browser")
;; Local Variables:
;; no-byte-compile: t
;; End:

File diff suppressed because it is too large Load diff

View file

@ -1,6 +1,6 @@
;;; doom-modeline-env.el --- A environment parser for doom-modeline -*- lexical-binding: t -*- ;;; doom-modeline-env.el --- A environment parser for doom-modeline -*- lexical-binding: t -*-
;; Copyright (C) 2019-2023 Vincent Zhang, Justin Barclay ;; Copyright (C) 2019-2020 Justin Barclay, Vincent Zhang
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.
@ -200,7 +200,7 @@ PARSER should be a function for parsing COMMAND's output line-by-line, to
;;;###autoload (autoload 'doom-modeline-env-setup-python "doom-modeline-env") ;;;###autoload (autoload 'doom-modeline-env-setup-python "doom-modeline-env")
(doom-modeline-def-env python (doom-modeline-def-env python
:hooks '(python-mode-hook python-ts-mode-hook) :hooks 'python-mode-hook
:command (lambda () (cond ((and (fboundp 'pipenv-project-p) :command (lambda () (cond ((and (fboundp 'pipenv-project-p)
(pipenv-project-p)) (pipenv-project-p))
(list "pipenv" "run" (list "pipenv" "run"
@ -220,7 +220,7 @@ PARSER should be a function for parsing COMMAND's output line-by-line, to
;;;###autoload (autoload 'doom-modeline-env-setup-ruby "doom-modeline-env") ;;;###autoload (autoload 'doom-modeline-env-setup-ruby "doom-modeline-env")
(doom-modeline-def-env ruby (doom-modeline-def-env ruby
:hooks '(ruby-mode-hook ruby-ts-mode-hook enh-ruby-mode-hook) :hooks '(ruby-mode-hook enh-ruby-mode-hook)
:command (lambda () (list (or doom-modeline-env-ruby-executable "ruby") "--version")) :command (lambda () (list (or doom-modeline-env-ruby-executable "ruby") "--version"))
:parser (lambda (line) :parser (lambda (line)
(car (split-string (car (split-string
@ -244,7 +244,7 @@ PARSER should be a function for parsing COMMAND's output line-by-line, to
;;;###autoload (autoload 'doom-modeline-env-setup-go "doom-modeline-env") ;;;###autoload (autoload 'doom-modeline-env-setup-go "doom-modeline-env")
(doom-modeline-def-env go (doom-modeline-def-env go
:hooks '(go-mode-hook go-ts-mode-hook) :hooks 'go-mode-hook
:command (lambda () (list (or doom-modeline-env-go-executable "go") "version")) :command (lambda () (list (or doom-modeline-env-go-executable "go") "version"))
:parser (lambda (line) :parser (lambda (line)
(cadr (cadr
@ -262,7 +262,7 @@ PARSER should be a function for parsing COMMAND's output line-by-line, to
;;;###autoload (autoload 'doom-modeline-env-setup-rust "doom-modeline-env") ;;;###autoload (autoload 'doom-modeline-env-setup-rust "doom-modeline-env")
(doom-modeline-def-env rust (doom-modeline-def-env rust
:hooks '(rust-mode-hook rust-ts-mode-hook) :hooks 'rust-mode-hook
:command (lambda () (list (or doom-modeline-env-rust-executable "rustc") "--version")) :command (lambda () (list (or doom-modeline-env-rust-executable "rustc") "--version"))
:parser (lambda (line) :parser (lambda (line)
(car (car

View file

@ -1,11 +1,8 @@
(define-package "doom-modeline" "20230807.1218" "A minimal and modern mode-line" (define-package "doom-modeline" "20230219.1605" "A minimal and modern mode-line"
'((emacs "25.1") '((emacs "25.1")
(compat "28.1.1.1") (compat "28.1.1.1")
(nerd-icons "0.0.1")
(shrink-path "0.2.0")) (shrink-path "0.2.0"))
:commit "de4af51c04237555ee3030502bdb57597cefb181" :authors :commit "6125309c2caa3c98591a4c802e9b4dd2f7ea83e9" :authors
'(("Vincent Zhang" . "seagle0128@gmail.com"))
:maintainers
'(("Vincent Zhang" . "seagle0128@gmail.com")) '(("Vincent Zhang" . "seagle0128@gmail.com"))
:maintainer :maintainer
'("Vincent Zhang" . "seagle0128@gmail.com") '("Vincent Zhang" . "seagle0128@gmail.com")

File diff suppressed because it is too large Load diff

View file

@ -1,11 +1,11 @@
;;; doom-modeline.el --- A minimal and modern mode-line -*- lexical-binding: t; -*- ;;; doom-modeline.el --- A minimal and modern mode-line -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2023 Vincent Zhang ;; Copyright (C) 2018-2020 Vincent Zhang
;; Author: Vincent Zhang <seagle0128@gmail.com> ;; Author: Vincent Zhang <seagle0128@gmail.com>
;; Homepage: https://github.com/seagle0128/doom-modeline ;; Homepage: https://github.com/seagle0128/doom-modeline
;; Version: 4.0.0 ;; Version: 3.3.3
;; Package-Requires: ((emacs "25.1") (compat "28.1.1.1") (nerd-icons "0.0.1") (shrink-path "0.2.0")) ;; Package-Requires: ((emacs "25.1") (compat "28.1.1.1") (shrink-path "0.2.0"))
;; Keywords: faces mode-line ;; Keywords: faces mode-line
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.

View file

@ -0,0 +1,91 @@
;;; doom-modeline-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "doom-modeline" "doom-modeline.el" (0 0 0 0))
;;; Generated autoloads from doom-modeline.el
(autoload 'doom-modeline-set-main-modeline "doom-modeline" "\
Set main mode-line.
If DEFAULT is non-nil, set the default mode-line for all buffers.
\(fn &optional DEFAULT)" nil nil)
(defvar doom-modeline-mode nil "\
Non-nil if Doom-Modeline mode is enabled.
See the `doom-modeline-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `doom-modeline-mode'.")
(custom-autoload 'doom-modeline-mode "doom-modeline" nil)
(autoload 'doom-modeline-mode "doom-modeline" "\
Toggle `doom-modeline' on or off.
This is a minor mode. If called interactively, toggle the
`Doom-Modeline mode' mode. If the prefix argument is positive,
enable the mode, and if it is zero or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
evaluate `(default-value \\='doom-modeline-mode)'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
\(fn &optional ARG)" t nil)
(register-definition-prefixes "doom-modeline" '("doom-modeline-"))
;;;***
;;;### (autoloads nil "doom-modeline-core" "doom-modeline-core.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from doom-modeline-core.el
(register-definition-prefixes "doom-modeline-core" '("doom-modeline"))
;;;***
;;;### (autoloads nil "doom-modeline-env" "doom-modeline-env.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from doom-modeline-env.el
(autoload 'doom-modeline-env-setup-python "doom-modeline-env")
(autoload 'doom-modeline-env-setup-ruby "doom-modeline-env")
(autoload 'doom-modeline-env-setup-perl "doom-modeline-env")
(autoload 'doom-modeline-env-setup-go "doom-modeline-env")
(autoload 'doom-modeline-env-setup-elixir "doom-modeline-env")
(autoload 'doom-modeline-env-setup-rust "doom-modeline-env")
(register-definition-prefixes "doom-modeline-env" '("doom-modeline-"))
;;;***
;;;### (autoloads nil "doom-modeline-segments" "doom-modeline-segments.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from doom-modeline-segments.el
(register-definition-prefixes "doom-modeline-segments" '("doom-modeline-"))
;;;***
;;;### (autoloads nil nil ("doom-modeline-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; doom-modeline-autoloads.el ends here

View file

@ -1,6 +1,6 @@
;;; doom-modeline-core.el --- The core libraries for doom-modeline -*- lexical-binding: t; -*- ;;; doom-modeline-core.el --- The core libraries for doom-modeline -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2023 Vincent Zhang ;; Copyright (C) 2018-2020 Vincent Zhang
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.
@ -30,87 +30,16 @@
(require 'subr-x) (require 'subr-x)
(require 'compat) (require 'compat)
(require 'nerd-icons)
(require 'shrink-path) (require 'shrink-path)
(require 'all-the-icons nil t)
;; ;;
;; Compatibility ;; Externals
;; ;;
;; Backport from 30 (declare-function all-the-icons--function-name "ext:all-the-icons")
(unless (fboundp 'mode--line-format-right-align)
(defcustom mode-line-right-align-edge 'window
"Where function `mode-line-format-right-align' should align to.
Internally, that function uses `:align-to' in a display property,
so aligns to the left edge of the given area. See info node
`(elisp)Pixel Specification'.
Must be set to a symbol. Acceptable values are:
- `window': align to extreme right of window, regardless of margins
or fringes
- `right-fringe': align to right-fringe
- `right-margin': align to right-margin"
:type '(choice (const right-margin)
(const right-fringe)
(const window))
:group 'mode-line)
(defun doom-modeline-string-pixel-width (str)
"Return the width of STR in pixels."
(if (fboundp 'string-pixel-width)
(string-pixel-width str)
(* (string-width str) (window-font-width nil 'mode-line) 1.05)))
(defun mode--line-format-right-align ()
"Right-align all following mode-line constructs.
When the symbol `mode-line-format-right-align' appears in
`mode-line-format', return a string of one space, with a display
property to make it appear long enough to align anything after
that symbol to the right of the rendered mode line. Exactly how
far to the right is controlled by `mode-line-right-align-edge'.
It is important that the symbol `mode-line-format-right-align' be
included in `mode-line-format' (and not another similar construct
such as `(:eval (mode-line-format-right-align)'). This is because
the symbol `mode-line-format-right-align' is processed by
`format-mode-line' as a variable."
(let* ((rest (cdr (memq 'mode-line-format-right-align
mode-line-format)))
(rest-str (format-mode-line `("" ,@rest)))
(rest-width (progn
(add-face-text-property
0 (length rest-str) 'mode-line t rest-str)
(doom-modeline-string-pixel-width rest-str))))
(propertize " " 'display
;; The `right' spec doesn't work on TTY frames
;; when windows are split horizontally (bug#59620)
(if (and (display-graphic-p)
(not (eq mode-line-right-align-edge 'window)))
`(space :align-to (- ,mode-line-right-align-edge
(,rest-width)))
`(space :align-to (,(- (window-pixel-width)
(window-scroll-bar-width)
(window-right-divider-width)
(* (or (cdr (window-margins)) 1)
(frame-char-width))
;; Manually account for value of
;; `mode-line-right-align-edge' even
;; when display is non-graphical
(pcase mode-line-right-align-edge
('right-margin
(or (cdr (window-margins)) 0))
('right-fringe
;; what here?
(or (cadr (window-fringes)) 0))
(_ 0))
rest-width)))))))
(defvar mode-line-format-right-align '(:eval (mode--line-format-right-align))
"Mode line construct to right align all following constructs.")
;;;###autoload
(put 'mode-line-format-right-align 'risky-local-variable t))
;; ;;
@ -121,6 +50,30 @@ the symbol `mode-line-format-right-align' is processed by
(when (eq system-type 'windows-nt) (when (eq system-type 'windows-nt)
(setq inhibit-compacting-font-caches t)) (setq inhibit-compacting-font-caches t))
;; For better performance, because `window-font-width' consumes a lot.
(defvar doom-modeline--font-width-cache nil)
(defun doom-modeline--font-width ()
"Cache the font width for better performance."
(if (display-graphic-p)
(let ((attributes (face-all-attributes 'mode-line)))
(or (cdr (assoc attributes doom-modeline--font-width-cache))
(let ((width (window-font-width nil 'mode-line)))
(push (cons attributes width) doom-modeline--font-width-cache)
width)))
1))
;; Refresh the font width after setting frame parameters
;; to ensure the font width is correct.
(defun doom-modeline-refresh-font-width-cache (&rest _)
"Refresh the font width cache."
(setq doom-modeline--font-width-cache nil)
(doom-modeline--font-width))
(add-hook 'window-setup-hook #'doom-modeline-refresh-font-width-cache)
(add-hook 'after-make-frame-functions #'doom-modeline-refresh-font-width-cache)
(add-hook 'after-setting-font-hook #'doom-modeline-refresh-font-width-cache)
(add-hook 'server-after-make-frame-hook #'doom-modeline-refresh-font-width-cache)
;; ;;
;; Customization ;; Customization
@ -144,7 +97,7 @@ Must be set before loading `doom-modeline'."
(remove-hook 'emacs-lisp-mode-hook #'doom-modeline-add-imenu))) (remove-hook 'emacs-lisp-mode-hook #'doom-modeline-add-imenu)))
:group 'doom-modeline) :group 'doom-modeline)
(defcustom doom-modeline-height (+ (frame-char-height) 4) (defcustom doom-modeline-height 25
"How tall the mode-line should be. It's only respected in GUI. "How tall the mode-line should be. It's only respected in GUI.
If the actual char height is larger, it respects the actual char height." If the actual char height is larger, it respects the actual char height."
:type 'integer :type 'integer
@ -227,14 +180,6 @@ Given ~/Projects/FOSS/emacs/lisp/comint.el
(const buffer-name)) (const buffer-name))
:group'doom-modeline) :group'doom-modeline)
(defcustom doom-modeline-buffer-file-true-name nil
"Use `file-truename' on buffer file name.
Project detection(projectile.el) may uses `file-truename' on directory path.
Turn on this to provide right relative path for buffer file name."
:type 'boolean
:group'doom-modeline)
(defcustom doom-modeline-icon t (defcustom doom-modeline-icon t
"Whether display the icons in the mode-line. "Whether display the icons in the mode-line.
@ -252,7 +197,7 @@ It respects variable `doom-modeline-icon'."
(defcustom doom-modeline-major-mode-color-icon t (defcustom doom-modeline-major-mode-color-icon t
"Whether display the colorful icon for `major-mode'. "Whether display the colorful icon for `major-mode'.
It respects `nerd-icons-color-icons'." It respects `all-the-icons-color-icons'."
:type 'boolean :type 'boolean
:group'doom-modeline) :group'doom-modeline)
@ -607,7 +552,8 @@ If nil, display only if the mode line is active."
:group 'doom-modeline) :group 'doom-modeline)
(defcustom doom-modeline-always-visible-segments nil (defcustom doom-modeline-always-visible-segments nil
"A list of segments that should be visible even in inactive windows." "A list of segments that should be visible even in
inactive windows."
:type '(repeat symbol) :type '(repeat symbol)
:group 'doom-modeline) :group 'doom-modeline)
@ -658,7 +604,7 @@ If nil, display only if the mode line is active."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-buffer-minor-mode (defface doom-modeline-buffer-minor-mode
'((t (:inherit (doom-modeline font-lock-doc-face) :weight normal :slant normal))) '((t (:inherit (doom-modeline font-lock-doc-face) :slant normal)))
"Face used for the minor-modes segment in the mode-line." "Face used for the minor-modes segment in the mode-line."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -689,32 +635,32 @@ This applies to `anzu', `evil-substitute', `iedit' etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-input-method (defface doom-modeline-input-method
'((t (:inherit (doom-modeline-emphasis)))) '((t (:inherit (doom-modeline-emphasis bold))))
"Face for input method in the mode-line." "Face for input method in the mode-line."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-input-method-alt (defface doom-modeline-input-method-alt
'((t (:inherit (doom-modeline font-lock-doc-face) :slant normal))) '((t (:inherit (doom-modeline font-lock-doc-face bold) :slant normal)))
"Alternative face for input method in the mode-line." "Alternative face for input method in the mode-line."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-debug (defface doom-modeline-debug
'((t (:inherit (doom-modeline font-lock-doc-face) :slant normal))) '((t (:inherit (doom-modeline font-lock-doc-face bold) :slant normal)))
"Face for debug-level messages in the mode-line. Used by vcs, checker, etc." "Face for debug-level messages in the mode-line. Used by vcs, checker, etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-info (defface doom-modeline-info
'((t (:inherit (doom-modeline success)))) '((t (:inherit (doom-modeline success bold))))
"Face for info-level messages in the mode-line. Used by vcs, checker, etc." "Face for info-level messages in the mode-line. Used by vcs, checker, etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-warning (defface doom-modeline-warning
'((t (:inherit (doom-modeline warning)))) '((t (:inherit (doom-modeline warning bold))))
"Face for warnings in the mode-line. Used by vcs, checker, etc." "Face for warnings in the mode-line. Used by vcs, checker, etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-urgent (defface doom-modeline-urgent
'((t (:inherit (doom-modeline error)))) '((t (:inherit (doom-modeline error bold))))
"Face for errors in the mode-line. Used by vcs, checker, etc." "Face for errors in the mode-line. Used by vcs, checker, etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -725,7 +671,7 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-unread-number (defface doom-modeline-unread-number
'((t (:inherit doom-modeline :slant italic))) '((t (:inherit doom-modeline :slant italic :weight normal)))
"Face for unread number in the mode-line. Used by GitHub, mu4e, etc." "Face for unread number in the mode-line. Used by GitHub, mu4e, etc."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -735,7 +681,7 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-bar-inactive (defface doom-modeline-bar-inactive
`((t (:inherit doom-modeline))) `((t (:background ,(face-foreground 'mode-line-inactive))))
"The face used for the left-most bar in the mode-line of an inactive window." "The face used for the left-most bar in the mode-line of an inactive window."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -746,17 +692,17 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-evil-emacs-state (defface doom-modeline-evil-emacs-state
'((t (:inherit (doom-modeline font-lock-builtin-face)))) '((t (:inherit (doom-modeline font-lock-builtin-face bold))))
"Face for the Emacs state tag in evil indicator." "Face for the Emacs state tag in evil indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-evil-insert-state (defface doom-modeline-evil-insert-state
'((t (:inherit (doom-modeline font-lock-keyword-face)))) '((t (:inherit (doom-modeline font-lock-keyword-face bold))))
"Face for the insert state tag in evil indicator." "Face for the insert state tag in evil indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-evil-motion-state (defface doom-modeline-evil-motion-state
'((t (:inherit (doom-modeline font-lock-doc-face) :slant normal))) '((t (:inherit (doom-modeline font-lock-doc-face bold) :slant normal)))
"Face for the motion state tag in evil indicator." "Face for the motion state tag in evil indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -766,7 +712,7 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-evil-operator-state (defface doom-modeline-evil-operator-state
'((t (:inherit (doom-modeline mode-line)))) '((t (:inherit doom-modeline-buffer-file)))
"Face for the operator state tag in evil indicator." "Face for the operator state tag in evil indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -791,12 +737,12 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-ryo (defface doom-modeline-ryo
'((t (:inherit doom-modeline-info))) '((t (:inherit doom-modeline-ryo)))
"Face for RYO indicator." "Face for RYO indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-fly-insert-state (defface doom-modeline-fly-insert-state
'((t (:inherit (doom-modeline font-lock-keyword-face)))) '((t (:inherit (font-lock-keyword-face bold))))
"Face for the insert state in xah-fly-keys indicator." "Face for the insert state in xah-fly-keys indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -811,17 +757,17 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-boon-insert-state (defface doom-modeline-boon-insert-state
'((t (:inherit (doom-modeline font-lock-keyword-face)))) '((t (:inherit (doom-modeline font-lock-keyword-face bold))))
"Face for the insert state tag in boon indicator." "Face for the insert state tag in boon indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-boon-special-state (defface doom-modeline-boon-special-state
'((t (:inherit (doom-modeline font-lock-builtin-face)))) '((t (:inherit (doom-modeline font-lock-builtin-face bold))))
"Face for the special state tag in boon indicator." "Face for the special state tag in boon indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-boon-off-state (defface doom-modeline-boon-off-state
'((t (:inherit (doom-modeline mode-line)))) '((t (:inherit doom-modeline-buffer-file)))
"Face for the off state tag in boon indicator." "Face for the off state tag in boon indicator."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -831,32 +777,32 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-persp-buffer-not-in-persp (defface doom-modeline-persp-buffer-not-in-persp
'((t (:inherit (doom-modeline font-lock-doc-face italic)))) '((t (:inherit (doom-modeline font-lock-doc-face bold italic))))
"Face for the buffers which are not in the persp." "Face for the buffers which are not in the persp."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-repl-success (defface doom-modeline-repl-success
'((t (:inherit doom-modeline-info))) '((t (:inherit doom-modeline-info :weight normal)))
"Face for REPL success state." "Face for REPL success state."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-repl-warning (defface doom-modeline-repl-warning
'((t (:inherit doom-modeline-warning))) '((t (:inherit doom-modeline-warning :weight normal)))
"Face for REPL warning state." "Face for REPL warning state."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-lsp-success (defface doom-modeline-lsp-success
'((t (:inherit doom-modeline-info))) '((t (:inherit doom-modeline-info :weight normal)))
"Face for LSP success state." "Face for LSP success state."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-lsp-warning (defface doom-modeline-lsp-warning
'((t (:inherit doom-modeline-warning))) '((t (:inherit doom-modeline-warning :weight normal)))
"Face for LSP warning state." "Face for LSP warning state."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-lsp-error (defface doom-modeline-lsp-error
'((t (:inherit doom-modeline-urgent))) '((t (:inherit doom-modeline-urgent :weight normal)))
"Face for LSP error state." "Face for LSP error state."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -866,32 +812,32 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-charging (defface doom-modeline-battery-charging
'((t (:inherit doom-modeline-info))) '((t (:inherit doom-modeline-info :weight normal)))
"Face for battery charging status." "Face for battery charging status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-full (defface doom-modeline-battery-full
'((t (:inherit doom-modeline-info))) '((t (:inherit doom-modeline-info :weight normal)))
"Face for battery full status." "Face for battery full status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-normal (defface doom-modeline-battery-normal
'((t (:inherit (doom-modeline mode-line)))) '((t (:inherit (doom-modeline mode-line) :weight normal)))
"Face for battery normal status." "Face for battery normal status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-warning (defface doom-modeline-battery-warning
'((t (:inherit doom-modeline-warning))) '((t (:inherit doom-modeline-warning :weight normal)))
"Face for battery warning status." "Face for battery warning status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-critical (defface doom-modeline-battery-critical
'((t (:inherit doom-modeline-urgent))) '((t (:inherit doom-modeline-urgent :weight normal)))
"Face for battery critical status." "Face for battery critical status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-battery-error (defface doom-modeline-battery-error
'((t (:inherit doom-modeline-urgent))) '((t (:inherit doom-modeline-urgent :weight normal)))
"Face for battery error status." "Face for battery error status."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -906,7 +852,7 @@ Also see the face `doom-modeline-unread-number'."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
(defface doom-modeline-compilation (defface doom-modeline-compilation
'((t (:inherit doom-modeline-warning :slant italic :height 0.9))) '((t (:inherit doom-modeline-warning :weight normal :slant italic :height 0.9)))
"Face for compilation progress." "Face for compilation progress."
:group 'doom-modeline-faces) :group 'doom-modeline-faces)
@ -959,8 +905,7 @@ Also see the face `doom-modeline-unread-number'."
;; FIXME #183: Force to calculate mode-line height ;; FIXME #183: Force to calculate mode-line height
;; @see https://github.com/seagle0128/doom-modeline/issues/183 ;; @see https://github.com/seagle0128/doom-modeline/issues/183
;; @see https://github.com/seagle0128/doom-modeline/issues/483 ;; @see https://github.com/seagle0128/doom-modeline/issues/483
(unless (>= emacs-major-version 29) (defun doom-modeline-redisplay (&rest _)
(defun doom-modeline-redisplay (&rest _)
"Call `redisplay' to trigger mode-line height calculations. "Call `redisplay' to trigger mode-line height calculations.
Certain functions, including e.g. `fit-window-to-buffer', base Certain functions, including e.g. `fit-window-to-buffer', base
@ -982,16 +927,14 @@ used as an advice to window creation functions."
mode-line-format mode-line-format
(/= (frame-char-height) (window-mode-line-height))) (/= (frame-char-height) (window-mode-line-height)))
(redisplay t))) (redisplay t)))
(unless (>= emacs-major-version 29)
(advice-add #'fit-window-to-buffer :before #'doom-modeline-redisplay)) (advice-add #'fit-window-to-buffer :before #'doom-modeline-redisplay))
;; For `flychecker-color-mode-line'
(with-eval-after-load 'flychecker-color-mode-line
(defvar flycheck-color-mode-line-face-to-color)
(setq flycheck-color-mode-line-face-to-color 'doom-modeline))
(defun doom-modeline-icon-displayable-p () (defun doom-modeline-icon-displayable-p ()
"Return non-nil if icons are displayable." "Return non-nil if icons are displayable."
(and doom-modeline-icon (featurep 'nerd-icons))) (and doom-modeline-icon
(display-graphic-p)
(featurep 'all-the-icons)))
(defun doom-modeline-mwheel-available-p () (defun doom-modeline-mwheel-available-p ()
"Whether mouse wheel is available." "Whether mouse wheel is available."
@ -1016,8 +959,8 @@ used as an advice to window creation functions."
(defvar-local doom-modeline--limited-width-p nil) (defvar-local doom-modeline--limited-width-p nil)
(defun doom-modeline--segment-visible (name) (defun doom-modeline--segment-visible (name)
"Whether the segment NAME should be displayed." "Whether a segment should be displayed"
(and (and
(or (doom-modeline--active) (or (doom-modeline--active)
(member name doom-modeline-always-visible-segments)) (member name doom-modeline-always-visible-segments))
(not doom-modeline--limited-width-p))) (not doom-modeline--limited-width-p)))
@ -1141,7 +1084,24 @@ Example:
(rhs-forms (doom-modeline--prepare-segments rhs))) (rhs-forms (doom-modeline--prepare-segments rhs)))
(defalias sym (defalias sym
(lambda () (lambda ()
`(,lhs-forms ,rhs-forms)) (list lhs-forms
(propertize
" "
'face (doom-modeline-face)
'display `(space
:align-to
(- (+ right right-fringe right-margin scroll-bar)
,(let ((rhs-str (format-mode-line (cons "" rhs-forms))))
(if (and (>= emacs-major-version 29)
(fboundp 'string-pixel-width))
(/ (string-pixel-width rhs-str)
(doom-modeline--font-width)
1.0)
(* (string-width rhs-str)
(if (display-graphic-p)
(/ (doom-modeline--font-width) (frame-char-width) 0.95)
1.0)))))))
rhs-forms))
(concat "Modeline:\n" (concat "Modeline:\n"
(format " %s\n %s" (format " %s\n %s"
(prin1-to-string lhs) (prin1-to-string lhs)
@ -1153,10 +1113,7 @@ Example:
Throws an error if it doesn't exist." Throws an error if it doesn't exist."
(let ((fn (intern-soft (format "doom-modeline-format--%s" key)))) (let ((fn (intern-soft (format "doom-modeline-format--%s" key))))
(when (functionp fn) (when (functionp fn)
(let* ((modeline (funcall fn)) `(:eval (,fn)))))
(lhs (car modeline))
(rhs (cdr modeline)))
`(,lhs mode-line-format-right-align ,rhs)))))
(defun doom-modeline-set-modeline (key &optional default) (defun doom-modeline-set-modeline (key &optional default)
"Set the modeline format. Does nothing if the modeline KEY doesn't exist. "Set the modeline format. Does nothing if the modeline KEY doesn't exist.
@ -1165,7 +1122,7 @@ If DEFAULT is non-nil, set the default mode-line for all buffers."
(setf (if default (setf (if default
(default-value 'mode-line-format) (default-value 'mode-line-format)
mode-line-format) mode-line-format)
modeline))) (list "%e" modeline))))
;; ;;
@ -1202,12 +1159,18 @@ If INACTIVE-FACE is nil, `mode-line-inactive' face will be used."
(and (facep inactive-face) inactive-face) (and (facep inactive-face) inactive-face)
'mode-line-inactive))) 'mode-line-inactive)))
;; Since 27, the calculation of char height was changed
;; @see https://github.com/seagle0128/doom-modeline/issues/271
(defun doom-modeline--font-height () (defun doom-modeline--font-height ()
"Calculate the actual char height of the mode-line." "Calculate the actual char height of the mode-line."
(let ((height (face-attribute 'mode-line :height)) (let ((height (face-attribute 'mode-line :height))
(char-height (window-font-height nil 'mode-line))) (char-height (window-font-height nil 'mode-line)))
(round (round
(* 1.0 (cond ((integerp height) (/ height 10)) (* (pcase system-type
('darwin (if doom-modeline-icon 1.7 1.0))
('windows-nt (if doom-modeline-icon 1.3 1.0))
(_ (if (and doom-modeline-icon (< emacs-major-version 27)) 1.4 1.0)))
(cond ((integerp height) (/ height 10))
((floatp height) (* height char-height)) ((floatp height) (* height char-height))
(t char-height)))))) (t char-height))))))
@ -1248,10 +1211,10 @@ See https://github.com/seagle0128/doom-modeline/issues/301."
(defun doom-modeline-icon (icon-set icon-name unicode text &rest args) (defun doom-modeline-icon (icon-set icon-name unicode text &rest args)
"Display icon of ICON-NAME with ARGS in mode-line. "Display icon of ICON-NAME with ARGS in mode-line.
ICON-SET includes `ipsicon', `octicon', `pomicon', `powerline', `faicon', ICON-SET includes `octicon', `faicon', `material', `alltheicons' and `fileicon',
`wicon', `sucicon', `devicon', `codicon', `flicon' and `mdicon', etc. etc.
UNICODE is the unicode char fallback. TEXT is the ASCII char fallback. UNICODE is the unicode char fallback. TEXT is the ASCII char fallback.
ARGS is same as `nerd-icons-octicon' and others." ARGS is same as `all-the-icons-octicon' and others."
(let ((face `(:inherit (doom-modeline (let ((face `(:inherit (doom-modeline
,(or (plist-get args :face) 'mode-line))))) ,(or (plist-get args :face) 'mode-line)))))
(cond (cond
@ -1259,7 +1222,7 @@ ARGS is same as `nerd-icons-octicon' and others."
((and (doom-modeline-icon-displayable-p) ((and (doom-modeline-icon-displayable-p)
icon-name icon-name
(not (string-empty-p icon-name))) (not (string-empty-p icon-name)))
(when-let* ((func (nerd-icons--function-name icon-set)) (when-let* ((func (all-the-icons--function-name icon-set))
(icon (and (fboundp func) (icon (and (fboundp func)
(apply func icon-name args)))) (apply func icon-name args))))
(doom-modeline-propertize-icon icon face))) (doom-modeline-propertize-icon icon face)))
@ -1275,10 +1238,6 @@ ARGS is same as `nerd-icons-octicon' and others."
;; Fallback ;; Fallback
(t "")))) (t ""))))
(defun doom-modeline-icon-for-buffer ()
"Get the formatted icon for the current buffer."
(nerd-icons-icon-for-buffer))
(defun doom-modeline-display-icon (icon) (defun doom-modeline-display-icon (icon)
"Display ICON in mode-line." "Display ICON in mode-line."
(if (doom-modeline--active) (if (doom-modeline--active)
@ -1295,7 +1254,8 @@ ARGS is same as `nerd-icons-octicon' and others."
"Create the bar image. "Create the bar image.
Use FACE for the bar, WIDTH and HEIGHT are the image size in pixels." Use FACE for the bar, WIDTH and HEIGHT are the image size in pixels."
(when (and (image-type-available-p 'pbm) (when (and (display-graphic-p)
(image-type-available-p 'pbm)
(numberp width) (> width 0) (numberp width) (> width 0)
(numberp height) (> height 0)) (numberp height) (> height 0))
(propertize (propertize
@ -1461,12 +1421,12 @@ If INCLUDE-PROJECT is non-nil, the project path will be included."
'face 'doom-modeline-buffer-file)))))) 'face 'doom-modeline-buffer-file))))))
(defun doom-modeline--buffer-file-name (file-path (defun doom-modeline--buffer-file-name (file-path
true-file-path _true-file-path
&optional &optional
truncate-project-root-parent truncate-project-root-parent
truncate-project-relative-path truncate-project-relative-path
hide-project-root-parent) hide-project-root-parent)
"Propertize buffer name given by FILE-PATH or TRUE-FILE-PATH. "Propertize buffer name given by FILE-PATH.
If TRUNCATE-PROJECT-ROOT-PARENT is non-nil will be saved by truncating project If TRUNCATE-PROJECT-ROOT-PARENT is non-nil will be saved by truncating project
root parent down fish-shell style. root parent down fish-shell style.
@ -1504,10 +1464,7 @@ Example:
;; relative path ;; relative path
(propertize (propertize
(when-let (relative-path (file-relative-name (when-let (relative-path (file-relative-name
(or (file-name-directory (or (file-name-directory file-path) "./")
(if doom-modeline-buffer-file-true-name
true-file-path file-path))
"./")
project-root)) project-root))
(if (string= relative-path "./") (if (string= relative-path "./")
"" ""

View file

@ -0,0 +1,276 @@
;;; doom-modeline-env.el --- A environment parser for doom-modeline -*- lexical-binding: t -*-
;; Copyright (C) 2019-2020 Justin Barclay, Vincent Zhang
;; This file is not part of GNU Emacs.
;;
;; 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:
;;
;; Parse programming environment.
;;
;;; Code:
(require 'subr-x)
(require 'doom-modeline-core)
;; Externals
(defvar python-shell-interpreter)
;; Customization
(defgroup doom-modeline-env nil
"The environment parser for `doom-modeline'."
:group 'doom-modeline
:link '(url-link :tag "Homepage" "https://github.com/seagle0128/doom-modeline"))
(defcustom doom-modeline-env-load-string doom-modeline-ellipsis
"What to display as the version while a new one is being loaded."
:type 'string
:group 'doom-modeline-env)
(defcustom doom-modeline-before-update-env-hook nil
"Hooks that run before the modeline version string is updated."
:type 'hook
:group 'doom-modeline-env)
(defcustom doom-modeline-after-update-env-hook nil
"Hooks that run after the modeline version string is updated."
:type 'hook
:group 'doom-modeline-env)
;; Variables
;; Show version string for multi-version managers like rvm, rbenv, pyenv, etc.
(defvar-local doom-modeline-env--version nil
"The version to display with major-mode in mode-line.
Example: \"2.6.0\"")
(defvar-local doom-modeline-env--command nil
"A program that we're looking to extract version information from.
Example: \"ruby\"")
(defvar-local doom-modeline-env--command-args nil
"A list of arguments for the command to extract the version from.
Example: \\='(\"--version\")")
(defvar-local doom-modeline-env--parser nil
"A function that returns version number from a command --version (or similar).
Example: \\='doom-modeline-env--ruby")
;; Functions & Macros
(defun doom-modeline-update-env ()
"Update environment info on mode-line."
(when (and doom-modeline-env-version
doom-modeline-env--command
(executable-find doom-modeline-env--command)
doom-modeline-env--command-args
doom-modeline-env--parser)
(let ((default-directory (doom-modeline-project-root))
(buffer (current-buffer)))
(run-hooks 'doom-modeline-before-update-env-hook)
(setq doom-modeline-env--version doom-modeline-env-load-string)
(doom-modeline-env--get
doom-modeline-env--command
doom-modeline-env--command-args
(lambda (prog-version)
(with-current-buffer buffer
(setq doom-modeline-env--version
(funcall doom-modeline-env--parser prog-version))
(run-hooks 'doom-modeline-after-update-env-hook)))))))
(add-hook 'find-file-hook #'doom-modeline-update-env)
(with-no-warnings
(if (boundp 'after-focus-change-function)
(add-function
:after after-focus-change-function
(lambda ()
(if (frame-focus-state)
(doom-modeline-update-env))))
(add-hook 'focus-in-hook #'doom-modeline-update-env)))
(defun doom-modeline-env--get (prog args callback)
"Start a sub process using PROG and apply the ARGS to the sub process.
Once it receives information from STDOUT, it closes off the subprocess and
passes on the information into the CALLBACK.
Example:
(doom-modeline-env--get
\"ruby\"
\\='(\"--version\")
(lambda (line)
(message (doom-modeline-parser--ruby line)))"
(when-let ((proc (ignore-errors
(apply 'start-process
;; Flaten process-args into a single list so we can handle
;; variadic length args
(append
(list "doom-modeline-env" nil prog)
args))))
(parser callback))
(set-process-filter proc
(lambda (_proc line)
(ignore-errors
(funcall parser line))))))
(cl-defmacro doom-modeline-def-env (name &key hooks command parser)
"Define a handler for updating & displaying a version string for a language.
NAME is an unquoted symbol representing the handler's unique ID.
HOOKS is a list of hook symbols where this handler should be triggered.
COMMAND should be a function that returns a shell command and its arguments (as
a list). It is run on HOOKS. It takes no arguments.
PARSER should be a function for parsing COMMAND's output line-by-line, to
extract the version string."
(declare (indent defun))
(unless (and hooks command parser)
(error "'%s' env is missing either :hooks, :command or :parser" name))
(let ((parse-fn (intern (format "doom-modeline-env--%s-parse" name)))
(action-fn (intern (format "doom-modeline-env--%s-args" name)))
(setup-fn (intern (format "doom-modeline-env-setup-%s" name)))
(update-fn (intern (format "doom-modeline-env-update-%s" name)))
(enable-var (intern (format "doom-modeline-env-enable-%s" name)))
(command-var (intern (format "doom-modeline-env-%s-command" name)))
(parser-var (intern (format "doom-modeline-env-%s-parser-fn" name)))
(exe-var (intern (format "doom-modeline-env-%s-executable" name))))
(macroexp-progn
`((defcustom ,enable-var t
,(format "Whether to display the version string for %s buffers." name)
:type 'boolean
:group 'doom-modeline-env)
(defvar ,command-var ',action-fn
,(concat "A function that returns the shell command and arguments (as a list) to\n"
"produce a version string."))
(defvar ,parser-var ',parse-fn
,(format "The function to parse each line of `%s'\'s output." command-var))
(defcustom ,exe-var nil
,(format (concat "What executable to use for the version indicator in %s buffers.\n\n"
"If nil, the default binary for this language is used.")
name)
:type 'string
:group 'doom-modeline-env)
(defalias ',parse-fn ,parser
(format "The line parser for %s buffers.\n\nUsed by `%s'."
',name ',update-fn))
(defalias ',action-fn ,command
(format "The command resolver for %s buffers.\n\nUsed by `%s'."
',name ',update-fn))
(defalias ',setup-fn
(lambda ()
(if enable-local-variables
(add-hook 'hack-local-variables-hook #',update-fn nil t)
(,update-fn)))
(format "Prepares the modeline to later display the %s version string."
',name))
(defalias ',update-fn
(lambda ()
(when ,enable-var
(when-let* ((command-list (funcall ,command-var))
(exe (executable-find (car command-list))))
(setq doom-modeline-env--command exe
doom-modeline-env--command-args (cdr command-list)
doom-modeline-env--parser ,parser-var)
(doom-modeline-update-env))))
(format "Updates the %s version string in the modeline." ',name))
(let ((hooks ',(eval hooks)))
(dolist (hook (if (listp hooks) hooks (list hooks)))
(add-hook hook #',setup-fn)))))))
;; Bootstrap
;; Versions, support Python, Ruby, Perl and Golang, etc.
;;;###autoload (autoload 'doom-modeline-env-setup-python "doom-modeline-env")
(doom-modeline-def-env python
:hooks 'python-mode-hook
:command (lambda () (cond ((and (fboundp 'pipenv-project-p)
(pipenv-project-p))
(list "pipenv" "run"
(or doom-modeline-env-python-executable
python-shell-interpreter
"python")
"--version"))
((executable-find "pyenv") (list "pyenv" "version-name"))
((list (or doom-modeline-env-python-executable
python-shell-interpreter
"python")
"--version"))))
:parser (lambda (line) (let ((version (split-string line)))
(if (length> version 1)
(cadr version)
(car version)))))
;;;###autoload (autoload 'doom-modeline-env-setup-ruby "doom-modeline-env")
(doom-modeline-def-env ruby
:hooks '(ruby-mode-hook enh-ruby-mode-hook)
:command (lambda () (list (or doom-modeline-env-ruby-executable "ruby") "--version"))
:parser (lambda (line)
(car (split-string
(cadr
(split-string line))
"p"))))
;;;###autoload (autoload 'doom-modeline-env-setup-perl "doom-modeline-env")
(doom-modeline-def-env perl
:hooks 'perl-mode-hook
:command (lambda () (list (or doom-modeline-env-perl-executable "perl") "--version"))
:parser (lambda (line)
(cadr
(split-string
(car
(split-string
(cadr
(split-string line "("))
")"))
"v"))))
;;;###autoload (autoload 'doom-modeline-env-setup-go "doom-modeline-env")
(doom-modeline-def-env go
:hooks 'go-mode-hook
:command (lambda () (list (or doom-modeline-env-go-executable "go") "version"))
:parser (lambda (line)
(cadr
(split-string
(cadr
(cdr
(split-string line)))
"go"))))
;;;###autoload (autoload 'doom-modeline-env-setup-elixir "doom-modeline-env")
(doom-modeline-def-env elixir
:hooks 'elixir-mode-hook
:command (lambda () (list (or doom-modeline-env-elixir-executable "elixir") "--version"))
:parser (lambda (line) (cadr (split-string line))))
;;;###autoload (autoload 'doom-modeline-env-setup-rust "doom-modeline-env")
(doom-modeline-def-env rust
:hooks 'rust-mode-hook
:command (lambda () (list (or doom-modeline-env-rust-executable "rustc") "--version"))
:parser (lambda (line)
(car
(split-string
(cadr
(split-string line))
"-"))))
(provide 'doom-modeline-env)
;;; doom-modeline-env.el ends here

View file

@ -0,0 +1,14 @@
(define-package "doom-modeline" "20230406.623" "A minimal and modern mode-line"
'((emacs "25.1")
(compat "28.1.1.1")
(shrink-path "0.2.0"))
:commit "a86ec8effe242cab8aba09ec0a2c7fed555c1fce" :authors
'(("Vincent Zhang" . "seagle0128@gmail.com"))
:maintainer
'("Vincent Zhang" . "seagle0128@gmail.com")
:keywords
'("faces" "mode-line")
:url "https://github.com/seagle0128/doom-modeline")
;; Local Variables:
;; no-byte-compile: t
;; End:

View file

@ -1,6 +1,6 @@
;;; doom-modeline-segments.el --- The segments for doom-modeline -*- lexical-binding: t; -*- ;;; doom-modeline-segments.el --- The segments for doom-modeline -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2023 Vincent Zhang ;; Copyright (C) 2018-2020 Vincent Zhang
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.
@ -57,7 +57,6 @@
(defvar boon-insert-state) (defvar boon-insert-state)
(defvar boon-off-state) (defvar boon-off-state)
(defvar boon-special-state) (defvar boon-special-state)
(defvar display-time-string)
(defvar edebug-execution-mode) (defvar edebug-execution-mode)
(defvar eglot--managed-mode) (defvar eglot--managed-mode)
(defvar erc-modified-channels-alist) (defvar erc-modified-channels-alist)
@ -85,10 +84,8 @@
(defvar minions-mode-line-minor-modes-map) (defvar minions-mode-line-minor-modes-map)
(defvar mlscroll-minimum-current-width) (defvar mlscroll-minimum-current-width)
(defvar mlscroll-right-align) (defvar mlscroll-right-align)
(defvar mu4e--modeline-item)
(defvar mu4e-alert-mode-line) (defvar mu4e-alert-mode-line)
(defvar mu4e-alert-modeline-formatter) (defvar mu4e-alert-modeline-formatter)
(defvar mu4e-modeline-mode)
(defvar nyan-minimum-window-width) (defvar nyan-minimum-window-width)
(defvar objed--obj-state) (defvar objed--obj-state)
(defvar objed--object) (defvar objed--object)
@ -107,7 +104,9 @@
(defvar tracking-buffers) (defvar tracking-buffers)
(defvar winum-auto-setup-mode-line) (defvar winum-auto-setup-mode-line)
(defvar xah-fly-insert-state-p) (defvar xah-fly-insert-state-p)
(defvar display-time-string)
(declare-function all-the-icons-icon-for-buffer "ext:all-the-icons")
(declare-function anzu--reset-status "ext:anzu") (declare-function anzu--reset-status "ext:anzu")
(declare-function anzu--where-is-here "ext:anzu") (declare-function anzu--where-is-here "ext:anzu")
(declare-function async-inject-variables "ext:async") (declare-function async-inject-variables "ext:async")
@ -204,7 +203,6 @@
(declare-function mc/num-cursors "ext:multiple-cursors-core") (declare-function mc/num-cursors "ext:multiple-cursors-core")
(declare-function minions--prominent-modes "ext:minions") (declare-function minions--prominent-modes "ext:minions")
(declare-function mlscroll-mode-line "ext:mlscroll") (declare-function mlscroll-mode-line "ext:mlscroll")
(declare-function mu4e--modeline-string "ext:mu4e-modeline")
(declare-function mu4e-alert-default-mode-line-formatter "ext:mu4e-alert") (declare-function mu4e-alert-default-mode-line-formatter "ext:mu4e-alert")
(declare-function mu4e-alert-enable-mode-line-display "ext:mu4e-alert") (declare-function mu4e-alert-enable-mode-line-display "ext:mu4e-alert")
(declare-function nyan-create "ext:nyan-mode") (declare-function nyan-create "ext:nyan-mode")
@ -256,12 +254,15 @@
(setq doom-modeline--buffer-file-icon (setq doom-modeline--buffer-file-icon
(when (and doom-modeline-major-mode-icon (when (and doom-modeline-major-mode-icon
(doom-modeline-icon-displayable-p)) (doom-modeline-icon-displayable-p))
(let ((icon (doom-modeline-icon-for-buffer))) (let ((icon (all-the-icons-icon-for-buffer)))
(propertize (if (or (null icon) (symbolp icon)) (propertize (if (or (null icon) (symbolp icon))
(doom-modeline-icon 'faicon "nf-fa-file_o" nil nil (doom-modeline-icon 'faicon "file-o" nil nil
:face 'nerd-icons-dsilver) :face 'all-the-icons-dsilver
:height 0.9
:v-adjust 0.0)
(doom-modeline-propertize-icon icon)) (doom-modeline-propertize-icon icon))
'help-echo (format "Major-mode: %s" (format-mode-line mode-name))))))) 'help-echo (format "Major-mode: %s" (format-mode-line mode-name))
'display '(raise -0.135))))))
(add-hook 'find-file-hook #'doom-modeline-update-buffer-file-icon) (add-hook 'find-file-hook #'doom-modeline-update-buffer-file-icon)
(add-hook 'after-change-major-mode-hook #'doom-modeline-update-buffer-file-icon) (add-hook 'after-change-major-mode-hook #'doom-modeline-update-buffer-file-icon)
(add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-icon) (add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-icon)
@ -278,8 +279,11 @@
(defun doom-modeline-buffer-file-state-icon (icon unicode text face) (defun doom-modeline-buffer-file-state-icon (icon unicode text face)
"Displays an ICON of buffer state with FACE. "Displays an ICON of buffer state with FACE.
UNICODE and TEXT are the alternatives if it is not applicable. UNICODE and TEXT are the alternatives if it is not applicable.
Uses `nerd-icons-mdicon' to fetch the icon." Uses `all-the-icons-material' to fetch the icon."
(doom-modeline-icon 'mdicon icon unicode text :face face)) (doom-modeline-icon 'material icon unicode text
:face face
:height 1.1
:v-adjust -0.225))
(defvar-local doom-modeline--buffer-file-state-icon nil) (defvar-local doom-modeline--buffer-file-state-icon nil)
(defun doom-modeline-update-buffer-file-state-icon (&rest _) (defun doom-modeline-update-buffer-file-state-icon (&rest _)
@ -290,28 +294,29 @@ Uses `nerd-icons-mdicon' to fetch the icon."
(concat (concat
(cond (buffer-read-only (cond (buffer-read-only
(doom-modeline-buffer-file-state-icon (doom-modeline-buffer-file-state-icon
"nf-md-lock" "🔒" "%1*" "lock" "🔒" "%1*" `(:inherit doom-modeline-warning
'doom-modeline-warning)) :weight ,(if doom-modeline-icon
'normal
'bold))))
((and buffer-file-name (buffer-modified-p) ((and buffer-file-name (buffer-modified-p)
doom-modeline-buffer-modification-icon) doom-modeline-buffer-modification-icon)
(doom-modeline-buffer-file-state-icon (doom-modeline-buffer-file-state-icon
"nf-md-content_save_edit" "💾" "%1*" "save" "💾" "%1*" `(:inherit doom-modeline-buffer-modified
'doom-modeline-warning)) :weight ,(if doom-modeline-icon
'normal
'bold))))
((and buffer-file-name ((and buffer-file-name
;; Avoid freezing while connection is lost (not (file-remote-p buffer-file-name)) ; Avoid freezing while connection is lost
(not (file-remote-p buffer-file-name))
(not (file-exists-p buffer-file-name))) (not (file-exists-p buffer-file-name)))
(doom-modeline-buffer-file-state-icon (doom-modeline-buffer-file-state-icon
"nf-md-cancel" "🚫" "!" "do_not_disturb_alt" "🚫" "!" 'doom-modeline-urgent))
'doom-modeline-urgent))
(t "")) (t ""))
(when (or (buffer-narrowed-p) (when (or (buffer-narrowed-p)
(and (bound-and-true-p fancy-narrow-mode) (and (bound-and-true-p fancy-narrow-mode)
(fancy-narrow-active-p)) (fancy-narrow-active-p))
(bound-and-true-p dired-narrow-mode)) (bound-and-true-p dired-narrow-mode))
(doom-modeline-buffer-file-state-icon (doom-modeline-buffer-file-state-icon
"nf-md-unfold_less_horizontal" "" "><" "vertical_align_center" "" "><" 'doom-modeline-warning)))))))
'doom-modeline-warning)))))))
(defvar-local doom-modeline--buffer-file-name nil) (defvar-local doom-modeline--buffer-file-name nil)
(defun doom-modeline-update-buffer-file-name (&rest _) (defun doom-modeline-update-buffer-file-name (&rest _)
@ -434,7 +439,8 @@ read-only or non-existent)."
"Display calculator icons and info." "Display calculator icons and info."
(concat (concat
(doom-modeline-spc) (doom-modeline-spc)
(when-let ((icon (doom-modeline-icon 'faicon "nf-fa-calculator" "🖩" ""))) (when-let ((icon (doom-modeline-icon 'faicon "calculator" nil nil
:height 0.85 :v-adjust -0.05)))
(concat (concat
(doom-modeline-display-icon icon) (doom-modeline-display-icon icon)
(doom-modeline-vspc))) (doom-modeline-vspc)))
@ -449,12 +455,11 @@ project directory is important."
(if (and buffer-file-name (buffer-modified-p)) (if (and buffer-file-name (buffer-modified-p))
'doom-modeline-buffer-modified 'doom-modeline-buffer-modified
'doom-modeline-buffer-path)))) 'doom-modeline-buffer-path))))
(concat (concat (doom-modeline-spc)
(doom-modeline-spc)
(and doom-modeline-major-mode-icon (and doom-modeline-major-mode-icon
(concat (concat (doom-modeline-icon
(doom-modeline-icon 'octicon "file-directory" "🖿" ""
'octicon "nf-oct-file_directory" "🖿" "" :face face) :face face :v-adjust -0.05 :height 1.25)
(doom-modeline-vspc))) (doom-modeline-vspc)))
(doom-modeline--buffer-state-icon) (doom-modeline--buffer-state-icon)
(propertize (abbreviate-file-name default-directory) 'face face)))) (propertize (abbreviate-file-name default-directory) 'face face))))
@ -465,12 +470,11 @@ project directory is important."
This is for special buffers like the scratch buffer where knowing the current This is for special buffers like the scratch buffer where knowing the current
project directory is important." project directory is important."
(let ((face (doom-modeline-face 'doom-modeline-buffer-path))) (let ((face (doom-modeline-face 'doom-modeline-buffer-path)))
(concat (concat (doom-modeline-spc)
(doom-modeline-spc)
(and doom-modeline-major-mode-icon (and doom-modeline-major-mode-icon
(concat (concat (doom-modeline-icon
(doom-modeline-icon 'octicon "file-directory" "🖿" ""
'octicon "nf-oct-file_directory" "🖿" "" :face face) :face face :v-adjust -0.05 :height 1.25)
(doom-modeline-vspc))) (doom-modeline-vspc)))
(propertize (abbreviate-file-name default-directory) 'face face)))) (propertize (abbreviate-file-name default-directory) 'face face))))
@ -627,9 +631,9 @@ project directory is important."
help-echo ,help-echo help-echo ,help-echo
local-map ,mode-line-minor-mode-keymap) local-map ,mode-line-minor-mode-keymap)
,(doom-modeline-spc) ,(doom-modeline-spc)
(:propertize ("" ,(doom-modeline-icon 'octicon "nf-oct-gear" "" (:propertize ("" ,(doom-modeline-icon 'octicon "gear" ""
minions-mode-line-lighter minions-mode-line-lighter
:face face)) :face face :v-adjust -0.05))
mouse-face ,mouse-face mouse-face ,mouse-face
help-echo "Minions help-echo "Minions
mouse-1: Display minor modes menu" mouse-1: Display minor modes menu"
@ -647,12 +651,13 @@ mouse-1: Display minor modes menu"
;; VCS ;; VCS
;; ;;
(defun doom-modeline-vcs-icon (icon &optional unicode text face) (defun doom-modeline-vcs-icon (icon &optional unicode text face voffset)
"Displays the vcs ICON with FACE and VOFFSET. "Displays the vcs ICON with FACE and VOFFSET.
UNICODE and TEXT are fallbacks. UNICODE and TEXT are fallbacks.
Uses `nerd-icons-octicon' to fetch the icon." Uses `all-the-icons-octicon' to fetch the icon."
(doom-modeline-icon 'devicon icon unicode text :face face)) (doom-modeline-icon 'octicon icon unicode text
:face face :v-adjust (or voffset -0.1)))
(defvar-local doom-modeline--vcs-icon nil) (defvar-local doom-modeline--vcs-icon nil)
(defun doom-modeline-update-vcs-icon (&rest _) (defun doom-modeline-update-vcs-icon (&rest _)
@ -662,15 +667,15 @@ Uses `nerd-icons-octicon' to fetch the icon."
(let* ((backend (vc-backend buffer-file-name)) (let* ((backend (vc-backend buffer-file-name))
(state (vc-state buffer-file-name backend))) (state (vc-state buffer-file-name backend)))
(cond ((memq state '(edited added)) (cond ((memq state '(edited added))
(doom-modeline-vcs-icon "nf-dev-git_compare" "🔃" "*" 'doom-modeline-info)) (doom-modeline-vcs-icon "git-compare" "🔃" "*" 'doom-modeline-info -0.05))
((eq state 'needs-merge) ((eq state 'needs-merge)
(doom-modeline-vcs-icon "nf-dev-git_merge" "🔀" "?" 'doom-modeline-info)) (doom-modeline-vcs-icon "git-merge" "🔀" "?" 'doom-modeline-info))
((eq state 'needs-update) ((eq state 'needs-update)
(doom-modeline-vcs-icon "nf-dev-git_pull_request" "" "!" 'doom-modeline-warning)) (doom-modeline-vcs-icon "arrow-down" "" "!" 'doom-modeline-warning))
((memq state '(removed conflict unregistered)) ((memq state '(removed conflict unregistered))
(doom-modeline-icon 'octicon "nf-oct-alert" "" "!" :face 'doom-modeline-urgent)) (doom-modeline-vcs-icon "alert" "" "!" 'doom-modeline-urgent))
(t (t
(doom-modeline-vcs-icon "nf-dev-git_branch" "" "@" 'doom-modeline-info))))))) (doom-modeline-vcs-icon "git-branch" "" "@" 'doom-modeline-info -0.05)))))))
(add-hook 'find-file-hook #'doom-modeline-update-vcs-icon) (add-hook 'find-file-hook #'doom-modeline-update-vcs-icon)
(add-hook 'after-save-hook #'doom-modeline-update-vcs-icon) (add-hook 'after-save-hook #'doom-modeline-update-vcs-icon)
(advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs-icon) (advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs-icon)
@ -702,19 +707,18 @@ Uses `nerd-icons-octicon' to fetch the icon."
(state (vc-state buffer-file-name backend)) (state (vc-state buffer-file-name backend))
(str (if vc-display-status (str (if vc-display-status
(substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2)) (substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2))
"")) "")))
(face (cond ((eq state 'needs-update)
'doom-modeline-warning)
((memq state '(removed conflict unregistered))
'doom-modeline-urgent)
(t 'doom-modeline-info))))
(propertize (if (length> str doom-modeline-vcs-max-length) (propertize (if (length> str doom-modeline-vcs-max-length)
(concat (concat
(substring str 0 (- doom-modeline-vcs-max-length 3)) (substring str 0 (- doom-modeline-vcs-max-length 3))
doom-modeline-ellipsis) doom-modeline-ellipsis)
str) str)
'mouse-face 'doom-modeline-highlight 'mouse-face 'doom-modeline-highlight
'face `(:inherit (,face bold))))))) 'face (cond ((eq state 'needs-update)
'doom-modeline-warning)
((memq state '(removed conflict unregistered))
'doom-modeline-urgent)
(t 'doom-modeline-info)))))))
(add-hook 'find-file-hook #'doom-modeline-update-vcs-text) (add-hook 'find-file-hook #'doom-modeline-update-vcs-text)
(add-hook 'after-save-hook #'doom-modeline-update-vcs-text) (add-hook 'after-save-hook #'doom-modeline-update-vcs-text)
(advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs-text) (advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs-text)
@ -743,8 +747,9 @@ Uses `nerd-icons-octicon' to fetch the icon."
"Displays the checker ICON with FACE. "Displays the checker ICON with FACE.
UNICODE and TEXT are fallbacks. UNICODE and TEXT are fallbacks.
Uses `nerd-icons-mdicon' to fetch the icon." Uses `all-the-icons-material' to fetch the icon."
(doom-modeline-icon 'mdicon icon unicode text :face face)) (doom-modeline-icon 'material icon unicode text
:face face :height 1.0 :v-adjust -0.225))
(defun doom-modeline-checker-text (text &optional face) (defun doom-modeline-checker-text (text &optional face)
"Displays TEXT with FACE." "Displays TEXT with FACE."
@ -779,16 +784,16 @@ level."
('finished (if flycheck-current-errors ('finished (if flycheck-current-errors
(let-alist (doom-modeline--flycheck-count-errors) (let-alist (doom-modeline--flycheck-count-errors)
(doom-modeline-checker-icon (doom-modeline-checker-icon
"nf-md-alert_circle_outline" "" "!" "error_outline" "" "!"
(cond ((> .error 0) 'doom-modeline-urgent) (cond ((> .error 0) 'doom-modeline-urgent)
((> .warning 0) 'doom-modeline-warning) ((> .warning 0) 'doom-modeline-warning)
(t 'doom-modeline-info)))) (t 'doom-modeline-info))))
(doom-modeline-checker-icon "nf-md-check_circle_outline" "" "" 'doom-modeline-info))) (doom-modeline-checker-icon "check" "" "-" 'doom-modeline-info)))
('running (doom-modeline-checker-icon "nf-md-timer_sand" "" "*" 'doom-modeline-debug)) ('running (doom-modeline-checker-icon "hourglass_empty" "" "*" 'doom-modeline-debug))
('no-checker (doom-modeline-checker-icon "nf-md-alert_box_outline" "" "-" 'doom-modeline-debug)) ('no-checker (doom-modeline-checker-icon "sim_card_alert" "" "-" 'doom-modeline-debug))
('errored (doom-modeline-checker-icon "nf-md-alert_circle_outline" "" "!" 'doom-modeline-urgent)) ('errored (doom-modeline-checker-icon "sim_card_alert" "" "-" 'doom-modeline-urgent))
('interrupted (doom-modeline-checker-icon "nf-md-pause_circle_outline" "" "." 'doom-modeline-debug)) ('interrupted (doom-modeline-checker-icon "pause_circle_outline" "" "=" 'doom-modeline-debug))
('suspicious (doom-modeline-checker-icon "nf-md-information_outline" "" "?" 'doom-modeline-debug)) ('suspicious (doom-modeline-checker-icon "info_outline" "" "?" 'doom-modeline-debug))
(_ nil)))) (_ nil))))
(propertize icon (propertize icon
'help-echo (concat "Flycheck\n" 'help-echo (concat "Flycheck\n"
@ -854,8 +859,7 @@ mouse-2: Show help for minor mode")
'doom-modeline-warning) 'doom-modeline-warning)
(doom-modeline-checker-text (number-to-string .info) (doom-modeline-checker-text (number-to-string .info)
'doom-modeline-info)))))) 'doom-modeline-info))))))
('running (and doom-modeline--flycheck-text ;; ('running nil)
(propertize doom-modeline--flycheck-text 'face 'doom-modeline-debug)))
;; ('no-checker nil) ;; ('no-checker nil)
;; ('errored (doom-modeline-checker-text "Error" 'doom-modeline-urgent)) ;; ('errored (doom-modeline-checker-text "Error" 'doom-modeline-urgent))
;; ('interrupted (doom-modeline-checker-text "Interrupted" 'doom-modeline-debug)) ;; ('interrupted (doom-modeline-checker-text "Interrupted" 'doom-modeline-debug))
@ -871,7 +875,7 @@ mouse-2: Show help for minor mode")
(format "error: %d, warning: %d, info: %d\n" .error .warning .info))) (format "error: %d, warning: %d, info: %d\n" .error .warning .info)))
"mouse-1: Show all errors "mouse-1: Show all errors
mouse-3: Next error" mouse-3: Next error"
(when (doom-modeline-mwheel-available-p) (if (doom-modeline-mwheel-available-p)
"\nwheel-up/wheel-down: Previous/next error"))) "\nwheel-up/wheel-down: Previous/next error")))
('running "Checking...") ('running "Checking...")
('no-checker "No Checker") ('no-checker "No Checker")
@ -923,9 +927,9 @@ mouse-3: Next error"
(when-let (when-let
((icon ((icon
(cond (cond
(some-waiting (doom-modeline-checker-icon "nf-md-timer_sand" "" "*" 'doom-modeline-debug)) (some-waiting (doom-modeline-checker-icon "hourglass_empty" "" "*" 'doom-modeline-urgent))
((null known) (doom-modeline-checker-icon "nf-md-alert_box_outline" "" "!" 'doom-modeline-urgent)) ((null known) (doom-modeline-checker-icon "sim_card_alert" "" "-" 'doom-modeline-debug))
(all-disabled (doom-modeline-checker-icon "nf-md-alert_outline" "" "!" 'doom-modeline-warning)) (all-disabled (doom-modeline-checker-icon "sim_card_alert" "" "-" 'doom-modeline-warning))
(t (let ((.error 0) (t (let ((.error 0)
(.warning 0) (.warning 0)
(.note 0)) (.note 0))
@ -943,11 +947,11 @@ mouse-3: Next error"
((> severity note-level) (cl-incf .warning)) ((> severity note-level) (cl-incf .warning))
(t (cl-incf .note)))))) (t (cl-incf .note))))))
(if (> (+ .error .warning .note) 0) (if (> (+ .error .warning .note) 0)
(doom-modeline-checker-icon "nf-md-alert_circle_outline" "" "!" (doom-modeline-checker-icon "error_outline" "" "!"
(cond ((> .error 0) 'doom-modeline-urgent) (cond ((> .error 0) 'doom-modeline-urgent)
((> .warning 0) 'doom-modeline-warning) ((> .warning 0) 'doom-modeline-warning)
(t 'doom-modeline-info))) (t 'doom-modeline-info)))
(doom-modeline-checker-icon "nf-md-check_circle_outline" "" "-" 'doom-modeline-info)))))))) (doom-modeline-checker-icon "check" "" "-" 'doom-modeline-info))))))))
(propertize (propertize
icon icon
'help-echo (concat "Flymake\n" 'help-echo (concat "Flymake\n"
@ -1019,8 +1023,7 @@ mouse-2: Show help for minor mode"
(when-let (when-let
((text ((text
(cond (cond
(some-waiting (and doom-modeline--flymake-text (some-waiting doom-modeline--flymake-text)
(propertize doom-modeline--flymake-text 'face 'doom-modeline-debug)))
((null known) nil) ((null known) nil)
(all-disabled nil) (all-disabled nil)
(t (let ((num (+ .error .warning .note))) (t (let ((num (+ .error .warning .note)))
@ -1159,14 +1162,16 @@ block selection."
'(:inherit (doom-modeline-panel variable-pitch))))) '(:inherit (doom-modeline-panel variable-pitch)))))
(concat (concat
sep sep
(doom-modeline-icon 'mdicon "nf-md-record" "" (doom-modeline-icon 'material "fiber_manual_record" ""
(if (bound-and-true-p evil-this-macro) (if (bound-and-true-p evil-this-macro)
(char-to-string evil-this-macro) (char-to-string evil-this-macro)
"Macro") "Macro")
:face 'doom-modeline-panel) :face 'doom-modeline-panel
:v-adjust -0.225)
vsep vsep
(doom-modeline-icon 'octicon "nf-oct-triangle_right" "" ">" (doom-modeline-icon 'octicon "triangle-right" "" ">"
:face 'doom-modeline-panel) :face 'doom-modeline-panel
:v-adjust -0.05)
sep)))) sep))))
;; `anzu' and `evil-anzu' expose current/total state that can be displayed in the ;; `anzu' and `evil-anzu' expose current/total state that can be displayed in the
@ -1214,8 +1219,7 @@ Requires `anzu', also `evil-anzu' if using `evil-mode' for compatibility with
'face (doom-modeline-face 'doom-modeline-panel)))) 'face (doom-modeline-face 'doom-modeline-panel))))
(defsubst doom-modeline--evil-substitute () (defsubst doom-modeline--evil-substitute ()
"Show number of matches for `evil-ex' in real time. "Show number of matches for evil-ex substitutions and highlights in real time."
The number of matches contains substitutions and highlightings."
(when (and (bound-and-true-p evil-local-mode) (when (and (bound-and-true-p evil-local-mode)
(or (assq 'evil-ex-substitute evil-ex-active-highlights-alist) (or (assq 'evil-ex-substitute evil-ex-active-highlights-alist)
(assq 'evil-ex-global-match evil-ex-active-highlights-alist) (assq 'evil-ex-global-match evil-ex-active-highlights-alist)
@ -1286,7 +1290,8 @@ The number of matches contains substitutions and highlightings."
((cons nil nil))) ((cons nil nil)))
(when count (when count
(concat (propertize " " 'face face) (concat (propertize " " 'face face)
(or (doom-modeline-icon 'faicon "nf-fa-i_cursor" "" "" :face face) (or (doom-modeline-icon 'faicon "i-cursor" nil nil
:face face :v-adjust -0.0575)
(propertize "I" (propertize "I"
'face `(:inherit ,face :height 1.4 :weight normal) 'face `(:inherit ,face :height 1.4 :weight normal)
'display '(raise -0.1))) 'display '(raise -0.1)))
@ -1307,8 +1312,7 @@ The number of matches contains substitutions and highlightings."
'face (doom-modeline-face 'doom-modeline-panel)))))) 'face (doom-modeline-face 'doom-modeline-panel))))))
(defun doom-modeline--override-phi-search (orig-fun &rest args) (defun doom-modeline--override-phi-search (orig-fun &rest args)
"Override the mode-line of `phi-search' and `phi-replace'. "Override the mode-line of `phi-search' and `phi-replace'."
Apply ORIG-FUN with ARGS."
(if (bound-and-true-p doom-modeline-mode) (if (bound-and-true-p doom-modeline-mode)
(apply orig-fun mode-line-format (cdr args)) (apply orig-fun mode-line-format (cdr args))
(apply orig-fun args))) (apply orig-fun args)))
@ -1545,8 +1549,7 @@ Requires `eyebrowse-mode' to be enabled or `tab-bar-mode' tabs to be created."
((name (cond ((name (cond
((and (bound-and-true-p eyebrowse-mode) ((and (bound-and-true-p eyebrowse-mode)
(length> (eyebrowse--get 'window-configs) 1)) (length> (eyebrowse--get 'window-configs) 1))
(setq mode-line-misc-info (assq-delete-all 'eyebrowse-mode mode-line-misc-info)
(assq-delete-all 'eyebrowse-mode mode-line-misc-info))
(when-let* (when-let*
((num (eyebrowse--get 'current-slot)) ((num (eyebrowse--get 'current-slot))
(tag (nth 2 (assoc num (eyebrowse--get 'window-configs))))) (tag (nth 2 (assoc num (eyebrowse--get 'window-configs)))))
@ -1581,16 +1584,15 @@ Requires `eyebrowse-mode' to be enabled or `tab-bar-mode' tabs to be created."
(not (persp-contain-buffer-p (current-buffer) persp))) (not (persp-contain-buffer-p (current-buffer) persp)))
'doom-modeline-persp-buffer-not-in-persp 'doom-modeline-persp-buffer-not-in-persp
'doom-modeline-persp-name)) 'doom-modeline-persp-name))
(icon (doom-modeline-icon 'octicon "nf-oct-repo" "🖿" "#" (icon (doom-modeline-icon 'material "folder" "🖿" "#"
:face `(:inherit ,face :slant normal)))) :face `(:inherit ,face :slant normal)
:height 1.1
:v-adjust -0.225)))
(when (or doom-modeline-display-default-persp-name (when (or doom-modeline-display-default-persp-name
(not (string-equal persp-nil-name name))) (not (string-equal persp-nil-name name)))
(concat " " (concat (doom-modeline-spc)
(propertize (concat (and doom-modeline-persp-icon (propertize (concat (and doom-modeline-persp-icon
(concat icon (concat icon (doom-modeline-vspc)))
(propertize
" "
'display '((space :relative-width 0.5)))))
(propertize name 'face face)) (propertize name 'face face))
'help-echo "mouse-1: Switch perspective 'help-echo "mouse-1: Switch perspective
mouse-2: Show help for minor mode" mouse-2: Show help for minor mode"
@ -1603,7 +1605,7 @@ mouse-2: Show help for minor mode"
(interactive) (interactive)
(describe-function 'persp-mode))) (describe-function 'persp-mode)))
map)) map))
" ")))))) (doom-modeline-spc)))))))
(add-hook 'buffer-list-update-hook #'doom-modeline-update-persp-name) (add-hook 'buffer-list-update-hook #'doom-modeline-update-persp-name)
(add-hook 'find-file-hook #'doom-modeline-update-persp-name) (add-hook 'find-file-hook #'doom-modeline-update-persp-name)
@ -1744,12 +1746,13 @@ mouse-1: Display Line and Column Mode Menu"
"Display the model icon with FACE and HELP-ECHO. "Display the model icon with FACE and HELP-ECHO.
TEXT is alternative if icon is not available." TEXT is alternative if icon is not available."
(propertize (doom-modeline-icon (propertize (doom-modeline-icon
'mdicon 'material
(when doom-modeline-modal-icon (when doom-modeline-modal-icon
(or icon "nf-md-record")) (or icon "fiber_manual_record"))
(or unicode "") (or unicode "")
text text
:face (doom-modeline-face face)) :face (doom-modeline-face face)
:v-adjust -0.225)
'help-echo help-echo)) 'help-echo help-echo))
(defsubst doom-modeline--evil () (defsubst doom-modeline--evil ()
@ -1767,47 +1770,29 @@ TEXT is alternative if icon is not available."
((evil-operator-state-p) 'doom-modeline-evil-operator-state) ((evil-operator-state-p) 'doom-modeline-evil-operator-state)
((evil-replace-state-p) 'doom-modeline-evil-replace-state) ((evil-replace-state-p) 'doom-modeline-evil-replace-state)
(t 'doom-modeline-evil-normal-state)) (t 'doom-modeline-evil-normal-state))
(evil-state-property evil-state :name t) (evil-state-property evil-state :name t))))
(cond
((evil-normal-state-p) "nf-md-alpha_n_circle")
((evil-emacs-state-p) "nf-md-alpha_e_circle")
((evil-insert-state-p) "nf-md-alpha_i_circle")
((evil-motion-state-p) "nf-md-alpha_m_circle")
((evil-visual-state-p) "nf-md-alpha_v_circle")
((evil-operator-state-p) "nf-md-alpha_o_circle")
((evil-replace-state-p) "nf-md-alpha_r_circle")
(t "nf-md-alpha_n_circle"))
(cond
((evil-normal-state-p) "🅝")
((evil-emacs-state-p) "🅔")
((evil-insert-state-p) "🅘")
((evil-motion-state-p) "🅜")
((evil-visual-state-p) "🅥")
((evil-operator-state-p) "🅞")
((evil-replace-state-p) "🅡")
(t "🅝")))))
(defsubst doom-modeline--overwrite () (defsubst doom-modeline--overwrite ()
"The current overwrite state which is enabled by command `overwrite-mode'." "The current overwrite state which is enabled by command `overwrite-mode'."
(when (and (bound-and-true-p overwrite-mode) (when (and (bound-and-true-p overwrite-mode)
(not (bound-and-true-p evil-local-mode))) (not (bound-and-true-p evil-local-mode)))
(doom-modeline--modal-icon (doom-modeline--modal-icon
"<W>" 'doom-modeline-overwrite "Overwrite mode" "<O>" 'doom-modeline-overwrite "Overwrite mode"
"nf-md-note_edit" "🅦"))) "border_color" "🧷")))
(defsubst doom-modeline--god () (defsubst doom-modeline--god ()
"The current god state which is enabled by the command `god-mode'." "The current god state which is enabled by the command `god-mode'."
(when (bound-and-true-p god-local-mode) (when (bound-and-true-p god-local-mode)
(doom-modeline--modal-icon (doom-modeline--modal-icon
"<G>" 'doom-modeline-god "God mode" "<G>" 'doom-modeline-god "God mode"
"nf-md-account_circle" "🅖"))) "account_circle" "🙇")))
(defsubst doom-modeline--ryo () (defsubst doom-modeline--ryo ()
"The current ryo-modal state which is enabled by the command `ryo-modal-mode'." "The current ryo-modal state which is enabled by the command `ryo-modal-mode'."
(when (bound-and-true-p ryo-modal-mode) (when (bound-and-true-p ryo-modal-mode)
(doom-modeline--modal-icon (doom-modeline--modal-icon
"<R>" 'doom-modeline-ryo "Ryo modal" "<R>" 'doom-modeline-ryo "Ryo modal"
"nf-md-star_circle" ""))) "add_circle" "")))
(defsubst doom-modeline--xah-fly-keys () (defsubst doom-modeline--xah-fly-keys ()
"The current `xah-fly-keys' state." "The current `xah-fly-keys' state."
@ -1815,10 +1800,10 @@ TEXT is alternative if icon is not available."
(if xah-fly-insert-state-p (if xah-fly-insert-state-p
(doom-modeline--modal-icon (doom-modeline--modal-icon
"<I>" 'doom-modeline-fly-insert-state "Xah-fly insert mode" "<I>" 'doom-modeline-fly-insert-state "Xah-fly insert mode"
"nf-md-airplane_edit" "🛧") "flight" "🛧")
(doom-modeline--modal-icon (doom-modeline--modal-icon
"<C>" 'doom-modeline-fly-normal-state "Xah-fly command mode" "<C>" 'doom-modeline-fly-normal-state "Xah-fly command mode"
"nf-md-airplane_cog" "🛧")))) "flight" "🛧"))))
(defsubst doom-modeline--boon () (defsubst doom-modeline--boon ()
"The current Boon state. Requires `boon-mode' to be enabled." "The current Boon state. Requires `boon-mode' to be enabled."
@ -1832,7 +1817,7 @@ TEXT is alternative if icon is not available."
(boon-off-state 'doom-modeline-boon-off-state) (boon-off-state 'doom-modeline-boon-off-state)
(t 'doom-modeline-boon-off-state)) (t 'doom-modeline-boon-off-state))
(boon-modeline-string) (boon-modeline-string)
"nf-md-coffee" "🍵"))) "local_cafe" "🍵")))
(defsubst doom-modeline--meow () (defsubst doom-modeline--meow ()
"The current Meow state. Requires `meow-mode' to be enabled." "The current Meow state. Requires `meow-mode' to be enabled."
@ -1961,7 +1946,8 @@ mouse-3: Describe current input method")
(defun doom-modeline-repl-icon (text face) (defun doom-modeline-repl-icon (text face)
"Display REPL icon (or TEXT in terminal) with FACE." "Display REPL icon (or TEXT in terminal) with FACE."
(doom-modeline-icon 'faicon "nf-fa-terminal" "$" text :face face)) (doom-modeline-icon 'faicon "terminal" "$" text
:face face :height 1.0 :v-adjust -0.0575))
(defvar doom-modeline--cider nil) (defvar doom-modeline--cider nil)
@ -2009,7 +1995,8 @@ mouse-3: Describe current input method")
(defun doom-modeline-lsp-icon (text face) (defun doom-modeline-lsp-icon (text face)
"Display LSP icon (or TEXT in terminal) with FACE." "Display LSP icon (or TEXT in terminal) with FACE."
(doom-modeline-icon 'octicon "nf-oct-rocket" "🚀" text :face face)) (doom-modeline-icon 'faicon "rocket" "🚀" text
:face face :height 1.0 :v-adjust -0.0575))
(defvar-local doom-modeline--lsp nil) (defvar-local doom-modeline--lsp nil)
(defun doom-modeline-update-lsp (&rest _) (defun doom-modeline-update-lsp (&rest _)
@ -2202,14 +2189,11 @@ Example:
(with-timeout (10) (with-timeout (10)
(ignore-errors (ignore-errors
(when-let* ((username (ghub--username ghub-default-host)) (when-let* ((username (ghub--username ghub-default-host))
(token (or (ghub--token ghub-default-host username 'forge t) (token (ghub--token ghub-default-host username 'ghub t)))
(ghub--token ghub-default-host username 'ghub t)))) (ghub-get "/notifications" nil
(ghub-get "/notifications" :query '((notifications . "true"))
'((all . t))
:host ghub-default-host
:username username :username username
:auth token :auth token
:unpaginate t
:noerror t)))))) :noerror t))))))
(lambda (result) (lambda (result)
(message "") ; suppress message (message "") ; suppress message
@ -2239,19 +2223,21 @@ Example:
"The GitHub notifications." "The GitHub notifications."
(when (and doom-modeline-github (when (and doom-modeline-github
(doom-modeline--segment-visible 'github) (doom-modeline--segment-visible 'github)
(numberp doom-modeline--github-notification-number)) (numberp doom-modeline--github-notification-number)
(> doom-modeline--github-notification-number 0))
(concat (concat
(doom-modeline-spc) (doom-modeline-spc)
(propertize (propertize
(concat (concat
(doom-modeline-icon 'octicon "nf-oct-mark_github" "🔔" "&" (doom-modeline-icon 'faicon "github" "🔔" "#"
:face 'doom-modeline-notification) :face 'doom-modeline-notification
(and (> doom-modeline--github-notification-number 0) (doom-modeline-vspc)) :v-adjust -0.0575)
(doom-modeline-vspc)
;; GitHub API is paged, and the limit is 50
(propertize (propertize
(cond (if (>= doom-modeline--github-notification-number 50)
((<= doom-modeline--github-notification-number 0) "") "50+"
((> doom-modeline--github-notification-number 99) "99+") (number-to-string doom-modeline--github-notification-number))
(t (number-to-string doom-modeline--github-notification-number)))
'face '(:inherit 'face '(:inherit
(doom-modeline-unread-number doom-modeline-notification)))) (doom-modeline-unread-number doom-modeline-notification))))
'help-echo "Github Notifications 'help-echo "Github Notifications
@ -2302,9 +2288,9 @@ mouse-3: Fetch notifications"
(add-hook 'dap-session-created-hook #'doom-modeline--debug-visual) (add-hook 'dap-session-created-hook #'doom-modeline--debug-visual)
(add-hook 'dap-terminated-hook #'doom-modeline--normal-visual) (add-hook 'dap-terminated-hook #'doom-modeline--normal-visual)
(defun doom-modeline-debug-icon (face) (defun doom-modeline-debug-icon (face &rest args)
"Display debug icon with FACE and ARGS." "Display debug icon with FACE and ARGS."
(doom-modeline-icon 'codicon "nf-cod-debug" "🐛" "!" :face face)) (doom-modeline-icon 'faicon "bug" "🐛" "!" :face face :v-adjust -0.0575 args))
(defun doom-modeline--debug-dap () (defun doom-modeline--debug-dap ()
"The current `dap-mode' state." "The current `dap-mode' state."
@ -2411,16 +2397,14 @@ mouse-1: Toggle Debug on Quit"
;; ;;
;; `mu4e' notifications ;; `mu4e-alert' notifications
;; ;;
(doom-modeline-def-segment mu4e (doom-modeline-def-segment mu4e
"Show notifications of any unread emails in `mu4e'." "Show notifications of any unread emails in `mu4e'."
(when (and doom-modeline-mu4e (when (and doom-modeline-mu4e
(doom-modeline--segment-visible 'mu4e)) (doom-modeline--segment-visible 'mu4e)
(let ((icon (doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" (bound-and-true-p mu4e-alert-mode-line)
:face 'doom-modeline-notification)))
(cond ((and (bound-and-true-p mu4e-alert-mode-line)
(numberp mu4e-alert-mode-line) (numberp mu4e-alert-mode-line)
;; don't display if the unread mails count is zero ;; don't display if the unread mails count is zero
(> mu4e-alert-mode-line 0)) (> mu4e-alert-mode-line 0))
@ -2428,7 +2412,9 @@ mouse-1: Toggle Debug on Quit"
(doom-modeline-spc) (doom-modeline-spc)
(propertize (propertize
(concat (concat
icon (doom-modeline-icon 'material "email" "📧" "#"
:face 'doom-modeline-notification
:height 1.1 :v-adjust -0.2)
(doom-modeline-vspc) (doom-modeline-vspc)
(propertize (propertize
(if (> mu4e-alert-mode-line doom-modeline-number-limit) (if (> mu4e-alert-mode-line doom-modeline-number-limit)
@ -2446,20 +2432,11 @@ mouse-1: Toggle Debug on Quit"
(format "You have %s unread emails" mu4e-alert-mode-line)) (format "You have %s unread emails" mu4e-alert-mode-line))
"\nClick here to view " "\nClick here to view "
(if (= mu4e-alert-mode-line 1) "it" "them"))) (if (= mu4e-alert-mode-line 1) "it" "them")))
(doom-modeline-spc))) (doom-modeline-spc))))
((bound-and-true-p mu4e-modeline-mode)
(concat
(doom-modeline-spc)
icon
(doom-modeline-vspc)
(propertize (mu4e--modeline-string)
'face 'doom-modeline-notification)
(doom-modeline-spc)))))))
(defun doom-modeline-override-mu4e-alert (&rest _) (defun doom-modeline-override-mu4e-alert (&rest _)
"Delete `mu4e-alert-mode-line' from global modeline string." "Delete `mu4e-alert-mode-line' from global modeline string."
(when (and (featurep 'mu4e-alert) (when (featurep 'mu4e-alert)
(bound-and-true-p mu4e-alert-mode-line))
(if (and doom-modeline-mu4e (if (and doom-modeline-mu4e
(bound-and-true-p doom-modeline-mode)) (bound-and-true-p doom-modeline-mode))
;; Delete original modeline ;; Delete original modeline
@ -2473,26 +2450,12 @@ mouse-1: Toggle Debug on Quit"
:after #'doom-modeline-override-mu4e-alert) :after #'doom-modeline-override-mu4e-alert)
(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-alert) (add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-alert)
(defun doom-modeline-override-mu4e-modeline (&rest _)
"Delete `mu4e-alert-mode-line' from global modeline string."
(when (bound-and-true-p mu4e-modeline-mode)
(if (and doom-modeline-mu4e
(bound-and-true-p doom-modeline-mode))
;; Delete original modeline
(setq global-mode-string
(delete mu4e--modeline-item global-mode-string))
;; Recover default settings
(add-to-list 'global-mode-string mu4e--modeline-item))))
(add-hook 'mu4e-modeline-mode-hook #'doom-modeline-override-mu4e-modeline)
(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-modeline)
(doom-modeline-add-variable-watcher (doom-modeline-add-variable-watcher
'doom-modeline-mu4e 'doom-modeline-mu4e
(lambda (_sym val op _where) (lambda (_sym val op _where)
(when (eq op 'set) (when (eq op 'set)
(setq doom-modeline-mu4e val) (setq doom-modeline-mu4e val)
(doom-modeline-override-mu4e-alert) (doom-modeline-override-mu4e-alert))))
(doom-modeline-override-mu4e-modeline))))
;; ;;
@ -2554,8 +2517,9 @@ mouse-1: Toggle Debug on Quit"
(doom-modeline-spc) (doom-modeline-spc)
(propertize (propertize
(concat (concat
(doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" (doom-modeline-icon 'material "email" "📧" "#"
:face 'doom-modeline-notification) :face 'doom-modeline-notification
:height 1.1 :v-adjust -0.2)
(doom-modeline-vspc) (doom-modeline-vspc)
(propertize (propertize
(if (> doom-modeline--gnus-unread-mail doom-modeline-number-limit) (if (> doom-modeline--gnus-unread-mail doom-modeline-number-limit)
@ -2658,8 +2622,9 @@ to be an icon and we don't want to remove that so we just return the original."
(doom-modeline-spc) (doom-modeline-spc)
(propertize (concat (propertize (concat
(doom-modeline-icon 'mdicon "nf-md-message_processing" "🗊" "#" (doom-modeline-icon 'material "message" "🗊" "#"
:face 'doom-modeline-notification) :face 'doom-modeline-notification
:height 1.0 :v-adjust -0.225)
(doom-modeline-vspc) (doom-modeline-vspc)
;; Display the number of unread buffers ;; Display the number of unread buffers
(propertize (number-to-string number) (propertize (number-to-string number)
@ -2733,13 +2698,6 @@ mouse-3: Switch to next unread buffer")))
;; Battery status ;; Battery status
;; ;;
(defun doom-modeline-battery-icon (icon unicode text face)
"Displays the battery ICON with FACE.
UNICODE and TEXT are fallbacks.
Uses `nerd-icons-mdicon' to fetch the icon."
(doom-modeline-icon 'mdicon icon unicode text :face face))
(defvar doom-modeline--battery-status nil) (defvar doom-modeline--battery-status nil)
(defun doom-modeline-update-battery-status () (defun doom-modeline-update-battery-status ()
"Update battery status." "Update battery status."
@ -2749,9 +2707,7 @@ Uses `nerd-icons-mdicon' to fetch the icon."
(let* ((data (and battery-status-function (let* ((data (and battery-status-function
(functionp battery-status-function) (functionp battery-status-function)
(funcall battery-status-function))) (funcall battery-status-function)))
(status (cdr (assoc ?L data))) (charging? (string-equal "AC" (cdr (assoc ?L data))))
(charging? (or (string-equal "AC" status)
(string-equal "on-line" status)))
(percentage (car (read-from-string (or (cdr (assq ?p data)) "ERR")))) (percentage (car (read-from-string (or (cdr (assq ?p data)) "ERR"))))
(valid-percentage? (and (numberp percentage) (valid-percentage? (and (numberp percentage)
(>= percentage 0) (>= percentage 0)
@ -2764,62 +2720,25 @@ Uses `nerd-icons-mdicon' to fetch the icon."
(t 'doom-modeline-battery-full)) (t 'doom-modeline-battery-full))
'doom-modeline-battery-error)) 'doom-modeline-battery-error))
(icon (if valid-percentage? (icon (if valid-percentage?
(cond (cond (charging?
((>= percentage 100) (doom-modeline-icon 'alltheicon "battery-charging" "🔋" "+"
(doom-modeline-battery-icon (if charging? :face face :height 1.4 :v-adjust -0.1))
"nf-md-battery_charging_100" ((> percentage 95)
"nf-md-battery") (doom-modeline-icon 'faicon "battery-full" "🔋" "-"
"🔋" "-" face)) :face face :v-adjust -0.0575))
((>= percentage 90) ((> percentage 70)
(doom-modeline-battery-icon (if charging? (doom-modeline-icon 'faicon "battery-three-quarters" "🔋" "-"
"nf-md-battery_charging_90" :face face :v-adjust -0.0575))
"nf-md-battery_90") ((> percentage 40)
"🔋" "-" face)) (doom-modeline-icon 'faicon "battery-half" "🔋" "-"
((>= percentage 80) :face face :v-adjust -0.0575))
(doom-modeline-battery-icon (if charging? ((> percentage battery-load-critical)
"nf-md-battery_charging_80" (doom-modeline-icon 'faicon "battery-quarter" "🔋" "-"
"nf-md-battery_80") :face face :v-adjust -0.0575))
"🔋" "-" face)) (t (doom-modeline-icon 'faicon "battery-empty" "🔋" "!"
((>= percentage 70) :face face :v-adjust -0.0575)))
(doom-modeline-battery-icon (if charging? (doom-modeline-icon 'faicon "battery-empty" "" "N/A"
"nf-md-battery_charging_70" :face face :v-adjust -0.0575)))
"nf-md-battery_70")
"🔋" "-" face))
((>= percentage 60)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_60"
"nf-md-battery_60")
"🔋" "-" face))
((>= percentage 50)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_50"
"nf-md-battery_50")
"🔋" "-" face))
((>= percentage 40)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_40"
"nf-md-battery_40")
"🔋" "-" face))
((>= percentage 30)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_30"
"nf-md-battery_30")
"🔋" "-" face))
((>= percentage 20)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_20"
"nf-md-battery_20")
"🔋" "-" face))
((>= percentage 10)
(doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_10"
"nf-md-battery_10")
"🪫" "-" face))
(t (doom-modeline-battery-icon (if charging?
"nf-md-battery_charging_outline"
"nf-md-battery_outline")
"🪫" "!" face)))
(doom-modeline-battery-icon "nf-md-battery_alert" "" "N/A" face)))
(text (if valid-percentage? (format "%d%s" percentage "%%") "")) (text (if valid-percentage? (format "%d%s" percentage "%%") ""))
(help-echo (if (and battery-echo-area-format data valid-percentage?) (help-echo (if (and battery-echo-area-format data valid-percentage?)
(battery-format battery-echo-area-format data) (battery-format battery-echo-area-format data)
@ -2892,11 +2811,13 @@ Uses `nerd-icons-mdicon' to fetch the icon."
(when (and doom-modeline-icon doom-modeline-major-mode-icon) (when (and doom-modeline-icon doom-modeline-major-mode-icon)
(concat (concat
(doom-modeline-spc) (doom-modeline-spc)
(doom-modeline-icon 'faicon "nf-fa-archive" nil nil (doom-modeline-icon 'faicon "archive" nil nil
:face (doom-modeline-face :face (doom-modeline-face
(if doom-modeline-major-mode-color-icon (if doom-modeline-major-mode-color-icon
'nerd-icons-silver 'all-the-icons-silver
'mode-line))))) 'mode-line))
:height 1.0
:v-adjust -0.0575)))
(doom-modeline-display-text (doom-modeline-display-text
(format-mode-line 'mode-line-buffer-identification)))) (format-mode-line 'mode-line-buffer-identification))))
@ -2924,10 +2845,12 @@ The cdr can also be a function that returns a name to use.")
(doom-modeline-spc) (doom-modeline-spc)
(when doom-modeline-icon (when doom-modeline-icon
(concat (concat
(doom-modeline-icon 'sucicon "nf-custom-emacs" nil nil (doom-modeline-icon 'fileicon "elisp" nil nil
:face (doom-modeline-face :face (doom-modeline-face
(and doom-modeline-major-mode-color-icon (and doom-modeline-major-mode-color-icon
'nerd-icons-blue))) 'all-the-icons-blue))
:height 1.0
:v-adjust -0.15)
(doom-modeline-spc))) (doom-modeline-spc)))
(propertize (propertize
(let ((custom (cdr (assoc (buffer-name) doom-modeline--helm-buffer-ids))) (let ((custom (cdr (assoc (buffer-name) doom-modeline--helm-buffer-ids)))
@ -3008,12 +2931,15 @@ The cdr can also be a function that returns a name to use.")
(let ((face (doom-modeline-face (let ((face (doom-modeline-face
(if grip--process (if grip--process
(pcase (process-status grip--process) (pcase (process-status grip--process)
('run 'doom-modeline-info) ('run 'doom-modeline-buffer-path)
('exit 'doom-modeline-warning) ('exit 'doom-modeline-warning)
(_ 'doom-modeline-urgent)) (_ 'doom-modeline-urgent))
'doom-modeline-urgent)))) 'doom-modeline-urgent))))
(propertize (propertize (doom-modeline-icon 'material "pageview" "🗐" "@"
(doom-modeline-icon 'codicon "nf-cod-open_preview" "🗐" "@" :face face) :face (if doom-modeline-icon
`(:inherit ,face :weight normal)
face)
:height 1.2 :v-adjust -0.2)
'help-echo (format "Preview on %s 'help-echo (format "Preview on %s
mouse-1: Preview in browser mouse-1: Preview in browser
mouse-2: Stop preview mouse-2: Stop preview
@ -3056,15 +2982,16 @@ mouse-3: Restart preview"
(doom-modeline-spc) (doom-modeline-spc)
(when doom-modeline-time-icon (when doom-modeline-time-icon
(concat (concat
(doom-modeline-icon 'octicon "nf-oct-clock" "" "" (doom-modeline-icon 'octicon "calendar" "📅" ""
:face '(:inherit doom-modeline-time :weight normal)) :face 'doom-modeline-time
:v-adjust -0.05)
(and (or doom-modeline-icon doom-modeline-unicode-fallback) (and (or doom-modeline-icon doom-modeline-unicode-fallback)
(doom-modeline-spc)))) (doom-modeline-spc))))
(propertize display-time-string (propertize display-time-string
'face (doom-modeline-face 'doom-modeline-time))))) 'face (doom-modeline-face 'doom-modeline-time)))))
(defun doom-modeline-override-time () (defun doom-modeline-override-time ()
"Override default `display-time' mode-line." "Override default display-time mode-line."
(or global-mode-string (setq global-mode-string '(""))) (or global-mode-string (setq global-mode-string '("")))
(if (and doom-modeline-time (if (and doom-modeline-time
(bound-and-true-p doom-modeline-mode)) (bound-and-true-p doom-modeline-mode))

View file

@ -0,0 +1,249 @@
;;; doom-modeline.el --- A minimal and modern mode-line -*- lexical-binding: t; -*-
;; Copyright (C) 2018-2020 Vincent Zhang
;; Author: Vincent Zhang <seagle0128@gmail.com>
;; Homepage: https://github.com/seagle0128/doom-modeline
;; Version: 3.3.3
;; Package-Requires: ((emacs "25.1") (compat "28.1.1.1") (shrink-path "0.2.0"))
;; Keywords: faces mode-line
;; This file is not part of GNU Emacs.
;;
;; 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:
;;
;; This package offers a fancy and fast mode-line inspired by minimalism design.
;;
;; It's integrated into Doom Emacs (https://github.com/hlissner/doom-emacs) and
;; Centaur Emacs (https://github.com/seagle0128/.emacs.d).
;;
;; The doom-modeline offers:
;; - A match count panel (for anzu, iedit, multiple-cursors, symbol-overlay,
;; evil-search and evil-substitute)
;; - An indicator for recording a macro
;; - Current environment version (e.g. python, ruby, go, etc.) in the major-mode
;; - A customizable mode-line height (see doom-modeline-height)
;; - A minor modes segment which is compatible with minions
;; - An error/warning count segment for flymake/flycheck
;; - A workspace number segment for eyebrowse
;; - A perspective name segment for persp-mode
;; - A window number segment for winum and window-numbering
;; - An indicator for modal editing state, including evil, overwrite, god, ryo
;; and xah-fly-keys, etc.
;; - An indicator for battery status
;; - An indicator for current input method
;; - An indicator for debug state
;; - An indicator for remote host
;; - An indicator for LSP state with lsp-mode or eglot
;; - An indicator for github notifications
;; - An indicator for unread emails with mu4e-alert
;; - An indicator for unread emails with gnus (basically builtin)
;; - An indicator for irc notifications with circe, rcirc or erc.
;; - An indicator for buffer position which is compatible with nyan-mode or poke-line
;; - An indicator for party parrot
;; - An indicator for PDF page number with pdf-tools
;; - An indicator for markdown/org previews with grip
;; - Truncated file name, file icon, buffer state and project name in buffer
;; information segment, which is compatible with project, find-file-in-project
;; and projectile
;; - New mode-line for Info-mode buffers
;; - New package mode-line for paradox
;; - New mode-line for helm buffers
;; - New mode-line for git-timemachine buffers
;;
;; Installation:
;; From melpa, `M-x package-install RET doom-modeline RET`.
;; In `init.el`,
;; (require 'doom-modeline)
;; (doom-modeline-mode 1)
;; or
;; (use-package doom-modeline
;; :ensure t
;; :hook (after-init . doom-modeline-mode))
;;
;;; Code:
(require 'doom-modeline-core)
(require 'doom-modeline-segments)
;;
;; Mode lines
;;
(doom-modeline-def-modeline 'main
'(bar workspace-name window-number modals matches follow buffer-info remote-host buffer-position word-count parrot selection-info)
'(compilation objed-state misc-info persp-name battery grip irc mu4e gnus github debug repl lsp minor-modes input-method indent-info buffer-encoding major-mode process vcs checker time))
(doom-modeline-def-modeline 'minimal
'(bar matches buffer-info-simple)
'(media-info major-mode time))
(doom-modeline-def-modeline 'special
'(bar window-number modals matches buffer-info remote-host buffer-position word-count parrot selection-info)
'(compilation objed-state misc-info battery irc-buffers debug minor-modes input-method indent-info buffer-encoding major-mode process time))
(doom-modeline-def-modeline 'project
'(bar window-number modals buffer-default-directory remote-host buffer-position)
'(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time))
(doom-modeline-def-modeline 'dashboard
'(bar window-number buffer-default-directory-simple remote-host)
'(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time))
(doom-modeline-def-modeline 'vcs
'(bar window-number modals matches buffer-info remote-host buffer-position parrot selection-info)
'(compilation misc-info battery irc mu4e gnus github debug minor-modes buffer-encoding major-mode process time))
(doom-modeline-def-modeline 'package
'(bar window-number package)
'(compilation misc-info major-mode process time))
(doom-modeline-def-modeline 'info
'(bar window-number buffer-info info-nodes buffer-position parrot selection-info)
'(compilation misc-info buffer-encoding major-mode time))
(doom-modeline-def-modeline 'media
'(bar window-number buffer-size buffer-info)
'(compilation misc-info media-info major-mode process vcs time))
(doom-modeline-def-modeline 'message
'(bar window-number modals matches buffer-info-simple buffer-position word-count parrot selection-info)
'(compilation objed-state misc-info battery debug minor-modes input-method indent-info buffer-encoding major-mode time))
(doom-modeline-def-modeline 'pdf
'(bar window-number matches buffer-info pdf-pages)
'(compilation misc-info major-mode process vcs time))
(doom-modeline-def-modeline 'org-src
'(bar window-number modals matches buffer-info buffer-position word-count parrot selection-info)
'(compilation objed-state misc-info debug lsp minor-modes input-method indent-info buffer-encoding major-mode process checker time))
(doom-modeline-def-modeline 'helm
'(bar helm-buffer-id helm-number helm-follow helm-prefix-argument)
'(helm-help time))
(doom-modeline-def-modeline 'timemachine
'(bar window-number modals matches git-timemachine buffer-position word-count parrot selection-info)
'(misc-info minor-modes indent-info buffer-encoding major-mode time))
(doom-modeline-def-modeline 'calculator
'(window-number modals matches calc buffer-position)
'(misc-info minor-modes major-mode process))
;;
;; Interfaces
;;
;;;###autoload
(defun doom-modeline-set-main-modeline (&optional default)
"Set main mode-line.
If DEFAULT is non-nil, set the default mode-line for all buffers."
(doom-modeline-set-modeline 'main default))
;;
;; Minor mode
;;
;; Suppress warnings
(defvar 2C-mode-line-format)
(defvar helm-ag-show-status-function)
(declare-function helm-display-mode-line "ext:helm-core")
(defvar doom-modeline-mode-map (make-sparse-keymap))
(defvar doom-modeline-mode-alist
'((message-mode . message)
(git-commit-mode . message)
(magit-mode . vcs)
(dashboard-mode . dashboard)
(Info-mode . info)
(image-mode . media)
(pdf-view-mode . pdf)
(org-src-mode . org-src)
(paradox-menu-mode . package)
(xwidget-webkit-mode . minimal)
(git-timemachine-mode . timemachine)
(calc-mode . calculator)
(calc-trail-mode . calculator)
(circe-mode . special)
(erc-mode . special)
(rcirc-mode . special))
"Alist of major modes and mode-lines.")
(defun doom-modeline-auto-set-modeline ()
"Set mode-line base on major-mode."
(catch 'found
(dolist (x doom-modeline-mode-alist)
(when (derived-mode-p (car x))
(doom-modeline-set-modeline (cdr x))
(throw 'found x)))))
(defun doom-modeline-set-helm-modeline (&rest _) ; To advice helm
"Set helm mode-line."
(doom-modeline-set-modeline 'helm))
;;;###autoload
(define-minor-mode doom-modeline-mode
"Toggle `doom-modeline' on or off."
:group 'doom-modeline
:global t
:lighter nil
:keymap doom-modeline-mode-map
(if doom-modeline-mode
(progn
(doom-modeline-refresh-bars) ; Create bars
(doom-modeline-set-main-modeline t) ; Set default mode-line
;; Apply to all existing buffers.
(dolist (buf (buffer-list))
(with-current-buffer buf
(unless (doom-modeline-auto-set-modeline)
(doom-modeline-set-main-modeline))))
;; For two-column editing
(setq 2C-mode-line-format (doom-modeline 'special))
;; Automatically set mode-lines
(add-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline)
;; Special handles
(advice-add #'helm-display-mode-line :after #'doom-modeline-set-helm-modeline)
(setq helm-ag-show-status-function #'doom-modeline-set-helm-modeline))
(progn
;; Restore mode-line
(let ((original-format (doom-modeline--original-value 'mode-line-format)))
(setq-default mode-line-format original-format)
(dolist (buf (buffer-list))
(with-current-buffer buf
(setq mode-line-format original-format))))
;; For two-column editing
(setq 2C-mode-line-format (doom-modeline--original-value '2C-mode-line-format))
;; Cleanup
(remove-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline)
(advice-remove #'helm-display-mode-line #'doom-modeline-set-helm-modeline)
(setq helm-ag-show-status-function (default-value 'helm-ag-show-status-function)))))
(provide 'doom-modeline)
;;; doom-modeline.el ends here

View file

@ -57,10 +57,6 @@ search.
(register-definition-prefixes "elisp-refs" '("elisp-")) (register-definition-prefixes "elisp-refs" '("elisp-"))
;;;***
;;;### (autoloads nil nil ("elisp-refs-pkg.el") (0 0 0 0))
;;;*** ;;;***
;; Local Variables: ;; Local Variables:

View file

@ -0,0 +1,2 @@
;;; Generated package description from elisp-refs.el -*- no-byte-compile: t -*-
(define-package "elisp-refs" "20220704.2141" "find callers of elisp functions or macros" '((dash "2.12.0") (s "1.11.0")) :commit "af73739084637c8ebadad337a8fe58ff4f1d2ec1" :authors '(("Wilfred Hughes" . "me@wilfred.me.uk")) :maintainer '("Wilfred Hughes" . "me@wilfred.me.uk") :keywords '("lisp"))

View file

@ -3,7 +3,9 @@
;; Copyright (C) 2016-2020 Wilfred Hughes <me@wilfred.me.uk> ;; Copyright (C) 2016-2020 Wilfred Hughes <me@wilfred.me.uk>
;; Author: Wilfred Hughes <me@wilfred.me.uk> ;; Author: Wilfred Hughes <me@wilfred.me.uk>
;; Version: 1.6 ;; Version: 1.5
;; Package-Version: 20220704.2141
;; Package-Commit: af73739084637c8ebadad337a8fe58ff4f1d2ec1
;; Keywords: lisp ;; Keywords: lisp
;; Package-Requires: ((dash "2.12.0") (s "1.11.0")) ;; Package-Requires: ((dash "2.12.0") (s "1.11.0"))
@ -37,10 +39,6 @@
(require 'format) (require 'format)
(eval-when-compile (require 'cl-lib)) (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 ;;; Internal
(defvar elisp-refs-verbose t) (defvar elisp-refs-verbose t)
@ -69,7 +67,7 @@ in the current buffer."
between START-POS and END-POS (inclusive) in BUFFER. between START-POS and END-POS (inclusive) in BUFFER.
Positions exclude quote characters, so given 'foo or `foo, we Positions exclude quote characters, so given 'foo or `foo, we
report the position of the symbol foo. report the position of the f.
Not recursive, so we don't consider subelements of nested sexps." Not recursive, so we don't consider subelements of nested sexps."
(let ((positions nil)) (let ((positions nil))
@ -91,25 +89,18 @@ Not recursive, so we don't consider subelements of nested sexps."
(scan-error nil))) (scan-error nil)))
(nreverse positions))) (nreverse positions)))
(defun elisp-refs--read-buffer-form (symbols-with-pos) (defun elisp-refs--read-buffer-form ()
"Read a form from the current buffer, starting at point. "Read a form from the current buffer, starting at point.
Returns a list: Returns a list:
\(form form-start-pos form-end-pos symbol-positions read-start-pos) \(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 are 0-indexed, relative to READ-START-POS."
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) (let* ((read-with-symbol-positions t)
(read-start-pos (point)) (read-start-pos (point))
(form (if (and symbols-with-pos (fboundp 'read-positioning-symbols)) (form (read (current-buffer)))
(read-positioning-symbols (current-buffer))
(read (current-buffer))))
(symbols (if (boundp 'read-symbol-positions-list) (symbols (if (boundp 'read-symbol-positions-list)
read-symbol-positions-list read-symbol-positions-list
nil)) (read-positioning-symbols (current-buffer))))
(end-pos (point)) (end-pos (point))
(start-pos (elisp-refs--start-pos end-pos))) (start-pos (elisp-refs--start-pos end-pos)))
(list form start-pos end-pos symbols read-start-pos))) (list form start-pos end-pos symbols read-start-pos)))
@ -118,14 +109,14 @@ non-nil, forms are read with `read-positioning-symbols'."
"A buffer-local variable used by `elisp-refs--contents-buffer'. "A buffer-local variable used by `elisp-refs--contents-buffer'.
Internal implementation detail.") Internal implementation detail.")
(defun elisp-refs--read-all-buffer-forms (buffer symbols-with-pos) (defun elisp-refs--read-all-buffer-forms (buffer)
"Read all the forms in BUFFER, along with their positions." "Read all the forms in BUFFER, along with their positions."
(with-current-buffer buffer (with-current-buffer buffer
(goto-char (point-min)) (goto-char (point-min))
(let ((forms nil)) (let ((forms nil))
(condition-case err (condition-case err
(while t (while t
(push (elisp-refs--read-buffer-form symbols-with-pos) forms)) (push (elisp-refs--read-buffer-form) forms))
(error (error
(if (or (equal (car err) 'end-of-file) (if (or (equal (car err) 'end-of-file)
;; TODO: this shouldn't occur in valid elisp files, ;; TODO: this shouldn't occur in valid elisp files,
@ -139,12 +130,12 @@ Internal implementation detail.")
(defun elisp-refs--proper-list-p (val) (defun elisp-refs--proper-list-p (val)
"Is VAL a proper list?" "Is VAL a proper list?"
(if (fboundp 'proper-list-p) (if (fboundp 'format-proper-list-p)
;; `proper-list-p' was added in Emacs 27.1. ;; Emacs stable.
(with-no-warnings (format-proper-list-p val))
;; Function was renamed in Emacs master:
;; http://git.savannah.gnu.org/cgit/emacs.git/commit/?id=2fde6275b69fd113e78243790bf112bbdd2fe2bf ;; http://git.savannah.gnu.org/cgit/emacs.git/commit/?id=2fde6275b69fd113e78243790bf112bbdd2fe2bf
(with-no-warnings (proper-list-p val)) (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) (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 "Walk FORM, a nested list, and return a list of sublists (with
@ -180,7 +171,7 @@ START-POS and END-POS should be the position of FORM within BUFFER."
;; Calculate the positions after the opening paren. ;; Calculate the positions after the opening paren.
(elisp-refs--sexp-positions buffer (1+ start-pos) end-pos)))) (elisp-refs--sexp-positions buffer (1+ start-pos) end-pos))))
;; For each subform, recurse if it's a list, or a matching symbol. ;; For each subform, recurse if it's a list, or a matching symbol.
(--each (-zip-pair form subforms-positions) (--each (-zip form subforms-positions)
(-let [(subform subform-start subform-end) it] (-let [(subform subform-start subform-end) it]
(when (or (when (or
(and (consp subform) (elisp-refs--proper-list-p subform)) (and (consp subform) (elisp-refs--proper-list-p subform))
@ -317,41 +308,15 @@ with its start and end position."
(-non-nil (-non-nil
(--mapcat (--mapcat
(-let [(form start-pos end-pos symbol-positions _read-start-pos) it] (-let [(form start-pos end-pos symbol-positions _read-start-pos) it]
;; Optimisation: if we have a list of positions for the current ;; Optimisation: don't bother walking a form if contains no
;; form (Emacs 28 and earlier), and it doesn't contain the ;; references to the symbol we're looking for.
;; symbol we're looking for, don't bother walking the form. (when (assq symbol symbol-positions)
(when (or (null symbol-positions) (assq symbol symbol-positions))
(elisp-refs--walk buffer form start-pos end-pos symbol match-p))) (elisp-refs--walk buffer form start-pos end-pos symbol match-p)))
(elisp-refs--read-all-buffer-forms buffer nil)))) (elisp-refs--read-all-buffer-forms buffer))))
(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) (defun elisp-refs--read-and-find-symbol (buffer symbol)
"Read all the forms in BUFFER, and return a list of all "Read all the forms in BUFFER, and return a list of all
positions of SYMBOL." 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 (-non-nil
(--mapcat (--mapcat
(-let [(_ _ _ symbol-positions read-start-pos) it] (-let [(_ _ _ symbol-positions read-start-pos) it]
@ -362,7 +327,8 @@ positions of SYMBOL."
(end-pos (+ start-pos (length (symbol-name sym))))) (end-pos (+ start-pos (length (symbol-name sym)))))
(list sym start-pos end-pos)))) (list sym start-pos end-pos))))
symbol-positions)) symbol-positions))
forms)))))
(elisp-refs--read-all-buffer-forms buffer))))
(defun elisp-refs--filter-obarray (pred) (defun elisp-refs--filter-obarray (pred)
"Return a list of all the items in `obarray' where PRED returns t." "Return a list of all the items in `obarray' where PRED returns t."

View file

@ -1,14 +0,0 @@
(define-package "elisp-refs" "20230419.405" "find callers of elisp functions or macros"
'((dash "2.12.0")
(s "1.11.0"))
:commit "bf3cca8f74065b1b31036f461e3a093b162311bd" :authors
'(("Wilfred Hughes" . "me@wilfred.me.uk"))
:maintainers
'(("Wilfred Hughes" . "me@wilfred.me.uk"))
:maintainer
'("Wilfred Hughes" . "me@wilfred.me.uk")
:keywords
'("lisp"))
;; Local Variables:
;; no-byte-compile: t
;; End:

View file

@ -1,11 +1,9 @@
(define-package "f" "20230704.1346" "Modern API for working with files and directories" (define-package "f" "20220911.711" "Modern API for working with files and directories"
'((emacs "24.1") '((emacs "24.1")
(s "1.7.0") (s "1.7.0")
(dash "2.2.0")) (dash "2.2.0"))
:commit "19e1da061e759b05e8c480b426287a063ca39484" :authors :commit "d50dca48929575642912bb5bbb2585709ba38f82" :authors
'(("Johan Andersson" . "johan.rejeep@gmail.com")) '(("Johan Andersson" . "johan.rejeep@gmail.com"))
:maintainers
'(("Lucien Cartier-Tilet" . "lucien@phundrak.com"))
:maintainer :maintainer
'("Lucien Cartier-Tilet" . "lucien@phundrak.com") '("Lucien Cartier-Tilet" . "lucien@phundrak.com")
:keywords :keywords

View file

@ -29,8 +29,7 @@
;;; Code: ;;; Code:
(when (version<= "28.1" emacs-version) (when (version<= "28.1" emacs-version)
(when (< emacs-major-version 29) (require 'shortdoc)
(require 'shortdoc))
(define-short-documentation-group f (define-short-documentation-group f
"Paths" "Paths"
@ -284,16 +283,10 @@
:result nil) :result nil)
(f-hidden-p (f-hidden-p
:eval (f-hidden-p "path/to/foo") :no-eval (f-hidden-p "/path/to/foo")
:eval (f-hidden-p ".path/to/foo") :result nil
:eval (f-hidden-p "path/.to/foo") :no-eval (f-hidden-p "/path/to/.foo")
:eval (f-hidden-p "path/to/.foo") :result t)
:eval (f-hidden-p ".path/to/foo" 'any)
:eval (f-hidden-p "path/.to/foo" 'any)
:eval (f-hidden-p "path/to/.foo" 'any)
:eval (f-hidden-p ".path/to/foo" 'last)
:eval (f-hidden-p "path/.to/foo" 'last)
:eval (f-hidden-p "path/to/.foo" 'last))
(f-empty-p (f-empty-p
:no-eval (f-empty-p "/path/to/empty-file") :no-eval (f-empty-p "/path/to/empty-file")
@ -305,30 +298,6 @@
:no-eval (f-empty-p "/path/to/dir-with-contents/") :no-eval (f-empty-p "/path/to/dir-with-contents/")
:result nil) :result nil)
(f-older-p
:noeval (f-older-p "older-file.txt" "newer-file.txt")
:result t
:noeval (f-older-p "newer-file.txt" "older-file.txt")
:result nil
:noeval (f-older-p "same-time1.txt" "same-time2.txt")
:result nil)
(f-newer-p
:noeval (f-newer-p "newer-file.txt" "older-file.txt")
:result t
:noeval (f-newer-p "older-file.txt" "newer-file.txt")
:result nil
:noeval (f-newer-p "same-time1.txt" "same-time2.txt")
:result nil)
(f-same-time-p
:noeval (f-same-time-p "same-time1.txt" "same-time2.txt")
:result t
:noeval (f-same-time-p "newer-file.txt" "older-file.txt")
:result nil
:noeval (f-same-time-p "older-file.txt" "newer-file.txt")
:result nil)
"Stats" "Stats"
(f-size (f-size
:no-eval* (f-size "path/to/file.txt") :no-eval* (f-size "path/to/file.txt")
@ -340,46 +309,16 @@
:eval (f-depth "/usr/local/bin")) :eval (f-depth "/usr/local/bin"))
(f-change-time (f-change-time
:no-eval (f-change-time "path/to/file.txt") :no-eval* (f-change-time "path/to/file.txt")
:result (25517 48756 26337 111000) :no-eval* (f-change-time "path/to/dir"))
:no-eval (f-change-time "path/to/dir")
:result (25517 57887 344657 210000)
:no-eval (f-change-time "path/to/file.txt" t)
:result (1672330868026337111 . 1000000000)
:no-eval (f-change-time "path/to/dir" t)
:result (1672339999344657210 . 1000000000)
:no-eval (f-change-time "path/to/file.txt" 'seconds)
:result 1672330868
:no-eval (f-change-time "path/to/dir" 'seconds)
:result 1672339999)
(f-modification-time (f-modification-time
:no-eval (f-modification-time "path/to/file.txt") :no-eval* (f-modification-time "path/to/file.txt")
:result (25517 48756 26337 111000) :no-eval* (f-modification-time "path/to/dir"))
:no-eval (f-modification-time "path/to/dir")
:result (25517 57887 344657 210000)
:no-eval (f-modification-time "path/to/file.txt" t)
:result (1672330868026337111 . 1000000000)
:no-eval (f-modification-time "path/to/dir" t)
:result (1672339999344657210 . 1000000000)
:no-eval (f-modification-time "path/to/file.txt" 'seconds)
:result 1672330868
:no-eval (f-modification-time "path/to/dir" 'seconds)
:result 1672339999)
(f-access-time (f-access-time
:no-eval (f-access-time "path/to/file.txt") :no-eval* (f-access-time "path/to/file.txt")
:result (25517 48756 26337 111000) :no-eval* (f-access-time "path/to/dir"))
:no-eval (f-access-time "path/to/dir")
:result (25517 57887 344657 210000)
:no-eval (f-access-time "path/to/file.txt" t)
:result (1672330868026337111 . 1000000000)
:no-eval (f-access-time "path/to/dir" t)
:result (1672339999344657210 . 1000000000)
:no-eval (f-access-time "path/to/file.txt" 'seconds)
:result 1672330868
:no-eval (f-access-time "path/to/dir" 'seconds)
:result 1672339999)
"Misc" "Misc"
(f-this-file (f-this-file
@ -389,8 +328,8 @@
:eval (f-path-separator)) :eval (f-path-separator))
(f-glob (f-glob
:no-eval* (f-glob "path/to/*.el") :noeval* (f-glob "path/to/*.el")
:no-eval* (f-glob "*.el" "path/to")) :noeval* (f-glob "*.el" "path/to"))
(f-entries (f-entries
:no-eval* (f-entries "path/to/dir") :no-eval* (f-entries "path/to/dir")

View file

@ -28,11 +28,6 @@
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA. ;; 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: ;;; Code:
@ -73,7 +68,7 @@ will discard all the preceeding arguments and make this absolute
path the new root of the generated path." path the new root of the generated path."
(let (path (let (path
(relative (f-relative-p (car args)))) (relative (f-relative-p (car args))))
(mapc (-map
(lambda (arg) (lambda (arg)
(setq path (cond ((not path) arg) (setq path (cond ((not path) arg)
((f-absolute-p arg) ((f-absolute-p arg)
@ -214,9 +209,9 @@ This function expects no duplicate paths."
(defun f-read-bytes (path &optional beg end) (defun f-read-bytes (path &optional beg end)
"Read binary data from PATH. "Read binary data from PATH.
Return the binary data as unibyte string. The optional second Return the binary data as unibyte string. The optional second and
and third arguments BEG and END specify what portion of the file third arguments BEG and END specify what portion of the file to
to read." read."
(with-temp-buffer (with-temp-buffer
(set-buffer-multibyte nil) (set-buffer-multibyte nil)
(setq buffer-file-coding-system 'binary) (setq buffer-file-coding-system 'binary)
@ -454,49 +449,16 @@ The extension, in a file name, is the part that follows the last
(defun f-descendant-of-p (path-a path-b) (defun f-descendant-of-p (path-a path-b)
"Return t if PATH-A is desendant of PATH-B." "Return t if PATH-A is desendant of PATH-B."
(unless (f-same-p path-a path-b) (unless (f-same-p path-a path-b)
(let ((path-a (f-split (f-full path-a))) (string-prefix-p (f-full path-b)
(path-b (f-split (f-full path-b))) (f-full path-a))))
(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) (defalias 'f-descendant-of? 'f-descendant-of-p)
(defun f-hidden-p (path &optional behavior) (defun f-hidden-p (path)
"Return t if PATH is hidden, nil otherwise. "Return t if PATH is hidden, nil otherwise."
(unless (f-exists-p path)
BEHAVIOR controls when a path should be considered as hidden (error "Path does not exist: %s" path))
depending on its value. Beware, if PATH begins with \"./\", the (string= (substring path 0 1) "."))
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) (defalias 'f-hidden? 'f-hidden-p)
@ -529,142 +491,26 @@ detect the depth.
'/' will be zero depth, '/usr' will be one depth. And so on." '/' will be zero depth, '/usr' will be one depth. And so on."
(- (length (f-split (f-expand path))) 1)) (- (length (f-split (f-expand path))) 1))
;; For Emacs 28 and below, forward-declare current-time-list, which was (defun f-change-time (path)
;; 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. "Return the last status change time of PATH.
The status change time (ctime) of PATH in the same format as The status change time (ctime) of PATH in the same format as
`current-time'. For details on TIMESTAMP-P and the format of the `current-time'. See `file-attributes' for technical details."
returned value, see `f--get-time'." (nth 6 (file-attributes path)))
(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) (defun f-modification-time (path)
"Return the last modification time of PATH. "Return the last modification time of PATH.
The modification time (mtime) of PATH in the same format as The modification time (mtime) of PATH in the same format as
`current-time'. For details on TIMESTAMP-P and the format of the `current-time'. See `file-attributes' for technical details."
returned value, see `f--get-time'." (nth 5 (file-attributes path)))
(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) (defun f-access-time (path)
"Return the last access time of PATH. "Return the last access time of PATH.
The access time (atime) of PATH is in the same format as The access time (atime) of PATH is in the same format as
`current-time'. For details on TIMESTAMP-P and the format of the `current-time'. See `file-attributes' for technical details."
returned value, see `f--get-time'." (nth 4 (file-attributes path)))
(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)))
(message "[DEBUG]: file: %s\t\tother: %s" file other)
(message "[DEBUG]: dates: %S" dates)
(-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 ;;;; Misc
@ -698,7 +544,7 @@ For more info on METHOD, see `f--date-compare'."
(member (f-filename file) '("." ".."))) (member (f-filename file) '("." "..")))
(directory-files path t)))) (directory-files path t))))
(cond (recursive (cond (recursive
(mapc (-map
(lambda (entry) (lambda (entry)
(if (f-file-p entry) (if (f-file-p entry)
(setq result (cons entry result)) (setq result (cons entry result))

View file

@ -0,0 +1,261 @@
#!/usr/bin/env sh
## Copyright (C) 2012 ~ 2021 Thierry Volpiatto
##
## 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:
# Preconfigured `emacs -Q' with a basic Helm configuration.
# If TEMP env var exists, use it, otherwise declare it.
test -z "$TEMP" && TEMP="/tmp"
CONF_FILE="$TEMP/helm-cfg.el"
EMACS=emacs
TOOLBARS=-1
LOAD_PACKAGES=
usage () {
cat >&1 <<EOF
Usage: ${0##*/} [-P PATH] [--toolbars] [--load-packages pkgs] [-h] [EMACS-OPTIONS-OR-FILENAME]
-P --path Specify path to emacs
-B --toolbars Display Menu bar, scroll bar etc...
--load-packages Load specified M/Elpa packages (separate with ",")
-h Display this help and exit
Any other Emacs options or filename must come after.
Emacs options:
Initialization options:
--chdir DIR change to directory DIR
--daemon, --bg-daemon[=NAME] start a (named) server in the background
--fg-daemon[=NAME] start a (named) server in the foreground
--debug-init enable Emacs Lisp debugger for init file
--display, -d DISPLAY use X server DISPLAY
--no-build-details do not add build details such as time stamps
--no-loadup, -nl do not load loadup.el into bare Emacs
--no-site-file do not load site-start.el
--no-x-resources do not load X resources
--no-window-system, -nw do not communicate with X, ignoring $DISPLAY
--script FILE run FILE as an Emacs Lisp script
--terminal, -t DEVICE use DEVICE for terminal I/O
Action options:
FILE visit FILE
+LINE go to line LINE in next FILE
+LINE:COLUMN go to line LINE, column COLUMN, in next FILE
--directory, -L DIR prepend DIR to load-path (with :DIR, append DIR)
--file FILE visit FILE
--find-file FILE visit FILE
--funcall, -f FUNC call Emacs Lisp function FUNC with no arguments
--insert FILE insert contents of FILE into current buffer
--load, -l FILE load Emacs Lisp FILE using the load function
--visit FILE visit FILE
Display options:
--background-color, -bg COLOR window background color
--basic-display, -D disable many display features;
used for debugging Emacs
--border-color, -bd COLOR main border color
--border-width, -bw WIDTH width of main border
--color, --color=MODE override color mode for character terminals;
MODE defaults to \`auto', and
can also be \`never', \`always',
or a mode name like \`ansi8'
--cursor-color, -cr COLOR color of the Emacs cursor indicating point
--font, -fn FONT default font; must be fixed-width
--foreground-color, -fg COLOR window foreground color
--fullheight, -fh make the first frame high as the screen
--fullscreen, -fs make the first frame fullscreen
--fullwidth, -fw make the first frame wide as the screen
--maximized, -mm make the first frame maximized
--geometry, -g GEOMETRY window geometry
--iconic start Emacs in iconified state
--internal-border, -ib WIDTH width between text and main border
--line-spacing, -lsp PIXELS additional space to put between lines
--mouse-color, -ms COLOR mouse cursor color in Emacs window
--name NAME title for initial Emacs frame
--reverse-video, -r, -rv switch foreground and background
--title, -T TITLE title for initial Emacs frame
--vertical-scroll-bars, -vb enable vertical scroll bars
--xrm XRESOURCES set additional X resources
--parent-id XID set parent window
--help display this help and exit
--version output version information and exit
You can generally also specify long option names with a single -; for
example, -batch as well as --batch. You can use any unambiguous
abbreviation for a --option.
Various environment variables and window system resources also affect
the operation of Emacs. See the main documentation.
EOF
}
for a in "$@"; do
case $a in
--path | -P)
shift 1
EMACS="$1"
shift 1
;;
--toolbars | -B)
shift 1
TOOLBARS=1
;;
--load-packages)
shift 1
LOAD_PACKAGES="$1"
shift 1
;;
-h)
usage
exit 1
;;
esac
done
LOAD_PATH=$($EMACS -q -batch --eval "(prin1 load-path)")
cd "${0%/*}" || exit 1
# Check if autoload file exists.
# It may be in a different directory if emacs-helm.sh is a symlink.
TRUENAME=$(find "${0%/*}" -path "$0" -printf "%l")
if [ -n "$TRUENAME" ]; then
AUTO_FILE="${TRUENAME%/*}/helm-autoloads.el"
else
AUTO_FILE="helm-autoloads.el"
fi
if [ ! -e "$AUTO_FILE" ]; then
echo No autoloads found, please run make first to generate autoload file
exit 1
fi
cat > $CONF_FILE <<EOF
(setq initial-scratch-message (concat initial-scratch-message
";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\\n\
;; This Emacs is Powered by \`HELM' using\\n\
;; emacs program \"$EMACS\".\\n\
;; This is a minimal \`helm' configuration to discover \`helm' or debug it.\\n\
;; You can retrieve this minimal configuration in \"$CONF_FILE\".\\n\
;;
;; Some original Emacs commands are replaced by their \`helm' counterparts:\\n\\n\
;; - \`find-file'(C-x C-f) =>\`helm-find-files'\\n\
;; - \`occur'(M-s o) =>\`helm-occur'\\n\
;; - \`list-buffers'(C-x C-b) =>\`helm-buffers-list'\\n\
;; - \`completion-at-point'(M-tab) =>\`helm-lisp-completion-at-point'[1]\\n\
;; - \`apropos-command'(C-h a) =>\`helm-apropos'\\n\
;; - \`dabbrev-expand'(M-/) =>\`helm-dabbrev'\\n\
;; - \`execute-extended-command'(M-x) =>\`helm-M-x'\\n\\n
;; Some other Emacs commands are \"helmized\" by \`helm-mode'.\\n\
;; [1] Coming with emacs-24.4, \`completion-at-point' is \"helmized\" by \`helm-mode'\\n\
;; which provides Helm completion in many places like \`shell-mode'.\\n\
;; Find context help for most Helm commands with \`C-h m'.\\n\
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\\n\\n"))
(setq load-path (quote $LOAD_PATH))
(defvar default-package-manager nil)
;; /home/you/.emacs.d/.local/straight/build-27.1/helm
(defvar initial-package-directory (file-name-directory (file-truename "$0")))
(defvar bootstrap-version)
(let* ((packages "$LOAD_PACKAGES")
(pkg-list (and packages
(not (equal packages ""))
(split-string packages ",")))
;; /home/you/.emacs.d/.local/straight/build-27.1
(straight-path (file-name-directory (directory-file-name initial-package-directory)))
;; /home/you/.emacs.d/.local/straight/build-27.1/async
(async-path (expand-file-name "async" straight-path))
;; /home/you/.emacs.d/.local/straight/repos/straight.el/bootstrap.el
(bootstrap-file
(expand-file-name "repos/straight.el/bootstrap.el"
(file-name-directory (directory-file-name straight-path))))
(bootstrap-version 5))
(when (file-exists-p bootstrap-file)
(setq default-package-manager 'straight)
(load bootstrap-file nil 'nomessage)
(add-to-list 'load-path async-path)
(when pkg-list
(dolist (pkg pkg-list)
(let* ((pkg-path (expand-file-name pkg straight-path))
(autoload-file (expand-file-name
(format "%s-autoloads.el" pkg)
pkg-path)))
(add-to-list 'load-path pkg-path)
(if (file-exists-p autoload-file)
(load autoload-file nil 'nomessage)
(straight-use-package (intern pkg))))))))
(unless (eq default-package-manager 'straight)
(require 'package)
;; User may be using a non standard \`package-user-dir'.
;; Modify \`package-directory-list' instead of \`package-user-dir'
;; in case the user starts Helm from a non-ELPA installation.
(unless (file-equal-p package-user-dir (locate-user-emacs-file "elpa"))
;; Something like /home/you/.emacs.d/somedir/else/elpa/
;; starting from default-directory is wrong in case helm.sh is a symlink
;; or e.g. helm --chdir foo have been used.
(add-to-list 'package-directory-list (directory-file-name
(file-name-directory
(directory-file-name initial-package-directory)))))
(let* ((str-lst "$LOAD_PACKAGES")
(load-packages (and str-lst
(not (string= str-lst ""))
(split-string str-lst ","))))
(setq package-load-list
(if (equal load-packages '("all"))
'(all)
(append '((helm-core t) (helm t) (async t) (popup t))
(mapcar (lambda (p) (list (intern p) t)) load-packages)))))
(package-initialize))
(add-to-list 'load-path initial-package-directory)
(unless (> $TOOLBARS 0)
(setq default-frame-alist '((vertical-scroll-bars . nil)
(tool-bar-lines . 0)
(menu-bar-lines . 0)
(fullscreen . nil))))
(blink-cursor-mode -1)
(require 'helm-config)
(helm-mode 1)
(with-eval-after-load 'tramp-cache (setq tramp-cache-read-persistent-data t))
(with-eval-after-load 'auth-source (setq auth-source-save-behavior nil))
(define-key global-map [remap find-file] 'helm-find-files)
(define-key global-map [remap occur] 'helm-occur)
(define-key global-map [remap list-buffers] 'helm-buffers-list)
(define-key global-map [remap dabbrev-expand] 'helm-dabbrev)
(define-key global-map [remap execute-extended-command] 'helm-M-x)
(define-key global-map [remap apropos-command] 'helm-apropos)
(unless (boundp 'completion-in-region-function)
(define-key lisp-interaction-mode-map [remap completion-at-point] 'helm-lisp-completion-at-point)
(define-key emacs-lisp-mode-map [remap completion-at-point] 'helm-lisp-completion-at-point))
(add-hook 'kill-emacs-hook #'(lambda () (and (file-exists-p "$CONF_FILE") (delete-file "$CONF_FILE"))))
EOF
$EMACS -Q -l "$CONF_FILE" "$@"

View file

@ -0,0 +1,284 @@
;;; helm-adaptive.el --- Adaptive Sorting of Candidates. -*- lexical-binding: t -*-
;; Original Author: Tamas Patrovics
;; Copyright (C) 2007 Tamas Patrovics
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(defgroup helm-adapt nil
"Adaptative sorting of candidates for Helm."
:group 'helm)
(defcustom helm-adaptive-history-file
(locate-user-emacs-file "helm-adaptive-history")
"Path of file where history information is stored.
When nil history is not saved nor restored after Emacs restart
unless you save/restore `helm-adaptive-history' with something
else like psession or desktop."
:type 'string)
(defcustom helm-adaptive-history-length 50
"Maximum number of candidates stored for a source."
:type 'number)
(defcustom helm-adaptive-sort-by-frequent-recent-usage t
"Try to sort on an average of frequent and recent usage when non-nil.
When nil sort on frequency usage only.
Only frequency:
When candidate have low frequency, you have to hit on it many
times to make it going up on top.
Frequency+recent:
Even with a low frequency, candidate go up on top. If a candidate
have a high frequency but it is not used since some time, it goes
down slowly, but as soon you reuse it it go up on top quickly."
:type 'boolean)
;; Internal
(defvar helm-adaptive-done nil
"nil if history information is not yet stored for the current
selection.")
(defvar helm-adaptive-history nil
"Contains the stored history information.
Format: ((SOURCE-NAME
(SELECTED-CANDIDATE (PATTERN . NUMBER-OF-USE) ...) ...) ...)")
(defconst helm-adaptive-freq-coefficient 5)
(defconst helm-adaptive-recent-coefficient 2)
(defun helm-adaptive-done-reset ()
(setq helm-adaptive-done nil))
;;;###autoload
(define-minor-mode helm-adaptive-mode
"Toggle adaptive sorting in all sources."
:global t
(if helm-adaptive-mode
(progn
(unless helm-adaptive-history
(helm-adaptive-maybe-load-history))
(add-hook 'kill-emacs-hook #'helm-adaptive-save-history)
;; Should run at beginning of `helm-initial-setup'.
(add-hook 'helm-before-initialize-hook #'helm-adaptive-done-reset)
;; Should run at beginning of `helm-exit-minibuffer'.
(add-hook 'helm-before-action-hook #'helm-adaptive-store-selection)
;; Should run at beginning of `helm-select-action'.
(add-hook 'helm-select-action-hook #'helm-adaptive-store-selection))
(helm-adaptive-save-history)
(setq helm-adaptive-history nil)
(remove-hook 'kill-emacs-hook #'helm-adaptive-save-history)
(remove-hook 'helm-before-initialize-hook #'helm-adaptive-done-reset)
(remove-hook 'helm-before-action-hook #'helm-adaptive-store-selection)
(remove-hook 'helm-select-action-hook #'helm-adaptive-store-selection)))
(defun helm-adapt-use-adaptive-p (&optional source-name)
"Return current source only if it use adaptive history, nil otherwise."
(when helm-adaptive-mode
(let* ((source (or source-name (helm-get-current-source)))
(adapt-source (or (assoc-default 'filtered-candidate-transformer source)
(assoc-default 'candidate-transformer source))))
(if (listp adapt-source)
(and (memq 'helm-adaptive-sort adapt-source) source)
(and (eq adapt-source 'helm-adaptive-sort) source)))))
(defun helm-adaptive-store-selection ()
"Store history information for the selected candidate."
(unless helm-adaptive-done
(setq helm-adaptive-done t)
(let ((source (helm-adapt-use-adaptive-p)))
(when source
(let* ((source-name (assoc-default 'name source))
(source-info (or (assoc source-name helm-adaptive-history)
(progn
(push (list source-name) helm-adaptive-history)
(car helm-adaptive-history))))
(selection (helm-get-selection nil t))
(selection-info (progn
(setcdr source-info
(cons
(let ((found (assoc selection (cdr source-info))))
(if (not found)
;; new entry
(list selection)
;; move entry to the beginning of the
;; list, so that it doesn't get
;; trimmed when the history is
;; truncated
(setcdr source-info
(delete found (cdr source-info)))
found))
(cdr source-info)))
(cadr source-info)))
(pattern-info (progn
(setcdr selection-info
(cons
(let ((found (assoc helm-pattern (cdr selection-info))))
(if (not found)
;; new entry
(cons helm-pattern 0)
;; move entry to the beginning of the
;; list, so if two patterns used the
;; same number of times then the one
;; used last appears first in the list
(setcdr selection-info
(delete found (cdr selection-info)))
found))
(cdr selection-info)))
(cadr selection-info)))
(timestamp-info (helm-aif (assq 'timestamp (cdr selection-info))
it
(setcdr selection-info (cons (cons 'timestamp 0) (cdr selection-info)))
(cadr selection-info))))
;; Increase usage count.
(setcdr pattern-info (1+ (cdr pattern-info)))
;; Update timestamp.
(setcdr timestamp-info (float-time))
;; Truncate history if needed.
(if (> (length (cdr selection-info)) helm-adaptive-history-length)
(setcdr selection-info
(cl-subseq (cdr selection-info) 0 helm-adaptive-history-length))))))))
(defun helm-adaptive-maybe-load-history ()
"Load `helm-adaptive-history-file' which contain `helm-adaptive-history'.
Returns nil if `helm-adaptive-history-file' doesn't exist."
(when (and helm-adaptive-history-file
(file-readable-p helm-adaptive-history-file))
(load-file helm-adaptive-history-file)))
(defun helm-adaptive-save-history (&optional arg)
"Save history information to the file given by `helm-adaptive-history-file'."
(interactive "p")
(when helm-adaptive-history-file
(with-temp-buffer
(insert
";; -*- mode: emacs-lisp -*-\n"
";; History entries used for helm adaptive display.\n")
(let (print-length print-level)
(prin1 `(setq helm-adaptive-history ',helm-adaptive-history)
(current-buffer)))
(insert ?\n)
(write-region (point-min) (point-max) helm-adaptive-history-file nil
(unless arg 'quiet)))))
(defun helm-adaptive-sort (candidates source)
"Sort the CANDIDATES for SOURCE by usage frequency.
This is a filtered candidate transformer you can use with the
`filtered-candidate-transformer' attribute."
(let* ((source-name (assoc-default 'name source))
(source-info (assoc source-name helm-adaptive-history)))
(if source-info
(let ((usage
;; Loop in the SOURCE entry of `helm-adaptive-history'
;; and assemble a list containing the (CANDIDATE
;; . USAGE-COUNT) pairs.
(cl-loop with cf = (if helm-adaptive-sort-by-frequent-recent-usage
helm-adaptive-freq-coefficient 1)
with cr = helm-adaptive-recent-coefficient
for (src-cand . infos) in (cdr source-info)
for count-freq = 0
for count-rec =
(helm-aif (and helm-adaptive-sort-by-frequent-recent-usage
(assq 'timestamp infos))
(* cr (+ (float-time) (cdr it)))
0)
do (cl-loop for (pattern . score) in
(remove (assq 'timestamp infos) infos)
;; If current pattern is equal to
;; the previously used one then
;; this candidate has priority
;; (that's why its count-freq is
;; boosted by 10000) and it only
;; has to compete with other
;; candidates which were also
;; selected with the same pattern.
if (equal pattern helm-pattern)
return (setq count-freq (+ 10000 score))
else do (cl-incf count-freq score))
and collect (cons src-cand (+ (* count-freq cf) count-rec))
into results
;; Sort the list in descending order, so
;; candidates with highest priority come
;; first.
finally return
(sort results (lambda (first second)
(> (cdr first) (cdr second)))))))
(if (consp usage)
;; Put those candidates first which have the highest usage count.
(cl-loop for (cand . _freq) in usage
for info = (or (and (assq 'multiline source)
(replace-regexp-in-string
"\n\\'" "" cand))
;; Some transformers like in
;; bookmarks may add a leading
;; space to provide additional
;; infos like an icon as a
;; display prop, strip out this
;; leading space for
;; comparison. Same for a
;; trailing space (helm
;; boookmark add bmk location as
;; a display prop when
;; displaying it).
(helm-aand (replace-regexp-in-string "\\` " "" cand)
(replace-regexp-in-string " \\'" "" it)))
when (cl-member info candidates
:test 'helm-adaptive-compare)
collect (car it) into sorted
and do (setq candidates
(cl-remove info candidates
:test 'helm-adaptive-compare))
finally return (append sorted candidates))
(message "Your `%s' is maybe corrupted or too old, \
you should reinitialize it with `helm-reset-adaptive-history'"
helm-adaptive-history-file)
(sit-for 1)
candidates))
;; if there is no information stored for this source then do nothing
candidates)))
;;;###autoload
(defun helm-reset-adaptive-history ()
"Delete all `helm-adaptive-history' and his file.
Useful when you have a old or corrupted
`helm-adaptive-history-file'."
(interactive)
(when (y-or-n-p "Really delete all your `helm-adaptive-history'? ")
(setq helm-adaptive-history nil)
(when (and helm-adaptive-history-file
(file-exists-p helm-adaptive-history-file))
(delete-file helm-adaptive-history-file))))
(defun helm-adaptive-compare (x y)
"Compare display parts if some of candidates X and Y.
Arguments X and Y are cons cell in (DISPLAY . REAL) format or
atoms."
(equal (if (listp x) (car x) x)
(if (listp y) (car y) y)))
(provide 'helm-adaptive)
;;; helm-adaptive.el ends here

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,809 @@
;;; helm-bookmark.el --- Helm for Emacs regular Bookmarks. -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'bookmark)
(require 'helm)
(require 'helm-lib)
(require 'helm-help)
(require 'helm-types)
(require 'helm-utils)
(require 'helm-info)
(require 'helm-adaptive)
(require 'helm-net)
(declare-function helm-browse-project "helm-files" (arg))
(declare-function addressbook-bookmark-edit "ext:addressbook-bookmark.el" (bookmark))
(declare-function all-the-icons-fileicon "ext:all-the-icons.el")
(declare-function all-the-icons-icon-for-file"ext:all-the-icons.el")
(declare-function all-the-icons-octicon "ext:all-the-icons.el")
(defgroup helm-bookmark nil
"Predefined configurations for `helm.el'."
:group 'helm)
(defcustom helm-bookmark-show-location nil
"Show location of bookmark on display."
:type 'boolean)
(defcustom helm-bookmark-default-filtered-sources
(append '(helm-source-bookmark-org
helm-source-bookmark-files&dirs
helm-source-bookmark-helm-find-files
helm-source-bookmark-info
helm-source-bookmark-gnus
helm-source-bookmark-mu4e
helm-source-bookmark-man
helm-source-bookmark-images
helm-source-bookmark-w3m)
(list 'helm-source-bookmark-uncategorized
'helm-source-bookmark-set))
"List of sources to use in `helm-filtered-bookmarks'."
:type '(repeat (choice symbol)))
(defcustom helm-bookmark-use-icon nil
"Display candidates with an icon with `all-the-icons' when non nil."
:type 'boolean)
(defcustom helm-bookmark-default-sort-method 'adaptive
"Sort method for `helm-filtered-bookmarks'.
Value can be either \\='native' or \\='adaptive'.
Once you use \\='native' the bookmark variable `bookmark-sort-flag'
will be honored."
:type '(choice
(symbol :tag "Helm adaptive sort method" adaptive)
(symbol :tag "Native bookmark sort method" native))
;; Don't use the :set function until functions and variables below
;; are not loaded i.e. use set-default only for now.
:initialize 'custom-initialize-changed
:set (lambda (var val)
(set var val)
(cl-loop for s in (remove 'helm-source-bookmark-set
helm-bookmark-default-filtered-sources)
for fn = (intern (format "%s-builder" s))
do (set s (funcall fn)))))
(defgroup helm-bookmark-faces nil
"Customize the appearance of helm-bookmark."
:prefix "helm-"
:group 'helm-bookmark
:group 'helm-faces)
(defface helm-bookmark-info
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "green"))
"Face used for W3m Emacs bookmarks (not w3m bookmarks)."
:group 'helm-bookmark-faces)
(defface helm-bookmark-w3m
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "yellow"))
"Face used for W3m Emacs bookmarks (not w3m bookmarks)."
:group 'helm-bookmark-faces)
(defface helm-bookmark-gnus
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "magenta"))
"Face used for Gnus bookmarks."
:group 'helm-bookmark-faces)
(defface helm-bookmark-man
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "Orange4"))
"Face used for Woman/man bookmarks."
:group 'helm-bookmark-faces)
(defface helm-bookmark-file
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "Deepskyblue2"))
"Face used for file bookmarks."
:group 'helm-bookmark-faces)
(defface helm-bookmark-file-not-found
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "Slategray4"))
"Face used for file bookmarks."
:group 'helm-bookmark-faces)
(defface helm-bookmark-directory
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:inherit helm-ff-directory))
"Face used for file bookmarks."
:group 'helm-bookmark-faces)
(defface helm-bookmark-addressbook
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "tomato"))
"Face used for addressbook bookmarks."
:group 'helm-bookmark-faces)
(defvar helm-bookmark-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "C-c o") #'helm-bookmark-run-jump-other-window)
(define-key map (kbd "C-c C-o") #'helm-bookmark-run-jump-other-frame)
(define-key map (kbd "C-d") #'helm-bookmark-run-delete)
(define-key map (kbd "C-]") #'helm-bookmark-toggle-filename)
(define-key map (kbd "M-e") #'helm-bookmark-run-edit)
map)
"Generic Keymap for Emacs bookmark sources.")
(defclass helm-source-basic-bookmarks (helm-source-in-buffer helm-type-bookmark)
((init :initform (lambda ()
(bookmark-maybe-load-default-file)
(helm-init-candidates-in-buffer
'global
(if (and (fboundp 'bookmark-maybe-sort-alist)
(fboundp 'bookmark-name-from-full-record))
(mapcar 'bookmark-name-from-full-record
(bookmark-maybe-sort-alist))
(bookmark-all-names)))))
(filtered-candidate-transformer :initform 'helm-bookmark-transformer)
(find-file-target :initform #'helm-bookmarks-quit-an-find-file-fn)))
(defvar helm-source-bookmarks
(helm-make-source "Bookmarks" 'helm-source-basic-bookmarks)
"See (info \"(emacs)Bookmarks\").")
(defun helm-bookmark-transformer (candidates _source)
(cl-loop for i in candidates
for loc = (bookmark-location i)
for len = (string-width i)
for trunc = (if (> len bookmark-bmenu-file-column)
(helm-substring i bookmark-bmenu-file-column)
i)
for sep = (make-string (- (+ bookmark-bmenu-file-column 2)
(length trunc))
? )
if helm-bookmark-show-location
collect (cons (concat trunc sep (if (listp loc) (car loc) loc)) i)
else collect i))
(defun helm-bookmark-toggle-filename-1 (_candidate)
(let* ((real (helm-get-selection helm-buffer))
(trunc (if (> (string-width real) bookmark-bmenu-file-column)
(helm-substring real bookmark-bmenu-file-column)
real)))
(setq helm-bookmark-show-location (not helm-bookmark-show-location))
(helm-update (if helm-bookmark-show-location
(regexp-quote trunc)
(regexp-quote real)))))
(helm-make-persistent-command-from-action helm-bookmark-toggle-filename
"Toggle bookmark location visibility."
'toggle-filename 'helm-bookmark-toggle-filename-1)
(defun helm-bookmark-jump (candidate)
"Jump to bookmark action."
(let ((current-prefix-arg helm-current-prefix-arg)
non-essential)
(bookmark-jump candidate)))
(defun helm-bookmark-jump-other-frame (candidate)
"Jump to bookmark in other frame action."
(let ((current-prefix-arg helm-current-prefix-arg)
non-essential)
(bookmark-jump candidate 'switch-to-buffer-other-frame)))
(defun helm-bookmark-jump-other-window (candidate)
"Jump to bookmark in other window action."
(let (non-essential)
(bookmark-jump-other-window candidate)))
;;; bookmark-set
;;
(defvar helm-source-bookmark-set
(helm-build-dummy-source "Set Bookmark"
:filtered-candidate-transformer
(lambda (_candidates _source)
(list (or (and (not (string= helm-pattern ""))
helm-pattern)
"Enter a bookmark name to record")))
:action '(("Set bookmark" . (lambda (candidate)
(if (string= helm-pattern "")
(message "No bookmark name given for record")
(bookmark-set candidate))))))
"See (info \"(emacs)Bookmarks\").")
;;; Predicates
;;
(defconst helm-bookmark--non-file-filename " - no file -"
"Name to use for `filename' entry, for non-file bookmarks.")
(defun helm-bookmark-gnus-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is a Gnus bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(or (eq (bookmark-get-handler bookmark) 'bmkext-jump-gnus)
(eq (bookmark-get-handler bookmark) 'gnus-summary-bookmark-jump)
(eq (bookmark-get-handler bookmark) 'bookmarkp-jump-gnus)))
(defun helm-bookmark-mu4e-bookmark-p (bookmark)
"Return non nil if BOOKMARK is a mu4e bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(memq (bookmark-get-handler bookmark)
'(mu4e-bookmark-jump mu4e--jump-to-bookmark)))
(defun helm-bookmark-w3m-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is a W3m bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(or (eq (bookmark-get-handler bookmark) 'bmkext-jump-w3m)
(eq (bookmark-get-handler bookmark) 'bookmark-w3m-bookmark-jump)
(eq (bookmark-get-handler bookmark) 'bookmarkp-jump-w3m)))
(defun helm-bookmark-woman-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is a Woman bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(or (eq (bookmark-get-handler bookmark) 'bmkext-jump-woman)
(eq (bookmark-get-handler bookmark) 'woman-bookmark-jump)
(eq (bookmark-get-handler bookmark) 'bookmarkp-jump-woman)))
(defun helm-bookmark-man-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is a Man bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(or (eq (bookmark-get-handler bookmark) 'bmkext-jump-man)
(eq (bookmark-get-handler bookmark) 'Man-bookmark-jump)
(eq (bookmark-get-handler bookmark) 'bookmarkp-jump-man)))
(defun helm-bookmark-woman-man-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is a Man or Woman bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(or (helm-bookmark-man-bookmark-p bookmark)
(helm-bookmark-woman-bookmark-p bookmark)))
(defun helm-bookmark-info-bookmark-p (bookmark)
"Return non-nil if BOOKMARK is an Info bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(eq (bookmark-get-handler bookmark) 'Info-bookmark-jump))
(defun helm-bookmark-image-bookmark-p (bookmark)
"Return non-nil if BOOKMARK bookmarks an image file."
(if (stringp bookmark)
(assq 'image-type (assq bookmark bookmark-alist))
(assq 'image-type bookmark)))
(defun helm-bookmark-file-p (bookmark)
"Return non-nil if BOOKMARK bookmarks a file or directory.
BOOKMARK is a bookmark name or a bookmark record.
This excludes bookmarks of a more specific kind (Info, Gnus, and W3m)."
(let* ((filename (bookmark-get-filename bookmark))
(isnonfile (equal filename helm-bookmark--non-file-filename)))
(and filename (not isnonfile) (not (bookmark-get-handler bookmark)))))
(defun helm-bookmark-org-file-p (bookmark)
(let* ((filename (bookmark-get-filename bookmark)))
(or (string-suffix-p ".org" filename t)
(string-suffix-p ".org_archive" filename t))))
(defun helm-bookmark-helm-find-files-p (bookmark)
"Return non-nil if BOOKMARK bookmarks a `helm-find-files' session.
BOOKMARK is a bookmark name or a bookmark record."
(eq (bookmark-get-handler bookmark) 'helm-ff-bookmark-jump))
(defun helm-bookmark-addressbook-p (bookmark)
"Return non--nil if BOOKMARK is a contact recorded with addressbook-bookmark.
BOOKMARK is a bookmark name or a bookmark record."
(if (listp bookmark)
(string= (assoc-default 'type bookmark) "addressbook")
(string= (assoc-default
'type (assoc bookmark bookmark-alist)) "addressbook")))
(defun helm-bookmark-uncategorized-bookmark-p (bookmark)
"Return non--nil if BOOKMARK match no known category."
(cl-loop for pred in '(helm-bookmark-org-file-p
helm-bookmark-addressbook-p
helm-bookmark-gnus-bookmark-p
helm-bookmark-mu4e-bookmark-p
helm-bookmark-w3m-bookmark-p
helm-bookmark-woman-man-bookmark-p
helm-bookmark-info-bookmark-p
helm-bookmark-image-bookmark-p
helm-bookmark-file-p
helm-bookmark-helm-find-files-p
helm-bookmark-addressbook-p)
never (funcall pred bookmark)))
(defun helm-bookmark-filter-setup-alist (fn)
"Return a filtered `bookmark-alist' sorted alphabetically."
(cl-loop for b in (if (and (fboundp 'bookmark-maybe-sort-alist)
(eq helm-bookmark-default-sort-method 'native))
(bookmark-maybe-sort-alist)
bookmark-alist)
for name = (car b)
when (funcall fn b) collect
(propertize name 'location (bookmark-location name))))
;;; Bookmark handlers
;;
(defvar w3m-async-exec)
(defun helm-bookmark-jump-w3m (bookmark)
"Jump to W3m bookmark BOOKMARK, setting a new tab.
If `browse-url-browser-function' is set to something else than
`w3m-browse-url' use it."
(require 'helm-net)
(let* ((file (or (bookmark-prop-get bookmark 'filename)
(bookmark-prop-get bookmark 'url)))
(buf (generate-new-buffer-name "*w3m*"))
(w3m-async-exec nil)
;; If user don't have anymore w3m installed let it browse its
;; bookmarks with default browser otherwise assume bookmark
;; have been bookmarked from w3m and use w3m.
(browse-url-browser-function (or (and (fboundp 'w3m-browse-url)
(executable-find "w3m")
'w3m-browse-url)
browse-url-browser-function))
(really-use-w3m (equal browse-url-browser-function 'w3m-browse-url)))
(helm-browse-url file really-use-w3m)
(when really-use-w3m
(bookmark-default-handler
`("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark))))))
;; All bookmarks recorded with the handler provided with w3m
;; (`bookmark-w3m-bookmark-jump') will use our handler which open
;; the bookmark in a new tab or in an external browser depending
;; on `browse-url-browser-function'.
(defalias 'bookmark-w3m-bookmark-jump #'helm-bookmark-jump-w3m)
;; Provide compatibility with old handlers provided in external
;; packages bookmark-extensions.el and bookmark+.
(defalias 'bmkext-jump-woman #'woman-bookmark-jump)
(defalias 'bmkext-jump-man #'Man-bookmark-jump)
(defalias 'bmkext-jump-w3m #'helm-bookmark-jump-w3m)
(defalias 'bmkext-jump-gnus #'gnus-summary-bookmark-jump)
(defalias 'bookmarkp-jump-gnus #'gnus-summary-bookmark-jump)
(defalias 'bookmarkp-jump-w3m #'helm-bookmark-jump-w3m)
(defalias 'bookmarkp-jump-woman #'woman-bookmark-jump)
(defalias 'bookmarkp-jump-man #'Man-bookmark-jump)
;;;; Filtered bookmark sources
;;
;;
(defclass helm-source-filtered-bookmarks (helm-source-in-buffer helm-type-bookmark)
((filtered-candidate-transformer
:initform (delq nil
`(,(and (eq helm-bookmark-default-sort-method 'adaptive)
'helm-adaptive-sort)
helm-highlight-bookmark)))
(find-file-target :initform #'helm-bookmarks-quit-an-find-file-fn)))
(defun helm-bookmarks-quit-an-find-file-fn (source)
(let* ((sel (helm-get-selection nil nil source))
(bmk (assoc (replace-regexp-in-string "\\`\\*" "" sel)
bookmark-alist)))
(helm-aif (bookmark-get-filename bmk)
(if (and helm--url-regexp
(string-match helm--url-regexp it))
it (expand-file-name it))
(expand-file-name default-directory))))
(defun helm-bookmark-build-source (name buildfn &optional class &rest args)
(apply #'helm-make-source name
(or class 'helm-source-filtered-bookmarks)
:init (lambda ()
(bookmark-maybe-load-default-file)
(helm-init-candidates-in-buffer
'global (funcall buildfn)))
args))
;;; W3m bookmarks.
;;
(defun helm-bookmark-w3m-setup-alist ()
"Specialized filter function for bookmarks w3m."
(helm-bookmark-filter-setup-alist 'helm-bookmark-w3m-bookmark-p))
(defun helm-source-bookmark-w3m-builder ()
(helm-bookmark-build-source "Bookmark W3m" #'helm-bookmark-w3m-setup-alist))
(defvar helm-source-bookmark-w3m (helm-source-bookmark-w3m-builder))
;;; Images
;;
(defun helm-bookmark-images-setup-alist ()
"Specialized filter function for images bookmarks."
(helm-bookmark-filter-setup-alist 'helm-bookmark-image-bookmark-p))
(defun helm-source-bookmark-images-builder ()
(helm-bookmark-build-source "Bookmark Images" #'helm-bookmark-images-setup-alist))
(defvar helm-source-bookmark-images (helm-source-bookmark-images-builder))
;;; Woman Man
;;
(defun helm-bookmark-man-setup-alist ()
"Specialized filter function for bookmarks w3m."
(helm-bookmark-filter-setup-alist 'helm-bookmark-woman-man-bookmark-p))
(defun helm-source-bookmark-man-builder ()
(helm-bookmark-build-source "Bookmark Woman&Man" #'helm-bookmark-man-setup-alist))
(defvar helm-source-bookmark-man (helm-source-bookmark-man-builder))
;;; Org files
;;
(defun helm-bookmark-org-setup-alist ()
"Specialized filter function for Org file bookmarks."
(helm-bookmark-filter-setup-alist 'helm-bookmark-org-file-p))
(defun helm-source-bookmark-org-builder ()
(helm-bookmark-build-source "Bookmark Org files" #'helm-bookmark-org-setup-alist))
(defvar helm-source-bookmark-org (helm-source-bookmark-org-builder))
;;; Gnus
;;
(defun helm-bookmark-gnus-setup-alist ()
"Specialized filter function for bookmarks gnus."
(helm-bookmark-filter-setup-alist 'helm-bookmark-gnus-bookmark-p))
(defun helm-source-bookmark-gnus-builder ()
(helm-bookmark-build-source "Bookmark Gnus" #'helm-bookmark-gnus-setup-alist))
(defvar helm-source-bookmark-gnus (helm-source-bookmark-gnus-builder))
;;; Mu4e
;;
(defun helm-bookmark-mu4e-setup-alist ()
(helm-bookmark-filter-setup-alist 'helm-bookmark-mu4e-bookmark-p))
(defun helm-source-bookmark-mu4e-builder ()
(helm-bookmark-build-source "Bookmark Mu4e" #'helm-bookmark-mu4e-setup-alist))
(defvar helm-source-bookmark-mu4e (helm-source-bookmark-mu4e-builder))
;;; Info
;;
(defun helm-bookmark-info-setup-alist ()
"Specialized filter function for bookmarks info."
(helm-bookmark-filter-setup-alist 'helm-bookmark-info-bookmark-p))
(defun helm-source-bookmark-info-builder ()
(helm-bookmark-build-source "Bookmark Info" #'helm-bookmark-info-setup-alist))
(defvar helm-source-bookmark-info (helm-source-bookmark-info-builder))
;;; Files and directories
;;
(defun helm-bookmark-local-files-setup-alist ()
"Specialized filter function for bookmarks locals files."
(helm-bookmark-filter-setup-alist 'helm-bookmark-file-p))
(defun helm-source-bookmark-files&dirs-builder ()
(helm-bookmark-build-source
"Bookmark Files&Directories" #'helm-bookmark-local-files-setup-alist))
(defvar helm-source-bookmark-files&dirs
(helm-source-bookmark-files&dirs-builder))
;;; Helm find files sessions.
;;
(defun helm-bookmark-helm-find-files-setup-alist ()
"Specialized filter function for `helm-find-files' bookmarks."
(helm-bookmark-filter-setup-alist 'helm-bookmark-helm-find-files-p))
(defun helm-bookmark-browse-project (candidate)
"Run `helm-browse-project' from action."
(with-helm-default-directory
(bookmark-get-filename candidate)
(helm-browse-project nil)))
(helm-make-command-from-action helm-bookmark-run-browse-project
"Run `helm-bookmark-browse-project' from keyboard."
'helm-bookmark-browse-project)
(defvar helm-bookmark-find-files-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-bookmark-map)
(define-key map (kbd "C-x C-d") #'helm-bookmark-run-browse-project)
map))
(defclass helm-bookmark-override-inheritor (helm-source) ())
(cl-defmethod helm--setup-source ((source helm-bookmark-override-inheritor))
;; Ensure `helm-source-in-buffer' method is called.
(cl-call-next-method)
(setf (slot-value source 'action)
(helm-append-at-nth
(cl-loop for (name . action) in helm-type-bookmark-actions
unless (memq action '(helm-bookmark-jump-other-frame
helm-bookmark-jump-other-window))
collect (cons name action))
'(("Browse project" . helm-bookmark-browse-project)) 1))
(setf (slot-value source 'keymap) helm-bookmark-find-files-map))
(defclass helm-bookmark-find-files-class (helm-source-filtered-bookmarks
helm-bookmark-override-inheritor)
())
(defun helm-source-bookmark-helm-find-files-builder ()
(helm-bookmark-build-source
"Bookmark helm-find-files sessions"
#'helm-bookmark-helm-find-files-setup-alist
'helm-bookmark-find-files-class
:persistent-action (lambda (_candidate) (ignore))
:persistent-help "Do nothing"))
(defvar helm-source-bookmark-helm-find-files
(helm-source-bookmark-helm-find-files-builder))
;;; Uncategorized bookmarks
;;
(defun helm-bookmark-uncategorized-setup-alist ()
"Specialized filter function for uncategorized bookmarks."
(helm-bookmark-filter-setup-alist 'helm-bookmark-uncategorized-bookmark-p))
(defun helm-source-bookmark-uncategorized-builder ()
(helm-bookmark-build-source
"Bookmark uncategorized" #'helm-bookmark-uncategorized-setup-alist))
(defvar helm-source-bookmark-uncategorized
(helm-source-bookmark-uncategorized-builder))
;;; Transformer
;;
(defun helm-highlight-bookmark (bookmarks _source)
"Used as `filtered-candidate-transformer' to colorize bookmarks."
(let ((non-essential t))
(cl-loop for i in bookmarks
for isfile = (bookmark-get-filename i)
for hff = (helm-bookmark-helm-find-files-p i)
for handlerp = (and (fboundp 'bookmark-get-handler)
(bookmark-get-handler i))
for isw3m = (and (fboundp 'helm-bookmark-w3m-bookmark-p)
(helm-bookmark-w3m-bookmark-p i))
for isgnus = (and (fboundp 'helm-bookmark-gnus-bookmark-p)
(helm-bookmark-gnus-bookmark-p i))
for ismu4e = (and (fboundp 'helm-bookmark-mu4e-bookmark-p)
(helm-bookmark-mu4e-bookmark-p i))
for isman = (and (fboundp 'helm-bookmark-man-bookmark-p) ; Man
(helm-bookmark-man-bookmark-p i))
for iswoman = (and (fboundp 'helm-bookmark-woman-bookmark-p) ; Woman
(helm-bookmark-woman-bookmark-p i))
for isannotation = (bookmark-get-annotation i)
for isabook = (string= (bookmark-prop-get i 'type)
"addressbook")
for isinfo = (eq handlerp 'Info-bookmark-jump)
for loc = (bookmark-location i)
for len = (string-width i)
for trunc = (if (and helm-bookmark-show-location
(> len bookmark-bmenu-file-column))
(helm-substring
i bookmark-bmenu-file-column)
i)
for icon = (when helm-bookmark-use-icon
(cond ((and isfile hff)
(all-the-icons-octicon "file-directory"))
((and isfile isinfo) (all-the-icons-octicon "info"))
(isfile (all-the-icons-icon-for-file isfile))
((or iswoman isman)
(all-the-icons-fileicon "man-page"))
((or isgnus ismu4e)
(all-the-icons-octicon "mail-read"))))
;; Add a * if bookmark have annotation
if (and isannotation (not (string-equal isannotation "")))
do (setq trunc (concat "*" (if helm-bookmark-show-location trunc i)))
for sep = (and helm-bookmark-show-location
(make-string (- (+ bookmark-bmenu-file-column 2)
(string-width trunc))
? ))
for bmk = (cond ( ;; info buffers
isinfo
(propertize trunc 'face 'helm-bookmark-info
'help-echo isfile))
( ;; w3m buffers
isw3m
(propertize trunc 'face 'helm-bookmark-w3m
'help-echo isfile))
( ;; gnus buffers
isgnus
(propertize trunc 'face 'helm-bookmark-gnus
'help-echo isfile))
( ;; Man Woman
(or iswoman isman)
(propertize trunc 'face 'helm-bookmark-man
'help-echo isfile))
( ;; Addressbook
isabook
(propertize trunc 'face 'helm-bookmark-addressbook))
(;; Directories (helm-find-files)
hff
(if (and (file-remote-p isfile)
(not (file-remote-p isfile nil t)))
(propertize trunc 'face 'helm-bookmark-file-not-found
'help-echo isfile)
(propertize trunc 'face 'helm-bookmark-directory
'help-echo isfile)))
( ;; Directories (dired)
(and isfile
;; This is needed because `non-essential'
;; is not working on Emacs-24.2 and the behavior
;; of tramp seems to have changed since previous
;; versions (Need to reenter password even if a
;; first connection have been established,
;; probably when host is named differently
;; i.e machine/localhost)
(and (not (file-remote-p isfile))
(file-directory-p isfile)))
(propertize trunc 'face 'helm-bookmark-directory
'help-echo isfile))
( ;; Non existing files.
(and isfile
;; Be safe and call `file-exists-p'
;; only if file is not remote or
;; remote but connected.
(or (and (file-remote-p isfile)
(not (file-remote-p isfile nil t)))
(not (file-exists-p isfile))))
(propertize trunc 'face 'helm-bookmark-file-not-found
'help-echo isfile))
( ;; regular files
t
(propertize trunc 'face 'helm-bookmark-file
'help-echo isfile)))
collect (if helm-bookmark-show-location
(cons (concat (and icon (propertize " " 'display (concat icon " ")))
bmk
(propertize
" " 'display
(concat sep (if (listp loc) (car loc) loc))))
i)
(cons (concat (and icon (propertize " " 'display (concat icon " ")))
bmk)
i)))))
;;; Edit/rename/save bookmarks.
;;
;;
(defun helm-bookmark-edit-bookmark (bookmark-name)
"Edit bookmark's name and file name, and maybe save them.
BOOKMARK-NAME is the current (old) name of the bookmark to be
renamed."
(let ((bmk (helm-bookmark-get-bookmark-from-name bookmark-name))
(handler (bookmark-prop-get bookmark-name 'handler)))
(if (eq handler 'addressbook-bookmark-jump)
(addressbook-bookmark-edit
(assoc bmk bookmark-alist))
(helm-bookmark-edit-bookmark-1 bookmark-name handler))))
(defun helm-bookmark-edit-bookmark-1 (bookmark-name handler)
(let* ((helm--reading-passwd-or-string t)
(bookmark-fname (bookmark-get-filename bookmark-name))
(bookmark-loc (bookmark-prop-get bookmark-name 'location))
(message-id (bookmark-prop-get bookmark-name 'message-id))
(new-name (read-from-minibuffer "Name: " bookmark-name))
(new-loc (and (or bookmark-fname bookmark-loc)
(read-from-minibuffer "FileName or Location: "
(or bookmark-fname
(if (consp bookmark-loc)
(car bookmark-loc)
bookmark-loc)))))
(new-message-id (and (memq handler '(mu4e--jump-to-bookmark
mu4e-bookmark-jump))
(read-string "Message-id: " message-id))))
(when (and (not (equal new-name ""))
(or (not (equal new-loc ""))
(not (equal new-message-id "")))
(y-or-n-p "Save changes? "))
(if bookmark-fname
(progn
(helm-bookmark-rename bookmark-name new-name 'batch)
(bookmark-set-filename new-name new-loc))
(bookmark-prop-set
(bookmark-get-bookmark bookmark-name)
(cond (new-loc 'location)
(new-message-id 'message-id))
(or new-loc new-message-id))
(helm-bookmark-rename bookmark-name new-name 'batch))
(helm-bookmark-maybe-save-bookmark)
(list new-name new-loc))))
(defun helm-bookmark-maybe-save-bookmark ()
"Increment save counter and maybe save `bookmark-alist'."
(setq bookmark-alist-modification-count (1+ bookmark-alist-modification-count))
(when (bookmark-time-to-save-p) (bookmark-save)))
(defun helm-bookmark-rename (old &optional new batch)
"Change bookmark's name from OLD to NEW.
Interactively:
If called from the keyboard, then prompt for OLD.
If called from the menubar, select OLD from a menu.
If NEW is nil, then prompt for its string value.
If BATCH is non-nil, then do not rebuild the menu list.
While the user enters the new name, repeated `C-w' inserts
consecutive words from the buffer into the new bookmark name."
(interactive (list (bookmark-completing-read "Old bookmark name")))
(bookmark-maybe-historicize-string old)
(bookmark-maybe-load-default-file)
(save-excursion (skip-chars-forward " ") (setq bookmark-yank-point (point)))
(setq bookmark-current-buffer (current-buffer))
(let ((newname (or new (read-from-minibuffer
"New name: " nil
(let ((now-map (copy-keymap minibuffer-local-map)))
(define-key now-map "\C-w" #'bookmark-yank-word)
now-map)
nil 'bookmark-history))))
(bookmark-set-name old newname)
(setq bookmark-current-bookmark newname)
(unless batch (bookmark-bmenu-surreptitiously-rebuild-list))
(helm-bookmark-maybe-save-bookmark) newname))
(helm-make-command-from-action helm-bookmark-run-edit
"Run `helm-bookmark-edit-bookmark' from keyboard."
'helm-bookmark-edit-bookmark)
(helm-make-command-from-action helm-bookmark-run-jump-other-frame
"Jump to bookmark other frame from keyboard."
'helm-bookmark-jump-other-frame)
(helm-make-command-from-action helm-bookmark-run-jump-other-window
"Jump to bookmark from keyboard."
'helm-bookmark-jump-other-window)
(helm-make-command-from-action helm-bookmark-run-delete
"Delete bookmark from keyboard."
'helm-delete-marked-bookmarks)
(defun helm-bookmark-get-bookmark-from-name (bmk)
"Return bookmark name even if it is a bookmark with annotation.
E.g. prepended with *."
(let ((bookmark (replace-regexp-in-string "\\`\\*" "" bmk)))
(if (assoc bookmark bookmark-alist) bookmark bmk)))
(defun helm-delete-marked-bookmarks (_ignore)
"Delete this bookmark or all marked bookmarks."
(cl-dolist (i (helm-marked-candidates))
(bookmark-delete (helm-bookmark-get-bookmark-from-name i)
'batch)))
;;;###autoload
(defun helm-bookmarks ()
"Preconfigured `helm' for bookmarks."
(interactive)
(helm :sources '(helm-source-bookmarks
helm-source-bookmark-set)
:buffer "*helm bookmarks*"
:default (buffer-name helm-current-buffer)))
;;;###autoload
(defun helm-filtered-bookmarks ()
"Preconfigured `helm' for bookmarks (filtered by category).
Optional source `helm-source-bookmark-addressbook' is loaded only
if external addressbook-bookmark package is installed."
(interactive)
(when helm-bookmark-use-icon
(require 'all-the-icons))
(helm :sources helm-bookmark-default-filtered-sources
:prompt "Search Bookmark: "
:buffer "*helm filtered bookmarks*"
:default (list (thing-at-point 'symbol)
(buffer-name helm-current-buffer))))
(provide 'helm-bookmark)
;;; helm-bookmark.el ends here

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,159 @@
;;; helm-color.el --- colors and faces -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(require 'helm-elisp)
(declare-function list-colors-display "facemenu")
;;; Customize Face
;;
;;
(defun helm-custom-faces-init ()
"Initialize buffer for `helm-source-customize-face'."
(unless (helm-candidate-buffer)
(save-selected-window
(list-faces-display)
(message nil))
(helm-init-candidates-in-buffer
'global
(with-current-buffer (get-buffer "*Faces*")
(buffer-substring
(next-single-char-property-change (point-min) 'face)
(point-max))))
(kill-buffer "*Faces*")))
(defvar helm-source-customize-face
(helm-build-in-buffer-source "Customize Face"
:init 'helm-custom-faces-init
:get-line 'buffer-substring
:persistent-action (lambda (candidate)
(helm-elisp--persistent-help
(intern (car (split-string candidate)))
'helm-describe-face))
:persistent-help "Describe face"
:action '(("Customize"
. (lambda (line)
(customize-face (intern (car (split-string line))))))
("Copy name"
. (lambda (line)
(kill-new (car (split-string line " " t)))))))
"See (info \"(emacs)Faces\")")
;;; Colors browser
;;
;;
(defun helm-colors-init ()
(require 'facemenu)
(unless (helm-candidate-buffer)
(save-selected-window
(list-colors-display)
(message nil))
(helm-init-candidates-in-buffer
'global
(with-current-buffer (get-buffer "*Colors*")
(buffer-string)))
(kill-buffer "*Colors*")))
(defun helm-color-insert-name (candidate)
(with-helm-current-buffer
(insert (helm-colors-get-name candidate))))
(defun helm-color-kill-name (candidate)
(kill-new (helm-colors-get-name candidate)))
(defun helm-color-insert-rgb (candidate)
(with-helm-current-buffer
(insert (helm-colors-get-rgb candidate))))
(defun helm-color-kill-rgb (candidate)
(kill-new (helm-colors-get-rgb candidate)))
(helm-make-command-from-action helm-color-run-insert-name
"Insert name of color from `helm-source-colors'."
'helm-color-insert-name)
(helm-make-command-from-action helm-color-run-kill-name
"Kill name of color from `helm-source-colors'."
'helm-color-kill-name)
(helm-make-command-from-action helm-color-run-insert-rgb
"Insert RGB of color from `helm-source-colors'."
'helm-color-insert-rgb)
(helm-make-command-from-action helm-color-run-kill-rgb
"Kill RGB of color from `helm-source-colors'."
'helm-color-kill-rgb)
(defvar helm-color-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "C-c n") #'helm-color-run-insert-name)
(define-key map (kbd "C-c N") #'helm-color-run-kill-name)
(define-key map (kbd "C-c r") #'helm-color-run-insert-rgb)
(define-key map (kbd "C-c R") #'helm-color-run-kill-rgb)
map))
(defvar helm-source-colors
(helm-build-in-buffer-source "Colors"
:init 'helm-colors-init
:get-line 'buffer-substring
:keymap helm-color-map
:persistent-help "Kill entry in RGB format."
:persistent-action 'helm-color-kill-rgb
:help-message 'helm-colors-help-message
:action
'(("Copy Name (C-c N)" . helm-color-kill-name)
("Copy RGB (C-c R)" . helm-color-kill-rgb)
("Insert Name (C-c n)" . helm-color-insert-name)
("Insert RGB (C-c r)" . helm-color-insert-rgb))))
(defun helm-colors-get-name (candidate)
"Get color name."
(replace-regexp-in-string
" " ""
(with-temp-buffer
(insert (capitalize candidate))
(goto-char (point-min))
(search-forward-regexp "\\s-\\{2,\\}")
(delete-region (point) (point-max))
(buffer-string))))
(defun helm-colors-get-rgb (candidate)
"Get color RGB."
(replace-regexp-in-string
" " ""
(with-temp-buffer
(insert (capitalize candidate))
(goto-char (point-max))
(search-backward-regexp "\\s-\\{2,\\}")
(delete-region (point) (point-min))
(buffer-string))))
;;;###autoload
(defun helm-colors ()
"Preconfigured `helm' for color."
(interactive)
(helm :sources '(helm-source-colors helm-source-customize-face)
:buffer "*helm colors*"))
(provide 'helm-color)
;;; helm-color.el ends here

View file

@ -102,7 +102,7 @@ If BUFFER is nil, use current buffer."
(funcall it) (funcall it)
(comint-next-prompt 1))) (comint-next-prompt 1)))
(push (list (buffer-substring-no-properties (push (list (buffer-substring-no-properties
it (pos-eol)) it (point-at-eol))
it (buffer-name) count) it (buffer-name) count)
result) result)
(setq count (1+ count)))) (setq count (1+ count))))
@ -218,7 +218,7 @@ See `helm-comint-prompts-list'."
(member major-mode helm-comint-mode-list)) (member major-mode helm-comint-mode-list))
(helm :sources 'helm-source-comint-input-ring (helm :sources 'helm-source-comint-input-ring
:input (buffer-substring-no-properties (comint-line-beginning-position) :input (buffer-substring-no-properties (comint-line-beginning-position)
(pos-eol)) (point-at-eol))
:buffer "*helm comint history*"))) :buffer "*helm comint history*")))
(provide 'helm-comint) (provide 'helm-comint)

View file

@ -0,0 +1,413 @@
;;; helm-command.el --- Helm execute-exended-command. -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(require 'helm-mode)
(require 'helm-elisp)
(defvar helm-M-x-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-comp-read-map)
(define-key map (kbd "C-u") nil)
(define-key map (kbd "C-u") #'helm-M-x-universal-argument)
(define-key map (kbd "C-]") #'helm-M-x-toggle-short-doc)
map))
(defgroup helm-command nil
"Emacs command related Applications and libraries for Helm."
:group 'helm)
(defcustom helm-M-x-always-save-history nil
"`helm-M-x' save command in `extended-command-history' even when it fails."
:type 'boolean)
(defcustom helm-M-x-reverse-history nil
"The history source of `helm-M-x' appear in second position when non-nil."
:type 'boolean)
(defcustom helm-M-x-fuzzy-match t
"Helm-M-x fuzzy matching when non nil."
:type 'boolean)
(defcustom helm-M-x-show-short-doc nil
"Show short docstring of command when non nil.
This value can be toggled with
\\<helm-M-x-map>\\[helm-M-x-toggle-short-doc] while in helm-M-x session."
:type 'boolean)
;;; Faces
;;
;;
(defgroup helm-command-faces nil
"Customize the appearance of helm-command."
:prefix "helm-"
:group 'helm-command
:group 'helm-faces)
(defface helm-M-x-key
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "orange" :box (:line-width -1)))
"Face used in helm-M-x to show keybinding."
:group 'helm-command-faces)
(defface helm-command-active-mode
'((t :inherit font-lock-builtin-face))
"Face used by `helm-M-x' for activated modes."
:group 'helm-command-faces)
(defface helm-M-x-short-doc
'((t :box (:line-width -1) :foreground "DimGray"))
"Face used by `helm-M-x' for short docstring."
:group 'helm-command-faces)
(defvar helm-M-x-input-history nil)
(defvar helm-M-x-prefix-argument nil
"Prefix argument before calling `helm-M-x'.")
(defvar helm-M-x--timer nil)
(defvar helm-M-x--unwind-forms-done nil)
(defun helm-M-x-get-major-mode-command-alist (mode-map)
"Return alist of MODE-MAP."
(when mode-map
(cl-loop for key being the key-seqs of mode-map using (key-bindings com)
for str-key = (key-description key)
for ismenu = (string-match "<menu-bar>" str-key)
unless ismenu collect (cons str-key com))))
(defun helm-get-mode-map-from-mode (mode)
"Guess the mode-map name according to MODE.
Some modes don't use conventional mode-map name so we need to
guess mode-map name. E.g. `python-mode' ==> py-mode-map.
Return nil if no mode-map found."
(cl-loop ;; Start with a conventional mode-map name.
with mode-map = (intern-soft (format "%s-map" mode))
with mode-string = (symbol-name mode)
with mode-name = (replace-regexp-in-string "-mode" "" mode-string)
while (not mode-map)
for count downfrom (length mode-name)
;; Return when no result after parsing entire string.
when (eq count 0) return nil
for sub-name = (substring mode-name 0 count)
do (setq mode-map (intern-soft (format "%s-map" (concat sub-name "-mode"))))
finally return mode-map))
(defun helm-M-x-current-mode-map-alist ()
"Return mode-map alist of current `major-mode'."
(let ((map-sym (helm-get-mode-map-from-mode major-mode)))
(when (and map-sym (boundp map-sym))
(helm-M-x-get-major-mode-command-alist (symbol-value map-sym)))))
(defun helm-M-x-toggle-short-doc ()
"Toggle short doc display in helm-M-x."
(interactive)
(setq helm-M-x-show-short-doc (not helm-M-x-show-short-doc))
(helm-force-update (concat "^" (helm-get-selection)) (helm-get-current-source)))
(put 'helm-M-x-toggle-short-doc 'no-helm-mx t)
(defun helm-M-x-transformer-1 (candidates &optional sort ignore-props)
"Transformer function to show bindings in emacs commands.
Show global bindings and local bindings according to current
`major-mode'.
If SORT is non nil sort list with `helm-generic-sort-fn'.
Note that SORT should not be used when fuzzy matching because
fuzzy matching is running its own sort function with a different
algorithm."
(with-helm-current-buffer
(cl-loop with max-len = (when helm-M-x-show-short-doc
(buffer-local-value 'helm-candidate-buffer-longest-len
(get-buffer (helm-candidate-buffer))))
with local-map = (helm-M-x-current-mode-map-alist)
for cand in candidates
for local-key = (car (rassq cand local-map))
for key = (substitute-command-keys (format "\\[%s]" cand))
for sym = (intern (if (consp cand) (car cand) cand))
for doc = (when max-len
(helm-get-first-line-documentation (intern-soft cand)))
for disp = (if (or (eq sym major-mode)
(and (memq sym minor-mode-list)
(boundp sym)
(buffer-local-value sym helm-current-buffer)))
(propertize cand 'face 'helm-command-active-mode)
cand)
unless (and (null ignore-props) (or (get sym 'helm-only) (get sym 'no-helm-mx)))
collect
(cons (cond ((and (string-match "^M-x" key) local-key)
(format "%s%s%s %s"
disp
(if doc (make-string (+ 1 (- max-len (length cand))) ? ) "")
(if doc (propertize doc 'face 'helm-M-x-short-doc) "")
(propertize
" " 'display
(propertize local-key 'face 'helm-M-x-key))))
((string-match "^M-x" key)
(format "%s%s%s"
disp
(if doc (make-string (+ 1 (- max-len (length cand))) ? ) "")
(if doc (propertize doc 'face 'helm-M-x-short-doc) "")))
(t (format "%s%s%s %s"
disp
(if doc (make-string (+ 1 (- max-len (length cand))) ? ) "")
(if doc (propertize doc 'face 'helm-M-x-short-doc) "")
(propertize
" " 'display
(propertize key 'face 'helm-M-x-key)))))
cand)
into ls
finally return
(if sort (sort ls #'helm-generic-sort-fn) ls))))
(defun helm-M-x-transformer (candidates _source)
"Transformer function for `helm-M-x' candidates."
;; Generic sort function is handling helm-flex.
(helm-M-x-transformer-1 candidates (null helm--in-fuzzy)))
(defun helm-M-x-transformer-no-sort (candidates _source)
"Transformer function for `helm-M-x' candidates."
(helm-M-x-transformer-1 candidates))
(defun helm-M-x-transformer-no-sort-no-props (candidates _source)
"Transformer function for `helm-M-x' candidates."
(helm-M-x-transformer-1 candidates nil t))
(defun helm-M-x--notify-prefix-arg ()
;; Notify a prefix-arg set AFTER calling M-x.
(when prefix-arg
(with-helm-window
(helm-display-mode-line (helm-get-current-source) 'force))))
(defun helm-cmd--get-current-function-name ()
(save-excursion
(beginning-of-defun)
(cadr (split-string (buffer-substring-no-properties
(point-at-bol) (point-at-eol))))))
(defun helm-cmd--get-preconfigured-commands (&optional dir)
(let* ((helm-dir (or dir (helm-basedir (locate-library "helm"))))
(helm-autoload-file (expand-file-name "helm-autoloads.el" helm-dir))
results)
(when (file-exists-p helm-autoload-file)
(with-temp-buffer
(insert-file-contents helm-autoload-file)
(while (re-search-forward "Preconfigured" nil t)
(push (substring (helm-cmd--get-current-function-name) 1) results))))
results))
(defun helm-M-x-universal-argument ()
"Same as `universal-argument' but for `helm-M-x'."
(interactive)
(if helm-M-x-prefix-argument
(progn (setq helm-M-x-prefix-argument nil)
(let ((inhibit-read-only t))
(with-selected-window (minibuffer-window)
(save-excursion
(goto-char (point-min))
(delete-char (- (minibuffer-prompt-width) (length "M-x "))))))
(message "Initial prefix arg disabled"))
(setq prefix-arg (list 4))
(universal-argument--mode)))
(put 'helm-M-x-universal-argument 'helm-only t)
(defun helm-M-x-persistent-action (candidate)
(helm-elisp--persistent-help
candidate 'helm-describe-function))
(defun helm-M-x--move-selection-after-hook ()
(setq current-prefix-arg nil))
(defun helm-M-x--before-action-hook ()
(remove-hook 'helm-move-selection-after-hook
#'helm-M-x--move-selection-after-hook))
(defclass helm-M-x-class (helm-source-in-buffer helm-type-command)
((requires-pattern :initform 0)
(must-match :initform t)
(filtered-candidate-transformer :initform 'helm-M-x-transformer-no-sort)
(persistent-help :initform "Describe this command")
(help-message :initform 'helm-M-x-help-message)
(nomark :initform t)
(cleanup :initform #'helm-M-x--unwind-forms)
(keymap :initform 'helm-M-x-map)
(resume :initform 'helm-M-x-resume-fn)))
(defun helm-M-x-resume-fn ()
(when (and helm-M-x--timer (timerp helm-M-x--timer))
(cancel-timer helm-M-x--timer)
(setq helm-M-x--timer nil))
(setq helm-M-x--timer (run-at-time 1 0.1 #'helm-M-x--notify-prefix-arg))
(setq helm--mode-line-display-prefarg t)
;; Prevent displaying a wrong prefix arg when helm-resume is called
;; from prefix arg.
(setq current-prefix-arg nil))
(defun helm-M-x-read-extended-command (collection &optional predicate history)
"Read or execute action on command name in COLLECTION or HISTORY.
When `helm-M-x-use-completion-styles' is used, Emacs
`completion-styles' mechanism is used, otherwise standard helm
completion and helm fuzzy matching are used together.
Helm completion is not provided when executing or defining kbd
macros.
Arg COLLECTION should be an `obarray' but can be any object
suitable for `try-completion'. Arg PREDICATE is a function that
default to `commandp' see also `try-completion'. Arg HISTORY
default to `extended-command-history'."
(setq helm--mode-line-display-prefarg t)
(let* ((pred (or predicate #'commandp))
(helm-fuzzy-sort-fn (lambda (candidates _source)
;; Sort on real candidate otherwise
;; "symbol (<binding>)" is used when sorting.
(helm-fuzzy-matching-default-sort-fn-1 candidates t)))
(sources `(,(helm-make-source "Emacs Commands history" 'helm-M-x-class
:data (lambda ()
(helm-comp-read-get-candidates
;; History should be quoted to
;; force `helm-comp-read-get-candidates'
;; to use predicate against
;; symbol and not string.
(or history 'extended-command-history)
;; Ensure using empty string to
;; not defeat helm matching fns [1]
pred nil nil ""))
:fuzzy-match helm-M-x-fuzzy-match)
,(helm-make-source "Emacs Commands" 'helm-M-x-class
:data (lambda ()
(helm-comp-read-get-candidates
;; [1] Same comment as above.
collection pred nil nil ""))
:fuzzy-match helm-M-x-fuzzy-match)))
(prompt (concat (cond
((eq helm-M-x-prefix-argument '-) "- ")
((and (consp helm-M-x-prefix-argument)
(eq (car helm-M-x-prefix-argument) 4))
"C-u ")
((and (consp helm-M-x-prefix-argument)
(integerp (car helm-M-x-prefix-argument)))
(format "%d " (car helm-M-x-prefix-argument)))
((integerp helm-M-x-prefix-argument)
(format "%d " helm-M-x-prefix-argument)))
"M-x ")))
(setq helm-M-x--timer (run-at-time 1 0.1 #'helm-M-x--notify-prefix-arg))
;; Fix Bug#2250, add `helm-move-selection-after-hook' which
;; reset prefix arg to nil only for this helm session.
(add-hook 'helm-move-selection-after-hook
#'helm-M-x--move-selection-after-hook)
(add-hook 'helm-before-action-hook
#'helm-M-x--before-action-hook)
(when (and sources helm-M-x-reverse-history)
(setq sources (nreverse sources)))
(unwind-protect
(progn
(setq current-prefix-arg nil)
(helm :sources sources
:prompt prompt
:buffer "*helm M-x*"
:history 'helm-M-x-input-history
:truncate-lines t))
(helm-M-x--unwind-forms))))
;; When running a command involving again helm from helm-M-x, the
;; unwind-protect UNWINDS forms are executed only once this helm
;; command exit leaving the helm-M-x timer running and other variables
;; and hooks not unset, so the timer is now in a global var and all
;; the forms that should normally run in unwind-protect are running as
;; well as soon as helm-M-x-execute-command is called.
(defun helm-M-x--unwind-forms (&optional done)
;; helm-M-x--unwind-forms-done is non nil when it have been called
;; once from helm-M-x-execute-command.
(unless helm-M-x--unwind-forms-done
(when (timerp helm-M-x--timer)
(cancel-timer helm-M-x--timer)
(setq helm-M-x--timer nil))
(setq helm--mode-line-display-prefarg nil
helm-fuzzy-sort-fn (default-toplevel-value 'helm-fuzzy-sort-fn))
;; Be sure to remove it here as well in case of quit.
(remove-hook 'helm-move-selection-after-hook
#'helm-M-x--move-selection-after-hook)
(remove-hook 'helm-before-action-hook
#'helm-M-x--before-action-hook))
;; Reset helm-M-x--unwind-forms-done to nil when DONE is
;; unspecified.
(setq helm-M-x--unwind-forms-done done))
(defun helm-M-x-execute-command (command)
"Execute COMMAND as an editor command.
COMMAND must be a symbol that satisfies the `commandp' predicate.
Save COMMAND to `extended-command-history'."
(helm-M-x--unwind-forms t)
(when command
;; Avoid having `this-command' set to *exit-minibuffer.
(setq this-command command
;; Handle C-x z (repeat) Bug#322
real-this-command command)
;; If helm-M-x is called with regular emacs completion (kmacro)
;; use the value of arg otherwise use helm-current-prefix-arg.
(let ((prefix-arg (or helm-current-prefix-arg helm-M-x-prefix-argument))
(command-name (symbol-name command)))
(condition-case-unless-debug err
(progn
(command-execute command 'record)
(add-to-history 'extended-command-history command-name))
(error
(when helm-M-x-always-save-history
(add-to-history 'extended-command-history command-name))
(signal (car err) (cdr err)))))))
(defun helm-M-x--vanilla-M-x ()
(helm-M-x-execute-command
(intern-soft
(if helm-mode
(unwind-protect
(progn
(helm-mode -1)
(read-extended-command))
(helm-mode 1))
(read-extended-command)))))
;;;###autoload
(defun helm-M-x (_arg)
"Preconfigured `helm' for Emacs commands.
It is `helm' replacement of regular `M-x'
`execute-extended-command'.
Unlike regular `M-x' Emacs vanilla `execute-extended-command'
command, the prefix args if needed, can be passed AFTER starting
`helm-M-x'. When a prefix arg is passed BEFORE starting
`helm-M-x', the first `C-u' while in `helm-M-x' session will
disable it.
You can get help on each command by persistent action."
(interactive
(progn
(setq helm-M-x-prefix-argument current-prefix-arg)
(list current-prefix-arg)))
(if (or defining-kbd-macro executing-kbd-macro)
(helm-M-x--vanilla-M-x)
(helm-M-x-read-extended-command obarray)))
(put 'helm-M-x 'interactive-only 'command-execute)
(provide 'helm-command)
;;; helm-command.el ends here

View file

@ -1,9 +1,6 @@
;;; nerd-icons-data-ipsicon.el --- glyphset ipsicon -*- lexical-binding: t -*- ;;; helm-config.el --- Applications library for `helm.el' -*- lexical-binding: t -*-
;; Copyright (C) 2023 Hongyu Ding <rainstormstudio@yahoo.com> ;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; Author: Hongyu Ding <rainstormstudio@yahoo.com>
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify ;; 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 ;; it under the terms of the GNU General Public License as published by
@ -19,20 +16,17 @@
;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary: ;;; Commentary:
;;
;; ipsicon ;; Requiring this file is not needed when using a package manager to
;; from Nerd Font Version: 3.0.1 ;; install helm as this one will take care of creating and loading the
;; autoload file.
;;; Code: ;;; Code:
(defvar nerd-icons/ipsicon-alist ;;; Load the autoload file generated by the make file.
'(
("nf-iec-power" . "\x23fb")
("nf-iec-power_off" . "\x2b58")
("nf-iec-power_on" . "\x23fd")
("nf-iec-sleep_mode" . "\x23fe")
("nf-iec-toggle_power" . "\x23fc")
))
(provide 'nerd-icons-data-ipsicon) (load "helm-autoloads" nil t)
;;; nerd-icons-data-ipsicon.el ends here
(provide 'helm-config)
;;; helm-config.el ends here

View file

@ -0,0 +1,388 @@
;;; helm-dabbrev.el --- Helm implementation of dabbrev. -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'helm)
(require 'helm-lib)
(require 'helm-help)
(require 'helm-elisp) ; For show-completion.
(defgroup helm-dabbrev nil
"Dabbrev related Applications and libraries for Helm."
:group 'helm)
(defcustom helm-dabbrev-always-search-all t
"Always search in all buffers when non--nil.
Note that even if nil, a search in all buffers will occur if the
length of candidates is <= than
`helm-dabbrev-max-length-result'."
:type 'boolean)
(defcustom helm-dabbrev-candidates-number-limit 1000
"Maximum number of candidates to collect.
The higher this number is, the slower the computation of
candidates will be. You can use safely a higher value with
emacs-26+.
Note that this have nothing to do with
`helm-candidate-number-limit', this means that computation of
candidates stop when this value is reached but only
`helm-candidate-number-limit' candidates are displayed in the
Helm buffer."
:type 'integer)
(defcustom helm-dabbrev-ignored-buffers-regexps
'("\\*helm" "\\*Messages" "\\*Echo Area" "\\*Buffer List")
"List of regexps matching names of buffers that `helm-dabbrev' should not check."
:type '(repeat regexp))
(defcustom helm-dabbrev-related-buffer-fn #'helm-dabbrev--same-major-mode-p
"A function that decide if a buffer to search in its related to `current-buffer'.
This is actually determined by comparing `major-mode' of the
buffer to search and the `current-buffer'.
The function take one arg, the buffer which is current, look at
`helm-dabbrev--same-major-mode-p' for an example.
When nil all buffers are considered related to `current-buffer'."
:type 'function)
(defcustom helm-dabbrev-major-mode-assoc nil
"Major mode association alist.
This allow helm-dabbrev searching in buffers with the associated
`major-mode'.
E.g. (emacs-lisp-mode . lisp-interaction-mode)
will allow searching in the lisp-interaction-mode buffer when
`current-buffer' is an `emacs-lisp-mode' buffer and vice versa
i.e. no need to provide (lisp-interaction-mode .
emacs-lisp-mode) association.
When nil check is the searched buffer has same `major-mode' than
the `current-buffer'.
This has no effect when `helm-dabbrev-related-buffer-fn' is nil
or of course bound to a function that doesn't handle this var."
:type '(alist :key-type symbol :value-type symbol))
(defcustom helm-dabbrev-lineno-around 30
"Search first in this number of lines before and after point."
:type 'integer)
(defcustom helm-dabbrev-cycle-threshold 5
"Number of time helm-dabbrev cycle before displaying helm completion.
When nil or 0 disable cycling."
:type '(choice (const :tag "Cycling disabled" nil) integer))
(defcustom helm-dabbrev-case-fold-search 'smart
"Set `case-fold-search' in `helm-dabbrev'.
Same as `helm-case-fold-search' but for `helm-dabbrev'.
Note that this is not affecting searching in Helm buffer, but the
initial search for all candidates in buffer(s)."
:type '(choice (const :tag "Ignore case" t)
(const :tag "Respect case" nil)
(other :tag "Smart" smart)))
(defvaralias 'helm-dabbrev--regexp 'helm-dabbrev-separator-regexp)
(make-obsolete-variable 'helm-dabbrev--regexp
'helm-dabbrev-separator-regexp "2.8.3")
;; Check for beginning of line should happen last (^\n\\|^).
(defvar helm-dabbrev-separator-regexp
"\\s-\\|\t\\|[(\\[\\{\"'`=<>$;,@.#+]\\|\\s\\\\|^\n\\|^"
"Regexp matching the start of a dabbrev candidate.")
(defvar helm-dabbrev-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "M-/") #'helm-next-line)
(define-key map (kbd "M-:") #'helm-previous-line)
map))
;; Internal
(defvar helm-dabbrev--cache nil)
(defvar helm-dabbrev--data nil)
(cl-defstruct helm-dabbrev-info dabbrev limits iterator)
(defvar helm-dabbrev--already-tried nil)
(defvar helm-dabbrev--computing-cache nil
"[INTERNAL] Flag to notify helm-dabbrev is blocked.
Do nothing when non nil.")
(defun helm-dabbrev--buffer-list ()
(cl-loop for buf in (buffer-list)
unless (cl-loop for r in helm-dabbrev-ignored-buffers-regexps
thereis (string-match r (buffer-name buf)))
collect buf))
(defun helm-dabbrev--same-major-mode-p (start-buffer)
"Decide if current-buffer is related to START-BUFFER."
(helm-same-major-mode-p start-buffer helm-dabbrev-major-mode-assoc))
(defun helm-dabbrev--collect (str limit ignore-case all)
(let* ((case-fold-search ignore-case)
(buffer1 (current-buffer)) ; start buffer.
(minibuf (minibufferp buffer1))
results pos-before pos-after)
(catch 'break
(dolist (buf (if all (helm-dabbrev--buffer-list)
(list (current-buffer))))
(with-current-buffer buf
(when (or minibuf ; check against all buffers when in minibuffer.
(if helm-dabbrev-related-buffer-fn
(funcall helm-dabbrev-related-buffer-fn buffer1)
t))
(save-excursion
;; Start searching before thing before point.
(goto-char (- (point) (length str)))
;; Search the last 30 lines BEFORE point and set POS-BEFORE.
(cl-multiple-value-bind (res _pa pb)
(helm-dabbrev--search-and-store str -2 limit results)
(setq results res
;; No need to set POS-AFTER here.
pos-before pb)))
(save-excursion
;; Search the next 30 lines AFTER point and set POS-AFTER.
(cl-multiple-value-bind (res pa _pb)
(helm-dabbrev--search-and-store str 2 limit results)
(setq results res
;; No need to set POS-BEFORE, we keep the last
;; value found.
pos-after pa)))
(save-excursion
;; Search all BEFORE point maybe starting from
;; POS-BEFORE to not search again what previously found.
;; If limit is reached in previous call of
;; `helm-dabbrev--search-and-store' POS-BEFORE is nil and
;; goto-char will fail, so check it.
(when pos-before (goto-char pos-before))
(cl-multiple-value-bind (res _pa _pb)
(helm-dabbrev--search-and-store str -1 limit results)
;; No need to set POS-BEFORE and POS-AFTER here.
(setq results res)))
(save-excursion
;; Search all AFTER point maybe starting from POS-AFTER.
;; Same comment as above for POS-AFTER.
(when pos-after (goto-char pos-after))
(cl-multiple-value-bind (res _pa _pb)
(helm-dabbrev--search-and-store str 1 limit results)
;; No need to set POS-BEFORE and POS-AFTER here.
(setq results res)))))
(when (>= (length results) limit) (throw 'break nil))))
(nreverse results)))
(defun helm-dabbrev--search-and-store (pattern direction limit results)
"Search words or symbols matching PATTERN in DIRECTION up to LIMIT.
Finally returns all matched candidates appended to RESULTS.
Argument DIRECTION can be:
- (1): Search forward from point.
- (-1): Search backward from point.
- (2): Search forward from the
`helm-dabbrev-lineno-around'
lines after point.
- (-2): Search backward from the
`helm-dabbrev-lineno-around'
lines before point."
(let ((res results)
after before)
(while (and (<= (length res) limit)
(cl-case direction
(1 (search-forward pattern nil t))
(-1 (search-backward pattern nil t))
(2 (let ((pos
(save-excursion
(forward-line
helm-dabbrev-lineno-around)
(point))))
(setq after pos)
(search-forward pattern pos t)))
(-2 (let ((pos
(save-excursion
(forward-line
(- helm-dabbrev-lineno-around))
(point))))
(setq before pos)
(search-backward pattern pos t)))))
(let* ((mb (match-beginning 0))
(replace-regexp (concat "\\(" helm-dabbrev-separator-regexp
"\\)\\'"))
(match-word (helm-dabbrev--search
pattern mb replace-regexp)))
(when (and match-word (not (member match-word res)))
(push match-word res))))
(list res after before)))
(defun helm-dabbrev--search (pattern beg sep-regexp)
"Search word or symbol at point matching PATTERN.
Argument BEG is corresponding to the previous `match-beginning'
search.
The search starts at (1- BEG) with a regexp starting with
`helm-dabbrev-separator-regexp' followed by PATTERN followed by a
regexp matching syntactically any word or symbol.
The possible false positives matching SEP-REGEXP at end are
finally removed."
(let ((eol (point-at-eol)))
(save-excursion
(goto-char (1- beg))
(when (re-search-forward
(concat "\\("
helm-dabbrev-separator-regexp
"\\)"
"\\(?99:\\("
(regexp-quote pattern)
"\\(\\sw\\|\\s_\\)+\\)\\)")
eol t)
(replace-regexp-in-string
sep-regexp ""
(match-string-no-properties 99))))))
(defun helm-dabbrev--get-candidates (dabbrev &optional limit)
(cl-assert dabbrev nil "[No Match]")
(helm-dabbrev--collect
dabbrev (or limit helm-dabbrev-candidates-number-limit)
(cl-case helm-dabbrev-case-fold-search
(smart (helm-set-case-fold-search-1 dabbrev))
(t helm-dabbrev-case-fold-search))
helm-dabbrev-always-search-all))
(defun helm-dabbrev-default-action (candidate)
(with-helm-current-buffer
(let* ((limits (helm-bounds-of-thing-before-point
helm-dabbrev-separator-regexp))
(beg (car limits))
(end (point)))
(run-with-timer
0.01 nil
#'helm-insert-completion-at-point
beg end candidate))))
;;;###autoload
(cl-defun helm-dabbrev ()
"Preconfigured helm for dynamic abbreviations."
(interactive)
(unless helm-dabbrev--computing-cache
(let ((dabbrev (helm-thing-before-point
nil helm-dabbrev-separator-regexp))
(limits (helm-bounds-of-thing-before-point
helm-dabbrev-separator-regexp))
(enable-recursive-minibuffers t)
(cycling-disabled-p (or (null helm-dabbrev-cycle-threshold)
(zerop helm-dabbrev-cycle-threshold)))
(helm-execute-action-at-once-if-one t)
(helm-quit-if-no-candidate
(lambda ()
(message "[Helm-dabbrev: No expansion found]"))))
(cl-assert (and (stringp dabbrev) (not (string= dabbrev "")))
nil "[Helm-dabbrev: Nothing found before point]")
(when (and
;; have been called at least once.
(helm-dabbrev-info-p helm-dabbrev--data)
;; But user have moved with some other command
;; in the meaning time.
(not (eq last-command 'helm-dabbrev)))
(setq helm-dabbrev--data nil))
;; When candidates are requested in helm directly without cycling,
;; we need them right now before running helm.
(when cycling-disabled-p
(message "Waiting for helm-dabbrev candidates...")
(setq helm-dabbrev--cache (helm-dabbrev--get-candidates dabbrev)))
(unless (or cycling-disabled-p
(helm-dabbrev-info-p helm-dabbrev--data))
(setq helm-dabbrev--data
(make-helm-dabbrev-info
:dabbrev dabbrev
:limits limits
:iterator
(helm-iter-list
(cl-loop for i in (helm-dabbrev--get-candidates
dabbrev helm-dabbrev-cycle-threshold)
when (string-match-p
(concat "^" (regexp-quote dabbrev)) i)
collect i)))))
(let ((iter (and (helm-dabbrev-info-p helm-dabbrev--data)
(helm-dabbrev-info-iterator helm-dabbrev--data)))
deactivate-mark)
;; Cycle until iterator is consumed.
(helm-aif (and iter (helm-iter-next iter))
(progn
(helm-insert-completion-at-point
(car (helm-dabbrev-info-limits helm-dabbrev--data))
;; END is the end of the previous inserted string, not
;; the end (apart for first insertion) of the initial string.
(cdr limits) it)
;; Move already tried candidates to end of list.
(push it helm-dabbrev--already-tried))
;; Iterator is now empty, or cycling was disabled, maybe
;; reset dabbrev to initial value and start helm completion.
(let* ((old-dabbrev (if (helm-dabbrev-info-p helm-dabbrev--data)
(helm-dabbrev-info-dabbrev helm-dabbrev--data)
dabbrev))
(only-one (eq (length helm-dabbrev--already-tried) 1)))
(unless helm-dabbrev--cache ; Already computed when
; cycling is disabled.
(message "Waiting for helm-dabbrev candidates...")
(setq helm-dabbrev--computing-cache t)
(setq helm-dabbrev--cache
(helm-dabbrev--get-candidates old-dabbrev))
;; If user continues typing M-/ while display is blocked by
;; helm-dabbrev--get-candidates delete these events.
(setq unread-command-events nil))
;; If the length of candidates is only one when computed
;; that's mean the unique matched item have already been
;; inserted by the iterator, so no need to reinsert the old dabbrev,
;; just let helm exiting with "No expansion found".
(unless (or only-one cycling-disabled-p)
(setq dabbrev old-dabbrev
limits (helm-dabbrev-info-limits helm-dabbrev--data))
(setq helm-dabbrev--data nil)
(delete-region (car limits) (point))
(insert dabbrev))
(when (and (null cycling-disabled-p) only-one)
(setq helm-dabbrev--cache nil
helm-dabbrev--already-tried nil
helm-dabbrev--computing-cache nil)
(cl-return-from helm-dabbrev
(message "[Helm-dabbrev: No expansion found]")))
(with-helm-show-completion (car limits) (cdr limits)
(unwind-protect
(helm :sources
(helm-build-in-buffer-source "Dabbrev Expand"
:data
(append
(cl-loop with lst = helm-dabbrev--cache
for cand in helm-dabbrev--already-tried
do (setq lst (delete cand lst))
finally return lst)
helm-dabbrev--already-tried)
:persistent-action 'ignore
:persistent-help "DoNothing"
:keymap helm-dabbrev-map
:action 'helm-dabbrev-default-action
:group 'helm-dabbrev)
:buffer "*helm dabbrev*"
:input (concat "^" dabbrev " ")
:resume 'noresume
:allow-nest t)
(setq helm-dabbrev--computing-cache nil
helm-dabbrev--already-tried nil
helm-dabbrev--cache nil)))))))))
(provide 'helm-dabbrev)
;;; helm-dabbrev.el ends here

View file

@ -0,0 +1,483 @@
;;; helm-elisp-package.el --- helm interface for package.el -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(require 'package)
(defgroup helm-el-package nil
"helm elisp packages."
:group 'helm)
(defcustom helm-el-package-initial-filter 'all
"Show only installed, upgraded or all packages at startup."
:type '(radio :tag "Initial filter for elisp packages"
(const :tag "Show all packages" all)
(const :tag "Show installed packages" installed)
(const :tag "Show not installed packages" uninstalled)
(const :tag "Show upgradable packages" upgrade)))
(defcustom helm-el-truncate-lines t
"Truncate lines in `helm-buffer' when non-nil."
:type 'boolean)
(defcustom helm-el-package-upgrade-on-start nil
"Show package upgrades on startup when non nil."
:type 'boolean)
(defcustom helm-el-package-autoremove-on-start nil
"Try to autoremove no more needed packages on startup.
See `package-autoremove'."
:type 'boolean)
;; internals vars
(defvar helm-el-package--show-only 'all)
(defvar helm-el-package--initialized-p nil)
(defvar helm-el-package--tabulated-list nil)
(defvar helm-el-package--upgrades nil)
(defvar helm-el-package--removable-packages nil)
;; Shutup bytecompiler for emacs-24*
(defvar package-menu-async) ; Only available on emacs-25.
(defvar helm-marked-buffer-name)
(declare-function async-byte-recompile-directory "ext:async-bytecomp.el")
(declare-function with-helm-display-marked-candidates "helm-utils.el")
(defun helm-el-package--init ()
;; In emacs-27 package-show-package-list returns an empty buffer
;; until package-initialize have been called.
(unless (or package--initialized
(null (boundp 'package-quickstart)))
(package-initialize))
(let (package-menu-async
(inhibit-read-only t))
(when (null package-alist)
(setq helm-el-package--show-only 'all))
(unless (consp package-selected-packages)
(helm-aif (package--find-non-dependencies)
(setq package-selected-packages it)))
(when (and (setq helm-el-package--removable-packages
(package--removable-packages))
helm-el-package-autoremove-on-start)
(package-autoremove))
(unwind-protect
(progn
(save-selected-window
(if helm-el-package--initialized-p
;; Use this as `list-packages' doesn't work
;; properly (empty buffer) when called from lisp
;; with 'no-fetch (emacs-25 WA).
(package-show-package-list)
(when helm--force-updating-p (message "Refreshing packages list..."))
(list-packages helm-el-package--initialized-p))
(setq helm-el-package--initialized-p t)
(message nil))
(helm-init-candidates-in-buffer
'global
(with-current-buffer (get-buffer "*Packages*")
(setq helm-el-package--tabulated-list tabulated-list-entries)
(remove-text-properties (point-min) (point-max)
'(read-only button follow-link category))
(goto-char (point-min))
(while (re-search-forward "^[ \t]+" nil t)
(replace-match ""))
(buffer-string)))
(setq helm-el-package--upgrades (helm-el-package-menu--find-upgrades))
(if helm--force-updating-p
(if helm-el-package--upgrades
(message "Refreshing packages list done, [%d] package(s) to upgrade"
(length helm-el-package--upgrades))
(message "Refreshing packages list done, no upgrades available"))
(setq helm-el-package--show-only (if (and helm-el-package-upgrade-on-start
helm-el-package--upgrades)
'upgrade
helm-el-package-initial-filter))))
(kill-buffer "*Packages*"))))
(defun helm-el-package-describe (candidate)
(let ((id (get-text-property 0 'tabulated-list-id candidate)))
(describe-package (package-desc-name id))))
(defun helm-el-package-visit-homepage (candidate)
(let* ((id (get-text-property 0 'tabulated-list-id candidate))
(pkg (package-desc-name id))
(desc (cadr (assoc pkg package-archive-contents)))
(extras (package-desc-extras desc))
(url (and (listp extras) (cdr-safe (assoc :url extras)))))
(if (stringp url)
(browse-url url)
(message "Package %s has no homepage"
(propertize (symbol-name pkg)
'face 'font-lock-keyword-face)))))
(helm-make-command-from-action helm-el-run-visit-homepage
"Visit package homepage from helm elisp packages."
'helm-el-package-visit-homepage)
(defun helm-elisp-package--pkg-name (pkg)
(if (package-desc-p pkg)
(package-desc-name pkg)
pkg))
(defun helm-el-package-install-1 (pkg-list)
(cl-loop with mkd = pkg-list
for p in mkd
for id = (get-text-property 0 'tabulated-list-id p)
for name = (helm-elisp-package--pkg-name id)
do (package-install id t)
when (helm-aand (assq name package-alist)
(package-desc-dir (cadr it))
(file-exists-p it))
collect id into installed-list and
do (unless (package--user-selected-p name)
(package--save-selected-packages
(cons name package-selected-packages)))
finally do (message (format "%d packages installed:\n(%s)"
(length installed-list)
(mapconcat #'package-desc-full-name
installed-list ", ")))))
(defun helm-el-package-install (_candidate)
(helm-el-package-install-1 (helm-marked-candidates)))
(helm-make-command-from-action helm-el-run-package-install
"Install package from helm elisp packages."
'helm-el-package-install)
(defun helm-el-package-uninstall-1 (pkg-list &optional force)
(cl-loop with mkd = pkg-list
for p in mkd
for id = (get-text-property 0 'tabulated-list-id p)
do
(condition-case-unless-debug err
(package-delete id force)
(error (message (cadr err))))
;; Seems like package-descs are symbols with props instead of
;; vectors in emacs-27, use package-desc-name to ensure
;; compatibility in all emacs versions.
unless (assoc (package-desc-name id) package-alist)
collect id into delete-list
finally do (if delete-list
(message (format "%d packages deleted:\n(%s)"
(length delete-list)
(mapconcat #'package-desc-full-name
delete-list ", ")))
"No package deleted")))
(defun helm-el-package-uninstall (_candidate)
(helm-el-package-uninstall-1 (helm-marked-candidates) helm-current-prefix-arg))
(helm-make-command-from-action helm-el-run-package-uninstall
"Uninstall package from helm elisp packages."
'helm-el-package-uninstall)
(defun helm-el-package-menu--find-upgrades ()
(cl-loop for entry in helm-el-package--tabulated-list
for pkg-desc = (car entry)
for status = (package-desc-status pkg-desc)
;; A dependency.
when (string= status "dependency")
collect pkg-desc into dependencies
;; An installed package used as dependency (user have
;; installed this package explicitely).
when (package--used-elsewhere-p pkg-desc)
collect pkg-desc into installed-as-dep
;; An installed package.
when (member status '("installed" "unsigned"))
collect pkg-desc into installed
when (member status '("available" "new"))
collect (cons (package-desc-name pkg-desc) pkg-desc) into available
finally return
;; Always try to upgrade dependencies before installed.
(cl-loop with all = (append dependencies installed-as-dep installed)
for pkg in all
for name = (package-desc-name pkg)
for avail-pkg = (assq name available)
when (and avail-pkg
(version-list-<
(package-desc-version pkg)
(package-desc-version (cdr avail-pkg))))
collect avail-pkg)))
(defun helm-el-package--user-installed-p (package)
"Return non-nil if PACKAGE is a user-installed package."
(let* ((assoc (assq package package-alist))
(pkg-desc (and assoc (cadr assoc)))
(dir (and pkg-desc (package-desc-dir pkg-desc))))
(when dir
(file-in-directory-p dir package-user-dir))))
(defun helm-el-package-upgrade-1 (pkg-list)
(cl-loop for p in pkg-list
for pkg-desc = (car p)
for pkg-name = (package-desc-name pkg-desc)
for upgrade = (cdr (assq pkg-name
helm-el-package--upgrades))
do
(cond (;; Install.
(equal pkg-desc upgrade)
(message "Installing package `%s'" pkg-name)
(package-install pkg-desc t))
(;; Do nothing.
(or (null upgrade)
;; This may happen when a Elpa version of pkg
;; is installed and need upgrade and pkg is as
;; well a builtin package.
(package-built-in-p pkg-name))
(ignore))
(;; Delete.
t
(message "Deleting package `%s'" pkg-name)
(package-delete pkg-desc t t)))))
(defun helm-el-package-upgrade (_candidate)
(helm-el-package-upgrade-1
(cl-loop with pkgs = (helm-marked-candidates)
for p in helm-el-package--tabulated-list
for pkg = (car p)
if (member (symbol-name (package-desc-name pkg)) pkgs)
collect p)))
(helm-make-command-from-action helm-el-run-package-upgrade
"Uninstall package from helm elisp packages."
'helm-el-package-upgrade)
(defun helm-el-package-upgrade-all ()
(if helm-el-package--upgrades
(with-helm-display-marked-candidates
helm-marked-buffer-name (helm-fast-remove-dups
(mapcar (lambda (x) (symbol-name (car x)))
helm-el-package--upgrades)
:test 'equal)
(when (y-or-n-p "Upgrade all packages? ")
(helm-el-package-upgrade-1 helm-el-package--tabulated-list)))
(message "No packages to upgrade actually!")))
(defun helm-el-package-upgrade-all-action (_candidate)
(helm-el-package-upgrade-all))
(helm-make-command-from-action helm-el-run-package-upgrade-all
"Upgrade all packages from helm elisp packages."
'helm-el-package-upgrade-all-action)
(defun helm-el-package--transformer (candidates _source)
(cl-loop for c in candidates
for disp = (concat " " c)
for id = (get-text-property 0 'tabulated-list-id c)
for name = (and id (package-desc-name id))
for desc = (package-desc-status id)
for built-in-p = (and (package-built-in-p name)
(not (member desc '("available" "new"
"installed" "dependency"))))
for installed-p = (member desc '("installed" "dependency"))
for upgrade-p = (assq name helm-el-package--upgrades)
for user-installed-p = (memq name package-selected-packages)
do (when (and user-installed-p (not upgrade-p))
(put-text-property 0 2 'display "S " disp))
do (when (or (memq name helm-el-package--removable-packages)
(and upgrade-p installed-p))
(put-text-property 0 2 'display "U " disp)
(put-text-property
2 (+ (length (symbol-name name)) 2)
'face 'font-lock-variable-name-face disp))
do (when (and upgrade-p (not installed-p) (not built-in-p))
(put-text-property 0 2 'display "I " disp))
for cand = (cons disp (car (split-string disp)))
when (or (and built-in-p
(eq helm-el-package--show-only 'built-in))
(and upgrade-p
(eq helm-el-package--show-only 'upgrade))
(and installed-p
(eq helm-el-package--show-only 'installed))
(and (not installed-p)
(not built-in-p)
(eq helm-el-package--show-only 'uninstalled))
(eq helm-el-package--show-only 'all))
collect cand))
(defun helm-el-package-show-built-in ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'built-in)
(helm-update)))
(put 'helm-el-package-show-built-in 'helm-only t)
(defun helm-el-package-show-upgrade ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'upgrade)
(helm-update)))
(put 'helm-el-package-show-upgrade 'helm-only t)
(defun helm-el-package-show-installed ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'installed)
(helm-update)))
(put 'helm-el-package-show-installed 'helm-only t)
(defun helm-el-package-show-all ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'all)
(helm-update)))
(put 'helm-el-package-show-all 'helm-only t)
(defun helm-el-package-show-uninstalled ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'uninstalled)
(helm-update)))
(put 'helm-el-package-show-uninstalled 'helm-only t)
(defvar helm-el-package-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "M-I") #'helm-el-package-show-installed)
(define-key map (kbd "M-O") #'helm-el-package-show-uninstalled)
(define-key map (kbd "M-U") #'helm-el-package-show-upgrade)
(define-key map (kbd "M-B") #'helm-el-package-show-built-in)
(define-key map (kbd "M-A") #'helm-el-package-show-all)
(define-key map (kbd "C-c i") #'helm-el-run-package-install)
(define-key map (kbd "C-c r") #'helm-el-run-package-reinstall)
(define-key map (kbd "C-c d") #'helm-el-run-package-uninstall)
(define-key map (kbd "C-c u") #'helm-el-run-package-upgrade)
(define-key map (kbd "C-c U") #'helm-el-run-package-upgrade-all)
(define-key map (kbd "C-c @") #'helm-el-run-visit-homepage)
map))
(defvar helm-source-list-el-package nil)
(defclass helm-list-el-package-source (helm-source-in-buffer)
((init :initform 'helm-el-package--init)
(get-line :initform 'buffer-substring)
(filtered-candidate-transformer :initform 'helm-el-package--transformer)
(action-transformer :initform 'helm-el-package--action-transformer)
(help-message :initform 'helm-el-package-help-message)
(keymap :initform 'helm-el-package-map)
(update :initform 'helm-el-package--update)
(candidate-number-limit :initform 9999)
(action :initform '(("Describe package" . helm-el-package-describe)
("Visit homepage" . helm-el-package-visit-homepage)))
(find-file-target :initform #'helm-el-package-quit-an-find-file-fn)
(group :initform 'helm-el-package)))
(defun helm-el-package-quit-an-find-file-fn (source)
(let* ((sel (helm-get-selection nil nil source))
(pkg (and (stringp sel)
(get-text-property 0 'tabulated-list-id sel))))
(when (and pkg (package-installed-p pkg))
(expand-file-name (package-desc-dir pkg)))))
(defun helm-el-package--action-transformer (actions candidate)
(let* ((pkg-desc (get-text-property 0 'tabulated-list-id candidate))
(status (package-desc-status pkg-desc))
(pkg-name (package-desc-name pkg-desc))
(built-in (and (package-built-in-p pkg-name)
(not (member status '("available" "new"
"installed" "dependency")))))
(acts (if helm-el-package--upgrades
(append actions '(("Upgrade all packages"
. helm-el-package-upgrade-all-action)))
actions)))
(cond (built-in '(("Describe package" . helm-el-package-describe)))
((and (package-installed-p pkg-name)
(cdr (assq pkg-name helm-el-package--upgrades))
(member status '("installed" "dependency")))
(append '(("Upgrade package(s)" . helm-el-package-upgrade)
("Uninstall package(s)" . helm-el-package-uninstall))
acts))
((and (package-installed-p pkg-name)
(cdr (assq pkg-name helm-el-package--upgrades))
(string= status "available"))
(append '(("Upgrade package(s)" . helm-el-package-upgrade))
acts))
((and (package-installed-p pkg-name)
(or (null (package-built-in-p pkg-name))
(and (package-built-in-p pkg-name)
(assq pkg-name package-alist))))
(append acts '(("Reinstall package(s)" . helm-el-package-reinstall)
("Recompile package(s)" . helm-el-package-recompile)
("Uninstall package(s)" . helm-el-package-uninstall))))
(t (append acts '(("Install packages(s)" . helm-el-package-install)))))))
(defun helm-el-package--update ()
(setq helm-el-package--initialized-p nil))
(defun helm-el-package-recompile (_pkg)
(cl-loop for p in (helm-marked-candidates)
do (helm-el-package-recompile-1 p)))
(defun helm-el-package-recompile-1 (pkg)
(let* ((pkg-desc (get-text-property 0 'tabulated-list-id pkg))
(dir (package-desc-dir pkg-desc)))
(async-byte-recompile-directory dir)))
(defun helm-el-package-reinstall (_pkg)
(cl-loop for p in (helm-marked-candidates)
for pkg-desc = (get-text-property 0 'tabulated-list-id p)
do (helm-el-package-reinstall-1 pkg-desc)))
(defun helm-el-package-reinstall-1 (pkg-desc)
(let ((name (package-desc-name pkg-desc)))
(package-delete pkg-desc 'force 'nosave)
;; pkg-desc contain the description
;; of the installed package just removed
;; and is BTW no more valid.
;; Use the entry in package-archive-content
;; which is the non--installed package entry.
;; For some reason `package-install'
;; need a pkg-desc (package-desc-p) for the build-in
;; packages already installed, the name (as symbol)
;; fails with such packages.
(package-install
(cadr (assq name package-archive-contents)) t)))
(helm-make-command-from-action helm-el-run-package-reinstall
"Reinstall package from helm elisp packages."
'helm-el-package-reinstall)
;;;###autoload
(defun helm-list-elisp-packages (arg)
"Preconfigured `helm' for listing and handling Emacs packages."
(interactive "P")
(when arg (setq helm-el-package--initialized-p nil))
(unless helm-source-list-el-package
(setq helm-source-list-el-package
(helm-make-source "list packages" 'helm-list-el-package-source)))
(helm :sources 'helm-source-list-el-package
:truncate-lines helm-el-truncate-lines
:full-frame t
:buffer "*helm list packages*"))
;;;###autoload
(defun helm-list-elisp-packages-no-fetch (arg)
"Preconfigured Helm for Emacs packages.
Same as `helm-list-elisp-packages' but don't fetch packages on
remote. Called with a prefix ARG always fetch packages on
remote."
(interactive "P")
(let ((helm-el-package--initialized-p (null arg)))
(helm-list-elisp-packages nil)))
(provide 'helm-elisp-package)
;;; helm-elisp-package.el ends here

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,254 @@
;;; helm-epa.el --- helm interface for epa/epg -*- lexical-binding: t; -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto <thievol@posteo.net>
;; 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/>.
;;; Code:
(require 'helm)
(eval-when-compile (require 'epg))
(defvar epa-protocol)
(defvar epa-last-coding-system-specified)
(defvar epg-key-validity-alist)
(defvar mail-header-separator)
(declare-function epg-list-keys "epg")
(declare-function epg-make-context "epg")
(declare-function epg-key-sub-key-list "epg")
(declare-function epg-sub-key-id "epg")
(declare-function epg-key-user-id-list "epg")
(declare-function epg-user-id-string "epg")
(declare-function epg-user-id-validity "epg")
(declare-function epa-sign-region "epa")
(declare-function epa--read-signature-type "epa")
(declare-function epa-display-error "epa")
(declare-function epg-export-keys-to-string "epg")
(declare-function epg-context-armor "epg")
(declare-function epg-context-set-armor "epg")
(declare-function epg-delete-keys "epg")
(declare-function helm-read-file-name "helm-mode")
(defvar helm-epa--list-only-secrets nil
"[INTERNAL] Used to pass MODE argument to `epg-list-keys'.")
(defcustom helm-epa-actions '(("Show key" . epa--show-key)
("encrypt file with key" . helm-epa-encrypt-file)
("Copy keys to kill ring" . helm-epa-kill-keys-armor)
("Delete keys" . helm-epa-delete-keys))
"Actions for `helm-epa-list-keys'."
:type '(alist :key-type string :value-type symbol)
:group 'helm-misc)
(defclass helm-epa (helm-source-sync)
((init :initform (lambda ()
(require 'epg)
(require 'epa)))
(candidates :initform 'helm-epa-get-key-list)
(keymap :initform 'helm-comp-read-map)
(mode-line :initform 'helm-comp-read-mode-line))
"Allow building helm sources for GPG keys.")
(defun helm-epa-get-key-list (&optional keys)
"Build candidate list for `helm-epa-list-keys'."
(cl-loop with all-keys = (or keys (epg-list-keys (epg-make-context epa-protocol)
nil helm-epa--list-only-secrets))
for key in all-keys
for sublist = (car (epg-key-sub-key-list key))
for subkey-id = (epg-sub-key-id sublist)
for uid-list = (epg-key-user-id-list key)
for uid = (epg-user-id-string (car uid-list))
for validity = (epg-user-id-validity (car uid-list))
collect (cons (format " %s %s %s"
(helm-aif (rassq validity epg-key-validity-alist)
(string (car it))
"?")
(propertize
subkey-id
'face (cl-case validity
(none 'epa-validity-medium)
((revoked expired)
'epa-validity-disabled)
(t 'epa-validity-high)))
(propertize
uid 'face 'font-lock-warning-face))
key)))
(defun helm-epa--select-keys (prompt keys)
"A helm replacement for `epa--select-keys'."
(let ((result (helm :sources (helm-make-source "Epa select keys" 'helm-epa
:candidates (lambda ()
(helm-epa-get-key-list keys)))
:prompt (and prompt (helm-epa--format-prompt prompt))
:buffer "*helm epa*")))
(unless (equal result "")
result)))
(defun helm-epa--format-prompt (prompt)
(let ((split (split-string prompt "\n")))
(if (cdr split)
(format "%s\n(%s): "
(replace-regexp-in-string "\\.[\t ]*\\'" "" (car split))
(replace-regexp-in-string "\\.[\t ]*\\'" "" (cadr split)))
(format "%s: " (replace-regexp-in-string "\\.[\t ]*\\'" "" (car split))))))
(defun helm-epa--read-signature-type ()
"A helm replacement for `epa--read-signature-type'."
(let ((answer (helm-read-answer "Signature type:
(n - Create a normal signature)
(c - Create a cleartext signature)
(d - Create a detached signature)"
'("n" "c" "d"))))
(helm-acase answer
("n" 'normal)
("c" 'clear)
("d" 'detached))))
(defun helm-epa-collect-keys-from-candidates (candidates)
(cl-loop for c in candidates
collect (epg-sub-key-id
(car (epg-key-sub-key-list c)))))
(defun helm-epa-collect-id-from-candidates (candidates)
(cl-loop for c in candidates
collect (epg-user-id-string
(car (epg-key-user-id-list c)))))
(defun helm-epa-success-message (str keys ids)
(message str
(mapconcat (lambda (pair)
(concat (car pair) " " (cdr pair)))
(cl-loop for k in keys
for i in ids
collect (cons k i))
"\n")))
;;;###autoload
(define-minor-mode helm-epa-mode
"Enable helm completion on gpg keys in epa functions."
:group 'helm-misc
:global t
(require 'epa)
(if helm-epa-mode
(progn
(advice-add 'epa--select-keys :override #'helm-epa--select-keys)
(advice-add 'epa--read-signature-type :override #'helm-epa--read-signature-type))
(advice-remove 'epa-select-keys #'helm-epa--select-keys)
(advice-remove 'epa--read-signature-type #'helm-epa--read-signature-type)))
(defun helm-epa-action-transformer (actions _candidate)
"Helm epa action transformer function."
(cond ((with-helm-current-buffer
(derived-mode-p 'message-mode 'mail-mode))
(helm-append-at-nth
actions '(("Sign mail with key" . helm-epa-mail-sign)
("Encrypt mail with key" . helm-epa-mail-encrypt))
3))
(t actions)))
(defun helm-epa-delete-keys (_candidate)
"Delete gpg marked keys from helm-epa."
(let ((context (epg-make-context epa-protocol))
(keys (helm-marked-candidates)))
(message "Deleting gpg keys..")
(condition-case error
(epg-delete-keys context keys)
(error
(epa-display-error context)
(signal (car error) (cdr error))))
(message "Deleting gpg keys done")))
(defun helm-epa-encrypt-file (_candidate)
"Select a file to encrypt with key CANDIDATE."
(let* ((file (helm-read-file-name "Encrypt file: "))
(cands (helm-marked-candidates))
(keys (helm-epa-collect-keys-from-candidates cands))
(ids (helm-epa-collect-id-from-candidates cands)))
(epa-encrypt-file file cands)
(helm-epa-success-message "File encrypted with key(s):\n %s"
keys ids)))
(defun helm-epa-kill-keys-armor (_candidate)
"Copy marked keys to kill ring."
(let ((keys (helm-marked-candidates))
(context (epg-make-context epa-protocol)))
(with-no-warnings
(setf (epg-context-armor context) t))
(condition-case error
(kill-new (epg-export-keys-to-string context keys))
(error
(epa-display-error context)
(signal (car error) (cdr error))))))
(defun helm-epa-mail-sign (candidate)
"Sign email with key CANDIDATE."
(let ((key (epg-sub-key-id (car (epg-key-sub-key-list candidate))))
(id (epg-user-id-string (car (epg-key-user-id-list candidate))))
start end mode)
(save-excursion
(goto-char (point-min))
(if (search-forward mail-header-separator nil t)
(forward-line))
(setq epa-last-coding-system-specified
(or coding-system-for-write
(select-safe-coding-system (point) (point-max))))
(let ((verbose current-prefix-arg))
(setq start (point)
end (point-max)
mode (if verbose
(epa--read-signature-type)
'clear))))
;; TODO Make non-interactive functions to replace epa-sign-region
;; and epa-encrypt-region and inline them.
(with-no-warnings
(epa-sign-region start end candidate mode))
(message "Mail signed with key `%s %s'" key id)))
(defun helm-epa-mail-encrypt (_candidate)
"Encrypt email with key CANDIDATE."
(let ((cands (helm-marked-candidates))
start end)
(save-excursion
(goto-char (point-min))
(when (search-forward mail-header-separator nil t)
(forward-line))
(setq start (point)
end (point-max))
(setq epa-last-coding-system-specified
(or coding-system-for-write
(select-safe-coding-system start end))))
;; Don't let some read-only text stop us from encrypting.
(let ((inhibit-read-only t)
(keys (helm-epa-collect-keys-from-candidates cands))
(ids (helm-epa-collect-id-from-candidates cands)))
(with-no-warnings
(epa-encrypt-region start end cands nil nil))
(helm-epa-success-message "Mail encrypted with key(s):\n %s"
keys ids))))
;;;###autoload
(defun helm-epa-list-keys ()
"List all gpg keys.
This is the helm interface for `epa-list-keys'."
(interactive)
(helm :sources
(helm-make-source "Epg list keys" 'helm-epa
:action-transformer 'helm-epa-action-transformer
:action 'helm-epa-actions)
:buffer "*helm epg list keys*"))
(provide 'helm-epa)
;;; helm-epa.el ends here

View file

@ -0,0 +1,494 @@
;;; helm-eshell.el --- pcomplete and eshell completion for helm. -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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:
;;
;; Enable like this in .emacs:
;; (add-hook 'eshell-mode-hook
;; (lambda ()
;; (eshell-cmpl-initialize)
;; (define-key eshell-mode-map [remap eshell-pcomplete] 'helm-esh-pcomplete)
;; (define-key eshell-mode-map (kbd "M-s f") 'helm-eshell-prompts-all)))
;; (define-key eshell-mode-map (kbd "M-r") 'helm-eshell-history)))
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-lib)
(require 'helm-help)
(require 'helm-elisp)
(declare-function eshell-read-aliases-list "em-alias")
(declare-function eshell-send-input "esh-mode" (&optional use-region queue-p no-newline))
(declare-function eshell-bol "esh-mode")
(declare-function eshell-parse-arguments "esh-arg" (beg end))
(declare-function eshell-backward-argument "esh-mode" (&optional arg))
(declare-function helm-quote-whitespace "helm-lib")
(declare-function eshell-skip-prompt "em-prompt")
(defvar eshell-special-chars-outside-quoting)
(defgroup helm-eshell nil
"Helm completion and history for Eshell."
:group 'helm)
(defcustom helm-eshell-fuzzy-match nil
"Enable fuzzy matching in `helm-esh-pcomplete' when non-nil."
:type 'boolean)
(defvar helm-eshell-history-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "M-p") #'helm-next-line)
map)
"Keymap for `helm-eshell-history'.")
(defvar helm-esh-completion-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "TAB") #'helm-next-line)
map)
"Keymap for `helm-esh-pcomplete'.")
(defvar helm-eshell--quit-flag nil)
;; Internal.
(defvar helm-ec-target "")
(defun helm-ec-insert (_candidate)
"Replace text at point with CANDIDATE.
The function that call this should set `helm-ec-target' to thing
at point."
(set (make-local-variable 'comint-file-name-quote-list)
eshell-special-chars-outside-quoting)
(let ((pt (point)))
(when (and helm-ec-target
(search-backward helm-ec-target nil t)
(string= (buffer-substring (point) pt) helm-ec-target))
(delete-region (point) pt)))
(when (string-match "\\`\\*" helm-ec-target) (insert "*"))
(let ((marked (helm-marked-candidates)))
(prog1 t ;; Makes helm returns t on action.
(insert
(mapconcat
(lambda (x)
(cond ((string-match "\\`~/" helm-ec-target)
;; Strip out the first escape char added by
;; `comint-quote-filename' before "~" (Bug#1803).
(substring (comint-quote-filename (abbreviate-file-name x)) 1))
((string-match "\\`/" helm-ec-target)
(comint-quote-filename x))
(t
(concat (and (string-match "\\`[.]/" helm-ec-target) "./")
(comint-quote-filename
(file-relative-name x))))))
marked " ")
(or (helm-aand (car (last marked))
(string-match-p "/\\'" it)
"")
" ")))))
(defun helm-esh-transformer (candidates _sources)
(cl-loop
for i in candidates
collect
(cond ((string-match "\\`~/?" helm-ec-target)
(abbreviate-file-name i))
((string-match "\\`/" helm-ec-target) i)
(t
(file-relative-name i)))
into lst
finally return (sort lst #'helm-generic-sort-fn)))
(defclass helm-esh-source (helm-source-sync)
((init :initform (lambda ()
(setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil)
;; Eshell-command add this hook in all minibuffers
;; Remove it for the helm one. (Fixed in Emacs24)
(remove-hook 'minibuffer-setup-hook 'eshell-mode)))
(candidates :initform 'helm-esh-get-candidates)
;(nomark :initform t)
(persistent-action :initform 'ignore)
(nohighlight :initform t)
(filtered-candidate-transformer :initform #'helm-esh-transformer)
(action :initform 'helm-ec-insert))
"Helm class to define source for Eshell completion.")
(defun helm-esh-get-candidates ()
"Get candidates for Eshell completion using `pcomplete'."
(catch 'pcompleted
(with-helm-current-buffer
(let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist)
(pcomplete-suffix-list pcomplete-suffix-list)
(table (pcomplete-completions))
(entry (or (try-completion helm-pattern
(pcomplete-entries))
helm-pattern)))
(cl-loop ;; expand entry too to be able to compare it with file-cand.
with exp-entry = (and (stringp entry)
(not (string= entry ""))
(file-name-as-directory
(expand-file-name entry default-directory)))
with comps = (all-completions pcomplete-stub table)
unless comps return (prog1 nil
;; Don't add final space when
;; there is no completion (Bug#1990).
(setq helm-eshell--quit-flag t)
(message "No completions of %s" pcomplete-stub))
for i in comps
;; Transform the relative names to abs names.
for file-cand = (and exp-entry
(if (file-remote-p i) i
(expand-file-name
i (file-name-directory
(if (directory-name-p pcomplete-stub)
entry
(directory-file-name entry))))))
;; Compare them to avoid dups.
for file-entry-p = (and (stringp exp-entry)
(stringp file-cand)
;; Fix :/tmp/foo/ $ cd foo
(not (file-directory-p file-cand))
(file-equal-p exp-entry file-cand))
if (and file-cand (or (file-remote-p file-cand)
(file-exists-p file-cand))
(not file-entry-p))
collect file-cand into ls
else
;; Avoid adding entry here.
unless file-entry-p collect i into ls
finally return
(if (and exp-entry
(file-directory-p exp-entry)
;; If the car of completion list is
;; an executable, probably we are in
;; command completion, so don't add a
;; possible file related entry here.
(and ls (not (executable-find (car ls))))
;; Don't add entry if already in prompt.
(not (file-equal-p exp-entry pcomplete-stub)))
(append (list exp-entry)
;; Entry should not be here now but double check.
(remove entry ls))
ls))))))
;;; Eshell history.
;;
;;
(defclass helm-eshell-history-source (helm-source-sync)
((init :initform
(lambda ()
;; Same comment as in `helm-source-esh'.
(remove-hook 'minibuffer-setup-hook 'eshell-mode)))
(candidates
:initform
(lambda ()
(with-helm-current-buffer
(cl-loop for c from 0 to (ring-length eshell-history-ring)
for elm = (eshell-get-history c)
unless (and (member elm lst)
eshell-hist-ignoredups)
collect elm into lst
finally return lst))))
(nomark :initform t)
(multiline :initform t)
(keymap :initform 'helm-eshell-history-map)
(candidate-number-limit :initform 9999)
(action :initform (lambda (candidate)
(eshell-kill-input)
(insert candidate))))
"Helm class to define source for Eshell history.")
(defun helm-esh-pcomplete-input (target users-comp last)
(if (and (stringp last)
(not (string= last ""))
(not users-comp)
;; Fix completion on "../" see Bug#1832.
(or (file-exists-p last)
(helm-aand
(file-name-directory last)
(file-directory-p it))))
(if (and (file-directory-p last)
(string-match "\\`[~.]*.*/[.]\\'" target))
;; Fix completion on "~/.", "~/[...]/.", and "../."
(expand-file-name
(concat (helm-basedir (file-name-as-directory last))
(regexp-quote (helm-basename target))))
(expand-file-name last))
;; Don't add "~" to input to provide completion on all users instead of only
;; on current $HOME (#1832).
(unless users-comp last)))
(defun helm-esh-pcomplete-default-source ()
"Make and return the default source for Eshell completion."
(helm-make-source "Eshell completions" 'helm-esh-source
:fuzzy-match helm-eshell-fuzzy-match
:keymap helm-esh-completion-map))
(defvar helm-esh-pcomplete-build-source-fn #'helm-esh-pcomplete-default-source
"Function that builds a source or a list of sources.")
(defun helm-esh-pcomplete--make-helm (&optional input)
(helm :sources (funcall helm-esh-pcomplete-build-source-fn)
:buffer "*helm pcomplete*"
:resume 'noresume
:input input))
;;;###autoload
(defun helm-esh-pcomplete ()
"Preconfigured `helm' to provide Helm completion in Eshell."
(interactive)
(let* ((helm-quit-if-no-candidate t)
(helm-execute-action-at-once-if-one t)
(end (point-marker))
(beg (save-excursion (eshell-bol) (point)))
(args (catch 'eshell-incomplete
(eshell-parse-arguments beg end)))
(target
(or (and (looking-back " " (1- (point))) " ")
(buffer-substring-no-properties
(save-excursion
(eshell-backward-argument 1) (point))
end)))
(users-comp (string= target "~"))
(first (car args)) ; Maybe lisp delimiter "(".
last ; Will be the last but parsed by pcomplete.
del-space
del-dot)
(setq helm-ec-target (or target " ")
end (point)
;; Reset beg for `with-helm-show-completion'.
beg (or (and target (not (string= target " "))
(- end (length target)))
;; Nothing at point.
(progn (insert " ") (setq del-space t) (point))))
(when (string-match "\\`[~.]*.*/[.]\\'" target)
;; Fix completion on
;; "~/.", "~/[...]/.", and "../."
(delete-char -1) (setq del-dot t)
(setq helm-ec-target (substring helm-ec-target 0 (1- (length helm-ec-target)))))
(cond ((eq first ?\()
(helm-lisp-completion-or-file-name-at-point))
;; In eshell `pcomplete-parse-arguments' is called
;; with `pcomplete-parse-arguments-function'
;; locally bound to `eshell-complete-parse-arguments'
;; which is calling `lisp-complete-symbol',
;; calling it before would popup the
;; *completions* buffer.
(t (setq last (replace-regexp-in-string
"\\`\\*" ""
(car (last (ignore-errors
(pcomplete-parse-arguments))))))
;; Set helm-eshell--quit-flag to non-nil only on
;; quit, this tells to not add final suffix when quitting
;; helm.
(add-hook 'helm-quit-hook #'helm-eshell--quit-hook-fn)
(with-helm-show-completion beg end
(unwind-protect
(or (helm-esh-pcomplete--make-helm
(helm-esh-pcomplete-input target users-comp last))
;; Delete removed dot on quit
(and del-dot (prog1 t (insert ".")))
;; A space is needed to have completion, remove
;; it when nothing found.
(and del-space (looking-back "\\s-" (1- (point)))
(delete-char -1))
(if (and (null helm-eshell--quit-flag)
(and (stringp last) (file-directory-p last))
(looking-back "\\([.]\\{1,2\\}\\|[^/]\\)\\'"
(1- (point))))
(prog1 t (insert "/"))
;; We need another flag for space here, but
;; global to pass it to `helm-quit-hook', this
;; space is added when point is just after
;; previous completion and there is no
;; more completion, see Bug#1832.
(unless (or helm-eshell--quit-flag
(looking-back "/\\'" (1- (point))))
(prog1 t (insert " ")))
(when (and helm-eshell--quit-flag
(string-match-p "[.]\\{2\\}\\'" last))
(insert "/"))))
(remove-hook 'helm-quit-hook #'helm-eshell--quit-hook-fn)
(setq helm-eshell--quit-flag nil)))))))
(defun helm-eshell--quit-hook-fn ()
(setq helm-eshell--quit-flag t))
;;;###autoload
(defun helm-eshell-history ()
"Preconfigured Helm for Eshell history."
(interactive)
(let* ((end (point))
(beg (save-excursion (eshell-bol) (point)))
(input (buffer-substring beg end))
flag-empty)
(when (eq beg end)
(insert " ")
(setq flag-empty t)
(setq end (point)))
(unwind-protect
(with-helm-show-completion beg end
(helm :sources (helm-make-source "Eshell history"
'helm-eshell-history-source
:fuzzy-match helm-eshell-fuzzy-match)
:buffer "*helm eshell history*"
:resume 'noresume
:input input))
(when (and flag-empty
(looking-back " " (1- (point))))
(delete-char -1)))))
;;; Eshell prompts
;;
(defface helm-eshell-prompts-promptidx
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "cyan"))
"Face used to highlight Eshell prompt index.")
(defface helm-eshell-prompts-buffer-name
`((t ,@(and (>= emacs-major-version 27) '(:extend t))
:foreground "green"))
"Face used to highlight Eshell buffer name.")
(defcustom helm-eshell-prompts-promptidx-p t
"Show prompt number."
:type 'boolean)
(defvar helm-eshell-prompts-keymap
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "C-c o") #'helm-eshell-prompts-other-window)
(define-key map (kbd "C-c C-o") #'helm-eshell-prompts-other-frame)
map)
"Keymap for `helm-eshell-prompt-all'.")
(defvar eshell-prompt-regexp)
(defvar eshell-highlight-prompt)
(defun helm-eshell-prompts-list (&optional buffer)
"List the prompts in Eshell BUFFER.
Return a list of (\"prompt\" (point) (buffer-name) prompt-index))
E.g. (\"ls\" 162 \"*eshell*\" 3).
If BUFFER is nil, use current buffer."
(with-current-buffer (or buffer (current-buffer))
(when (eq major-mode 'eshell-mode)
(save-excursion
(goto-char (point-min))
(let (result (count 1))
(helm-awhile (re-search-forward eshell-prompt-regexp nil t)
(when (or (and eshell-highlight-prompt
(get-text-property (match-beginning 0) 'read-only))
(null eshell-highlight-prompt))
(push (list (buffer-substring-no-properties
it (point-at-eol))
it (buffer-name) count)
result)
(setq count (1+ count))))
(nreverse result))))))
(defun helm-eshell-prompts-list-all ()
"List the prompts of all Eshell buffers.
See `helm-eshell-prompts-list'."
(cl-loop for b in (buffer-list)
append (helm-eshell-prompts-list b)))
(defun helm-eshell-prompts-transformer (candidates &optional all)
;; ("ls" 162 "*eshell*" 3) => ("*eshell*:3:ls" . ("ls" 162 "*eshell*" 3))
(cl-loop for (prt pos buf id) in candidates
collect `(,(concat
(when all
(concat (propertize
buf
'face 'helm-eshell-prompts-buffer-name)
":"))
(when helm-eshell-prompts-promptidx-p
(concat (propertize
(number-to-string id)
'face 'helm-eshell-prompts-promptidx)
":"))
prt)
. ,(list prt pos buf id))))
(defun helm-eshell-prompts-all-transformer (candidates)
(helm-eshell-prompts-transformer candidates t))
(cl-defun helm-eshell-prompts-goto (candidate &optional (action 'switch-to-buffer))
;; Candidate format: ("ls" 162 "*eshell*" 3)
(let ((buf (nth 2 candidate)))
(unless (and (string= (buffer-name) buf)
(eq action 'switch-to-buffer))
(funcall action buf))
(goto-char (nth 1 candidate))
(recenter)))
(defun helm-eshell-prompts-goto-other-window (candidate)
(helm-eshell-prompts-goto candidate 'switch-to-buffer-other-window))
(defun helm-eshell-prompts-goto-other-frame (candidate)
(helm-eshell-prompts-goto candidate 'switch-to-buffer-other-frame))
(helm-make-command-from-action helm-eshell-prompts-other-window
"Switch to eshell prompt in other window."
'helm-eshell-prompts-goto-other-window)
(helm-make-command-from-action helm-eshell-prompts-other-frame
"Switch to eshell prompt in other frame."
'helm-eshell-prompts-goto-other-frame)
;;;###autoload
(defun helm-eshell-prompts ()
"Pre-configured `helm' to browse the prompts of the current Eshell."
(interactive)
(if (eq major-mode 'eshell-mode)
(helm :sources
(helm-build-sync-source "Eshell prompts"
:candidates (helm-eshell-prompts-list)
:candidate-transformer 'helm-eshell-prompts-transformer
:action '(("Go to prompt" . helm-eshell-prompts-goto)))
:buffer "*helm Eshell prompts*")
(message "Current buffer is not an Eshell buffer")))
;;;###autoload
(defun helm-eshell-prompts-all ()
"Pre-configured `helm' to browse the prompts of all Eshell sessions."
(interactive)
(helm :sources
(helm-build-sync-source "All Eshell prompts"
:candidates (helm-eshell-prompts-list-all)
:candidate-transformer 'helm-eshell-prompts-all-transformer
:action '(("Go to prompt" . helm-eshell-prompts-goto)
("Go to prompt in other window `C-c o`" .
helm-eshell-prompts-goto-other-window)
("Go to prompt in other frame `C-c C-o`" .
helm-eshell-prompts-goto-other-frame))
:keymap helm-eshell-prompts-keymap)
:buffer "*helm Eshell all prompts*"))
(provide 'helm-eshell)
;;; helm-eshell ends here

View file

@ -0,0 +1,215 @@
;;; helm-eval.el --- eval expressions from helm. -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto
;; 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/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(require 'eldoc)
(require 'edebug)
(declare-function helm-lisp-completion-at-point "helm-elisp.el")
(defgroup helm-eval nil
"Eval related Applications and libraries for Helm."
:group 'helm)
(defcustom helm-eldoc-in-minibuffer-show-fn
'helm-show-info-in-mode-line
"A function to display eldoc info.
Should take one arg: the string to display."
:group 'helm-eval
:type 'symbol)
(defcustom helm-show-info-in-mode-line-delay 12
"Eldoc will show info in mode-line during this delay if user is idle."
:type 'integer
:group 'helm-eval)
;;; Eldoc compatibility between emacs-24 and emacs-25
;;
(if (require 'elisp-mode nil t) ; emacs-25
;; Maybe the eldoc functions have been
;; already aliased by eldoc-eval.
(cl-loop for (f . a) in '((eldoc-current-symbol .
elisp--current-symbol)
(eldoc-fnsym-in-current-sexp .
elisp--fnsym-in-current-sexp)
(eldoc-get-fnsym-args-string .
elisp-get-fnsym-args-string)
(eldoc-get-var-docstring .
elisp-get-var-docstring))
unless (fboundp f)
do (defalias f a))
;; Emacs-24.
(declare-function eldoc-current-symbol "eldoc")
(declare-function eldoc-get-fnsym-args-string "eldoc" (sym &optional index))
(declare-function eldoc-get-var-docstring "eldoc" (sym))
(declare-function eldoc-fnsym-in-current-sexp "eldoc"))
;;; Evaluation Result
;;
;;
;; Internal
(defvar helm-eldoc-active-minibuffers-list nil)
(defvar helm-eval-expression-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "<C-return>") #'helm-eval-new-line-and-indent)
(define-key map (kbd "<M-tab>") #'lisp-indent-line)
(define-key map (kbd "<C-tab>") #'helm-lisp-completion-at-point)
(define-key map (kbd "C-p") #'previous-line)
(define-key map (kbd "C-n") #'next-line)
(define-key map (kbd "<up>") #'previous-line)
(define-key map (kbd "<down>") #'next-line)
(define-key map (kbd "<right>") #'forward-char)
(define-key map (kbd "<left>") #'backward-char)
map))
(defun helm-build-evaluation-result-source ()
(helm-build-dummy-source "Evaluation Result"
:multiline t
:mode-line "C-RET: nl-and-indent, M-tab: reindent, C-tab:complete, C-p/n: next/prec-line."
:filtered-candidate-transformer
(lambda (_candidates _source)
(list
(condition-case nil
(with-helm-current-buffer
(pp-to-string
(if edebug-active
(edebug-eval-expression
(read helm-pattern))
(eval (read helm-pattern) t))))
(error "Error"))))
:nohighlight t
:keymap helm-eval-expression-map
:action '(("Copy result to kill-ring" . (lambda (candidate)
(kill-new
(replace-regexp-in-string
"\n" "" candidate))
(message "Result copied to kill-ring")))
("copy sexp to kill-ring" . (lambda (_candidate)
(kill-new helm-input)
(message "Sexp copied to kill-ring"))))))
(defun helm-eval-new-line-and-indent ()
(interactive)
(newline) (lisp-indent-line))
(defun helm-eldoc-store-minibuffer ()
"Store minibuffer buffer name in `helm-eldoc-active-minibuffers-list'."
(with-selected-window (minibuffer-window)
(push (current-buffer) helm-eldoc-active-minibuffers-list)))
;; From emacs-28.1: As the eldoc API is nowaday a pain to use, try to
;; provide some eldoc in mode-line the best as possible (may break at
;; some point).
(defun helm-eldoc-show-in-eval ()
"Return eldoc in mode-line for current minibuffer input."
(let ((buf (window-buffer (active-minibuffer-window))))
(condition-case err
(when (member buf helm-eldoc-active-minibuffers-list)
(with-current-buffer buf
(let* ((info-fn (eldoc-fnsym-in-current-sexp))
(vsym (eldoc-current-symbol))
(sym (car info-fn))
(vardoc (eldoc-get-var-docstring vsym))
(doc (or vardoc
(eldoc-get-fnsym-args-string
sym (cadr info-fn))))
(all (format "%s: %s"
(propertize
(symbol-name (if vardoc vsym sym))
'face (if vardoc
'font-lock-variable-name-face
'font-lock-function-name-face))
doc)))
(when doc (funcall helm-eldoc-in-minibuffer-show-fn all)))))
(error (message "Eldoc in minibuffer error: %S" err) nil))))
(defun helm-show-info-in-mode-line (str)
"Display string STR in mode-line."
(save-selected-window
(with-helm-window
(let ((mode-line-format (concat " " str)))
(force-mode-line-update)
(sit-for helm-show-info-in-mode-line-delay))
(force-mode-line-update))))
;;; Calculation Result
;;
;;
(defvar helm-source-calculation-result
(helm-build-dummy-source "Calculation Result"
:filtered-candidate-transformer (lambda (_candidates _source)
(list
(condition-case err
(let ((result (calc-eval helm-pattern)))
(if (listp result)
(error "At pos %s: %s"
(car result) (cadr result))
result))
(error (cdr err)))))
:nohighlight t
:action '(("Copy result to kill-ring" . (lambda (candidate)
(kill-new candidate)
(message "Result \"%s\" copied to kill-ring"
candidate)))
("Copy operation to kill-ring" . (lambda (_candidate)
(kill-new helm-input)
(message "Calculation copied to kill-ring"))))))
;;;###autoload
(defun helm-eval-expression (arg)
"Preconfigured `helm' for `helm-source-evaluation-result'."
(interactive "P")
(let ((helm-elisp-help-function #'helm-elisp-show-doc-modeline))
(helm :sources (helm-build-evaluation-result-source)
:input (when arg (thing-at-point 'sexp))
:buffer "*helm eval*"
:echo-input-in-header-line nil
:history 'read-expression-history)))
(defvar eldoc-idle-delay)
;;;###autoload
(defun helm-eval-expression-with-eldoc ()
"Preconfigured `helm' for `helm-source-evaluation-result' with `eldoc' support."
(interactive)
(let ((timer (run-with-idle-timer
eldoc-idle-delay 'repeat
#'helm-eldoc-show-in-eval)))
(unwind-protect
(minibuffer-with-setup-hook
#'helm-eldoc-store-minibuffer
(call-interactively 'helm-eval-expression))
(and timer (cancel-timer timer))
(setq helm-eldoc-active-minibuffers-list
(cdr helm-eldoc-active-minibuffers-list)))))
;;;###autoload
(defun helm-calcul-expression ()
"Preconfigured `helm' for `helm-source-calculation-result'."
(interactive)
(helm :sources 'helm-source-calculation-result
:buffer "*helm calcul*"))
(provide 'helm-eval)
;;; helm-eval.el ends here

Some files were not shown because too many files have changed in this diff Show more