daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

update of packages

Browse Source
This commit is contained in:
Daniel Weschke
2023-11-04 19:26:41 +01:00
parent e162a12b58
commit 3b54a3236d
726 changed files with 297673 additions and 34585 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
lisp/ace-window/ace-window-pkg.el
View File

@@ -2,6 +2,8 @@
'((avy "0.5.0")) '((avy "0.5.0"))
:commit "77115afc1b0b9f633084cf7479c767988106c196" :authors :commit "77115afc1b0b9f633084cf7479c767988106c196" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com")) '(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainers
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainer :maintainer
'("Oleh Krehel" . "ohwoeowho@gmail.com") '("Oleh Krehel" . "ohwoeowho@gmail.com")
:keywords :keywords

16
lisp/all-the-icons-ivy-rich/all-the-icons-ivy-rich-pkg.el Normal file
View File

@@ -0,0 +1,16 @@
(define-package "all-the-icons-ivy-rich" "20230420.1234" "Better experience with icons for ivy"
'((emacs "25.1")
(ivy-rich "0.1.0")
(all-the-icons "2.2.0"))
:commit "c098cc85123a401b0ab8f2afd3a25853e61d7d28" :authors
'(("Vincent Zhang" . "seagle0128@gmail.com"))
:maintainers
'(("Vincent Zhang" . "seagle0128@gmail.com"))
:maintainer
'("Vincent Zhang" . "seagle0128@gmail.com")
:keywords
'("convenience" "icons" "ivy")
:url "https://github.com/seagle0128/all-the-icons-ivy-rich")
;; Local Variables:
;; no-byte-compile: t
;; End:

261
lisp/all-the-icons-ivy-rich.el → lisp/all-the-icons-ivy-rich/all-the-icons-ivy-rich.el
View File

@@ -4,9 +4,7 @@
;; Author: Vincent Zhang <seagle0128@gmail.com> ;; Author: Vincent Zhang <seagle0128@gmail.com>
;; Homepage: https://github.com/seagle0128/all-the-icons-ivy-rich ;; Homepage: https://github.com/seagle0128/all-the-icons-ivy-rich
;; Version: 1.8.1 ;; Version: 1.9.0
;; Package-Version: 20221202.1336
;; Package-Commit: c5839098664104ade4dfcefa0ba716215c4f7812
;; Package-Requires: ((emacs "25.1") (ivy-rich "0.1.0") (all-the-icons "2.2.0")) ;; Package-Requires: ((emacs "25.1") (ivy-rich "0.1.0") (all-the-icons "2.2.0"))
;; Keywords: convenience, icons, ivy ;; Keywords: convenience, icons, ivy
@@ -133,7 +131,7 @@
:group 'all-the-icons-ivy-rich) :group 'all-the-icons-ivy-rich)
(defface all-the-icons-ivy-rich-size-face (defface all-the-icons-ivy-rich-size-face
'((t (:inherit shadow))) '((t (:inherit font-lock-constant-face)))
"Face used for buffer size." "Face used for buffer size."
:group 'all-the-icons-ivy-rich) :group 'all-the-icons-ivy-rich)
@@ -575,14 +573,12 @@ This value is adjusted depending on the `window-width'."
counsel-find-library counsel-find-library
(:columns (:columns
((all-the-icons-ivy-rich-library-icon) ((all-the-icons-ivy-rich-library-icon)
(all-the-icons-ivy-rich-library-transformer (:width 0.3)) (all-the-icons-ivy-rich-library-transformer))
(all-the-icons-ivy-rich-library-path (:face all-the-icons-ivy-rich-path-face)))
:delimiter "\t") :delimiter "\t")
counsel-load-library counsel-load-library
(:columns (:columns
((all-the-icons-ivy-rich-library-icon) ((all-the-icons-ivy-rich-library-icon)
(all-the-icons-ivy-rich-library-transformer (:width 0.3)) (all-the-icons-ivy-rich-library-transformer))
(all-the-icons-ivy-rich-library-path (:face all-the-icons-ivy-rich-path-face)))
:delimiter "\t") :delimiter "\t")
counsel-load-theme counsel-load-theme
(:columns (:columns
@@ -602,7 +598,7 @@ This value is adjusted depending on the `window-width'."
:delimiter "\t") :delimiter "\t")
counsel-git-checkout counsel-git-checkout
(:columns (:columns
((all-the-icons-ivy-rich-git-branch-icon) ((all-the-icons-ivy-rich-git-commit-icon)
(ivy-rich-candidate)) (ivy-rich-candidate))
:delimiter "\t") :delimiter "\t")
counsel-list-processes counsel-list-processes
@@ -737,15 +733,10 @@ This value is adjusted depending on the `window-width'."
((all-the-icons-ivy-rich-function-icon) ((all-the-icons-ivy-rich-function-icon)
(counsel-M-x-transformer (:width 0.3)) (counsel-M-x-transformer (:width 0.3))
(ivy-rich-counsel-function-docstring (:face all-the-icons-ivy-rich-doc-face)))) (ivy-rich-counsel-function-docstring (:face all-the-icons-ivy-rich-doc-face))))
project-switch-project project-switch-project
(:columns (:columns
((all-the-icons-ivy-rich-file-icon) ((all-the-icons-ivy-rich-project-icon)
(all-the-icons-ivy-rich-project-name (:width 0.4)) (all-the-icons-ivy-rich-project-name))
(all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-project-file-modes (:width 12))
(all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-project-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t") :delimiter "\t")
project-find-file project-find-file
(:columns (:columns
@@ -768,16 +759,7 @@ This value is adjusted depending on the `window-width'."
project-dired project-dired
(:columns (:columns
((all-the-icons-ivy-rich-file-icon) ((all-the-icons-ivy-rich-file-icon)
(all-the-icons-ivy-rich-project-name (:width 0.4)) (ivy-rich-candidate (:width 0.4))
(all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-project-file-modes (:width 12))
(all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-project-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t")
project-vc-dir
(:columns
((all-the-icons-ivy-rich-file-icon)
(all-the-icons-ivy-rich-project-name (:width 0.4))
(all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right)) (all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-project-file-modes (:width 12)) (all-the-icons-ivy-rich-project-file-modes (:width 12))
(all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face)) (all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
@@ -817,6 +799,51 @@ This value is adjusted depending on the `window-width'."
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face)) (all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face))) (all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t") :delimiter "\t")
package-recompile
(:columns
((all-the-icons-ivy-rich-package-icon)
(ivy-rich-candidate (:width 0.25))
(all-the-icons-ivy-rich-package-version (:width 16 :face all-the-icons-ivy-rich-version-face))
(all-the-icons-ivy-rich-package-status (:width 12))
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t")
package-update
(:columns
((all-the-icons-ivy-rich-package-icon)
(ivy-rich-candidate (:width 0.25))
(all-the-icons-ivy-rich-package-version (:width 16 :face all-the-icons-ivy-rich-version-face))
(all-the-icons-ivy-rich-package-status (:width 12))
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t")
package-vc-checkout
(:columns
((all-the-icons-ivy-rich-package-icon)
(ivy-rich-candidate (:width 0.25))
(all-the-icons-ivy-rich-package-version (:width 16 :face all-the-icons-ivy-rich-version-face))
(all-the-icons-ivy-rich-package-status (:width 12))
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t")
package-vc-install
(:columns
((all-the-icons-ivy-rich-package-icon)
(ivy-rich-candidate (:width 0.25))
(all-the-icons-ivy-rich-package-version (:width 16 :face all-the-icons-ivy-rich-version-face))
(all-the-icons-ivy-rich-package-status (:width 12))
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t")
package-vc-update
(:columns
((all-the-icons-ivy-rich-package-icon)
(ivy-rich-candidate (:width 0.25))
(all-the-icons-ivy-rich-package-version (:width 16 :face all-the-icons-ivy-rich-version-face))
(all-the-icons-ivy-rich-package-status (:width 12))
(all-the-icons-ivy-rich-package-archive-summary (:width 7 :face all-the-icons-ivy-rich-archive-face))
(all-the-icons-ivy-rich-package-install-summary (:face all-the-icons-ivy-rich-pacage-desc-face)))
:delimiter "\t")
;; persp ;; persp
persp-switch-to-buffer persp-switch-to-buffer
@@ -903,7 +930,7 @@ This value is adjusted depending on the `window-width'."
(lambda (cand) (get-buffer cand)) (lambda (cand) (get-buffer cand))
:delimiter "\t") :delimiter "\t")
all-the-icons-ivy-rich-kill-buffer kill-buffer
(:columns (:columns
((all-the-icons-ivy-rich-buffer-icon) ((all-the-icons-ivy-rich-buffer-icon)
(ivy-switch-buffer-transformer (:width 0.3)) (ivy-switch-buffer-transformer (:width 0.3))
@@ -931,10 +958,40 @@ This value is adjusted depending on the `window-width'."
customize-group customize-group
(:columns (:columns
((all-the-icons-ivy-rich-settings-icon) ((all-the-icons-ivy-rich-group-settings-icon)
(ivy-rich-candidate (:width 0.3)) (ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-group-docstring (:face all-the-icons-ivy-rich-doc-face))) (all-the-icons-ivy-rich-custom-group-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t") :delimiter "\t")
customize-group-other-window
(:columns
((all-the-icons-ivy-rich-group-settings-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-group-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
customize-option
(:columns
((all-the-icons-ivy-rich-variable-settings-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-variable-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
customize-option-other-window
(:columns
((all-the-icons-ivy-rich-variable-settings-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-variable-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
customize-variable
(:columns
((all-the-icons-ivy-rich-variable-settings-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-variable-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
customize-variable-other-window
(:columns
((all-the-icons-ivy-rich-variable-settings-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-custom-variable-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
describe-character-set describe-character-set
(:columns (:columns
@@ -956,6 +1013,13 @@ This value is adjusted depending on the `window-width'."
(ivy-rich-candidate)) (ivy-rich-candidate))
:delimiter "\t") :delimiter "\t")
describe-input-method
(:columns
((all-the-icons-ivy-rich-input-method-icon)
(ivy-rich-candidate (:width 0.3))
(all-the-icons-ivy-rich-input-method-docstring (:face all-the-icons-ivy-rich-doc-face)))
:delimiter "\t")
set-input-method set-input-method
(:columns (:columns
((all-the-icons-ivy-rich-input-method-icon) ((all-the-icons-ivy-rich-input-method-icon)
@@ -993,24 +1057,68 @@ This value is adjusted depending on the `window-width'."
(ivy-rich-candidate (:face all-the-icons-ivy-rich-string-face))) (ivy-rich-candidate (:face all-the-icons-ivy-rich-string-face)))
:delimiter "\t") :delimiter "\t")
lsp-install-server
(:columns
((all-the-icons-ivy-rich-lsp-icon)
(ivy-rich-candidate))
:delimiter "\t")
lsp-update-server
(:columns
((all-the-icons-ivy-rich-lsp-icon)
(ivy-rich-candidate))
:delimiter "\t")
lsp-uninstall-server
(:columns
((all-the-icons-ivy-rich-lsp-icon)
(ivy-rich-candidate))
:delimiter "\t")
lsp-ivy-workspace-folders-remove lsp-ivy-workspace-folders-remove
(:columns (:columns
((all-the-icons-ivy-rich-dir-icon) ((all-the-icons-ivy-rich-dir-icon)
(all-the-icons-ivy-rich-project-name (:width 0.4)) (ivy-rich-candidate (:width 0.4))
(all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right)) (all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-project-file-modes (:width 12)) (all-the-icons-ivy-rich-project-file-modes (:width 12))
(all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face)) (all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-project-file-modification-time (:face all-the-icons-ivy-rich-time-face))) (all-the-icons-ivy-rich-project-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t") :delimiter "\t")
magit-find-file
(:columns
((all-the-icons-ivy-rich-magit-file-icon)
(all-the-icons-ivy-rich-file-name (:width 0.4))
(all-the-icons-ivy-rich-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-file-modes (:width 12))
(all-the-icons-ivy-rich-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t")
magit-find-file-other-frame
(:columns
((all-the-icons-ivy-rich-magit-file-icon)
(all-the-icons-ivy-rich-file-name (:width 0.4))
(all-the-icons-ivy-rich-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-file-modes (:width 12))
(all-the-icons-ivy-rich-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t")
magit-find-file-other-window
(:columns
((all-the-icons-ivy-rich-magit-file-icon)
(all-the-icons-ivy-rich-file-name (:width 0.4))
(all-the-icons-ivy-rich-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-file-modes (:width 12))
(all-the-icons-ivy-rich-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t")
ivy-magit-todos
(:columns
((all-the-icons-ivy-rich-magit-todos-icon)
(all-the-icons-ivy-rich-magit-todos-transformer))
:delimiter "\t")
treemacs-projectile treemacs-projectile
(:columns (:columns
((all-the-icons-ivy-rich-project-icon) ((all-the-icons-ivy-rich-project-icon)
(all-the-icons-ivy-rich-project-name (:width 0.4)) (all-the-icons-ivy-rich-project-name))
(all-the-icons-ivy-rich-project-file-id (:width 15 :face all-the-icons-ivy-rich-file-owner-face :align right))
(all-the-icons-ivy-rich-project-file-modes (:width 12))
(all-the-icons-ivy-rich-project-file-size (:width 7 :face all-the-icons-ivy-rich-size-face))
(all-the-icons-ivy-rich-project-file-modification-time (:face all-the-icons-ivy-rich-time-face)))
:delimiter "\t")) :delimiter "\t"))
"Definitions for ivy-rich transformers. "Definitions for ivy-rich transformers.
@@ -1033,7 +1141,7 @@ See `ivy-rich-display-transformers-list' for details."
(format-mode-line (ivy-rich--local-values cand 'mode-name))) (format-mode-line (ivy-rich--local-values cand 'mode-name)))
;; Support `kill-buffer' ;; Support `kill-buffer'
(defun all-the-icons-ivy-rich-kill-buffer (&optional buffer-or-name) (defun all-the-icons-ivy-rich-kill-buffer (fn &optional buffer-or-name)
"Kill the buffer specified by BUFFER-OR-NAME." "Kill the buffer specified by BUFFER-OR-NAME."
(interactive (interactive
(list (completing-read (format "Kill buffer (default %s): " (buffer-name)) (list (completing-read (format "Kill buffer (default %s): " (buffer-name))
@@ -1042,7 +1150,7 @@ See `ivy-rich-display-transformers-list' for details."
(buffer-list)) (buffer-list))
nil t nil nil nil t nil nil
(buffer-name)))) (buffer-name))))
(kill-buffer buffer-or-name)) (funcall fn buffer-or-name))
(defun all-the-icons-ivy-rich--project-root () (defun all-the-icons-ivy-rich--project-root ()
"Get the path to the root of your project. "Get the path to the root of your project.
@@ -1059,9 +1167,10 @@ Return `default-directory' if no project was found."
(projectile-project-root)) (projectile-project-root))
((fboundp 'project-current) ((fboundp 'project-current)
(when-let ((project (project-current))) (when-let ((project (project-current)))
(expand-file-name (if (fboundp 'project-root) (expand-file-name
(if (fboundp 'project-root)
(project-root project) (project-root project)
(cdr project))))) (car (with-no-warnings (project-roots project)))))))
(t default-directory)))) (t default-directory))))
(defun all-the-icons-ivy-rich--file-path (cand) (defun all-the-icons-ivy-rich--file-path (cand)
@@ -1140,7 +1249,7 @@ Return `default-directory' if no project was found."
((file-remote-p file) "") ((file-remote-p file) "")
((not (file-exists-p file)) "") ((not (file-exists-p file)) "")
(t (format-time-string (t (format-time-string
"%b %d %H:%M" "%b %d %R"
(file-attribute-modification-time (file-attributes file)))))) (file-attribute-modification-time (file-attributes file))))))
;; Support `counsel-find-file', `counsel-dired', etc. ;; Support `counsel-find-file', `counsel-dired', etc.
@@ -1183,8 +1292,8 @@ Display the true name when the file is a symlink."
"Return project name for CAND." "Return project name for CAND."
(if (or (ivy--dirname-p cand) (if (or (ivy--dirname-p cand)
(file-directory-p (all-the-icons-ivy-rich--file-path cand))) (file-directory-p (all-the-icons-ivy-rich--file-path cand)))
(propertize cand 'face 'ivy-subdir) (propertize (abbreviate-file-name cand) 'face 'ivy-subdir)
cand)) (abbreviate-file-name cand)))
(defun all-the-icons-ivy-rich-project-file-modes (cand) (defun all-the-icons-ivy-rich-project-file-modes (cand)
"Return file modes for CAND." "Return file modes for CAND."
@@ -1469,12 +1578,19 @@ Only available in `emacs-lisp-mode'."
(all-the-icons-ivy-rich-symbol-docstring sym)) (all-the-icons-ivy-rich-symbol-docstring sym))
"")) ""))
;; Support `customize-group' ;; Support `customize-group' and `customize-group-other-window'
(defun all-the-icons-ivy-rich-custom-group-docstring (cand) (defun all-the-icons-ivy-rich-custom-group-docstring (cand)
"Return custom group's documentation for CAND." "Return custom group's documentation for CAND."
(all-the-icons-ivy-rich--truncate-docstring (all-the-icons-ivy-rich--truncate-docstring
(or (documentation-property (intern cand) 'group-documentation) ""))) (or (documentation-property (intern cand) 'group-documentation) "")))
;; Support `customize-variable' and `customize-variable-other-window'
;; `customize-variable' ia an alias of `customize-option'
(defun all-the-icons-ivy-rich-custom-variable-docstring (cand)
"Return custom variable's documentation for CAND."
(all-the-icons-ivy-rich--truncate-docstring
(or (documentation-property (intern cand) 'variable-documentation) "")))
;; Support `describe-character-set' ;; Support `describe-character-set'
(defun all-the-icons-ivy-rich-charset-docstring (cand) (defun all-the-icons-ivy-rich-charset-docstring (cand)
"Return charset's documentation for CAND." "Return charset's documentation for CAND."
@@ -1575,7 +1691,7 @@ If the buffer is killed, return \"--\"."
(if speed (if speed
(format " at %s b/s" speed) (format " at %s b/s" speed)
""))))) "")))))
(mapconcat 'identity (process-command p) " ")))))) (mapconcat #'identity (process-command p) " "))))))
;; Support `counsel-find-library' and `counsel-load-library' ;; Support `counsel-find-library' and `counsel-load-library'
(defun all-the-icons-ivy-rich-library-transformer (cand) (defun all-the-icons-ivy-rich-library-transformer (cand)
@@ -1584,11 +1700,6 @@ If the buffer is killed, return \"--\"."
cand cand
(propertize cand 'face 'all-the-icons-ivy-rich-off-face))) (propertize cand 'face 'all-the-icons-ivy-rich-off-face)))
(defun all-the-icons-ivy-rich-library-path (cand)
"Return library path for CAND."
(abbreviate-file-name
(or (ignore-errors (find-library-name cand)) "")))
;; Support `counsel-world-clock' ;; Support `counsel-world-clock'
(defun all-the-icons-ivy-rich-world-clock (cand) (defun all-the-icons-ivy-rich-world-clock (cand)
"Return local time of timezone (CAND)." "Return local time of timezone (CAND)."
@@ -1616,6 +1727,15 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(propertize err 'face 'error)))) (propertize err 'face 'error))))
(t cand))) (t cand)))
(defun all-the-icons-ivy-rich-magit-todos-transformer (cand)
"Transform `magit-todos' result (CAND)."
(let* ((strs (split-string cand " "))
(file (car strs))
(desc (cdr strs)))
(format "%s %s"
(propertize file 'face 'ivy-grep-info)
(string-join desc " "))))
;; ;;
;; Icons ;; Icons
;; ;;
@@ -1643,7 +1763,9 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(new-face `(:inherit ,face (new-face `(:inherit ,face
:family ,family :family ,family
:height ,all-the-icons-ivy-rich-icon-size))) :height ,all-the-icons-ivy-rich-icon-size)))
(format " %s" (propertize icon 'face new-face)))) (format "%s%s"
(propertize " " 'display '((space :relative-width 0.1)))
(propertize icon 'face new-face))))
(defun all-the-icons-ivy-rich-buffer-icon (cand) (defun all-the-icons-ivy-rich-buffer-icon (cand)
"Display buffer icon for CAND in `ivy-rich'." "Display buffer icon for CAND in `ivy-rich'."
@@ -1670,6 +1792,17 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(all-the-icons-faicon "file-o" :face 'all-the-icons-dsilver :height 0.9 :v-adjust 0.0) (all-the-icons-faicon "file-o" :face 'all-the-icons-dsilver :height 0.9 :v-adjust 0.0)
(propertize icon 'display '(raise 0.0))))))) (propertize icon 'display '(raise 0.0)))))))
(defun all-the-icons-ivy-rich-magit-file-icon (cand)
"Display file icon for CAND."
(if (string-suffix-p "Find file from revision: " ivy--prompt)
(all-the-icons-ivy-rich-git-branch-icon cand)
(all-the-icons-ivy-rich-file-icon cand)))
(defun all-the-icons-ivy-rich-magit-todos-icon (cand)
"Display file icon in `magit-todos'."
(when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich-file-icon (nth 0 (split-string cand " ")))))
(defun all-the-icons-ivy-rich-dir-icon (_cand) (defun all-the-icons-ivy-rich-dir-icon (_cand)
"Display project icon in `ivy-rich'." "Display project icon in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable) (when (all-the-icons-ivy-rich-icon-displayable)
@@ -1795,6 +1928,12 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(all-the-icons-ivy-rich--format-icon (all-the-icons-ivy-rich--format-icon
(all-the-icons-octicon "git-branch" :height 1.0 :v-adjust -0.05 :face 'all-the-icons-green)))) (all-the-icons-octicon "git-branch" :height 1.0 :v-adjust -0.05 :face 'all-the-icons-green))))
(defun all-the-icons-ivy-rich-git-commit-icon (_cand)
"Display the git branch icon in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich--format-icon
(all-the-icons-octicon "git-commit" :height 1.0 :v-adjust -0.05 :face 'all-the-icons-green))))
(defun all-the-icons-ivy-rich-process-icon (_cand) (defun all-the-icons-ivy-rich-process-icon (_cand)
"Display the process icon in `ivy-rich'." "Display the process icon in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable) (when (all-the-icons-ivy-rich-icon-displayable)
@@ -1849,12 +1988,18 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(all-the-icons-octicon "file-directory" :height 0.9 :v-adjust 0.01)) (all-the-icons-octicon "file-directory" :height 0.9 :v-adjust 0.01))
(t (all-the-icons-icon-for-file (file-name-nondirectory file) :height 0.9 :v-adjust 0.0))))))) (t (all-the-icons-icon-for-file (file-name-nondirectory file) :height 0.9 :v-adjust 0.0)))))))
(defun all-the-icons-ivy-rich-settings-icon (_cand) (defun all-the-icons-ivy-rich-group-settings-icon (_cand)
"Display settings icon for CAND in `ivy-rich'." "Display group settings icon for CAND in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable) (when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich--format-icon (all-the-icons-ivy-rich--format-icon
(all-the-icons-octicon "settings" :height 0.9 :v-adjust -0.01 :face 'all-the-icons-lblue)))) (all-the-icons-octicon "settings" :height 0.9 :v-adjust -0.01 :face 'all-the-icons-lblue))))
(defun all-the-icons-ivy-rich-variable-settings-icon (_cand)
"Display variable settings icon for CAND in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich--format-icon
(all-the-icons-octicon "settings" :height 0.9 :v-adjust -0.01 :face 'all-the-icons-lgreen))))
(defun all-the-icons-ivy-rich-charset-icon (_cand) (defun all-the-icons-ivy-rich-charset-icon (_cand)
"Display charset icon for CAND in `ivy-rich'." "Display charset icon for CAND in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable) (when (all-the-icons-ivy-rich-icon-displayable)
@@ -1888,9 +2033,11 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(defun all-the-icons-ivy-rich-link-icon (cand) (defun all-the-icons-ivy-rich-link-icon (cand)
"Display link icon in `ivy-rich'." "Display link icon in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich--format-icon
(if (string-prefix-p "#" cand) (if (string-prefix-p "#" cand)
(all-the-icons-faicon "anchor" :height 0.8 :v-adjust -0.05 :face 'all-the-icons-green) (all-the-icons-faicon "anchor" :height 0.8 :v-adjust -0.05 :face 'all-the-icons-green)
(all-the-icons-material "link" :height 1.0 :v-adjust -0.2 :face 'all-the-icons-blue))) (all-the-icons-material "link" :height 1.0 :v-adjust -0.2 :face 'all-the-icons-blue)))))
(defun all-the-icons-ivy-rich-key-icon (_cand) (defun all-the-icons-ivy-rich-key-icon (_cand)
"Display key icon in `ivy-rich'." "Display key icon in `ivy-rich'."
@@ -1898,6 +2045,12 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(all-the-icons-ivy-rich--format-icon (all-the-icons-ivy-rich--format-icon
(all-the-icons-octicon "key" :height 0.8 :v-adjust -0.05)))) (all-the-icons-octicon "key" :height 0.8 :v-adjust -0.05))))
(defun all-the-icons-ivy-rich-lsp-icon (_cand)
"Display lsp icon in `ivy-rich'."
(when (all-the-icons-ivy-rich-icon-displayable)
(all-the-icons-ivy-rich--format-icon
(all-the-icons-faicon "rocket" :height 0.8 :v-adjust -0.05 :face 'all-the-icons-lgreen))))
;; ;;
;; Modes ;; Modes
@@ -1914,12 +2067,12 @@ Support`counsel-ack', `counsel-ag', `counsel-pt' and `counsel-rg', etc."
(progn (progn
(add-hook 'minibuffer-setup-hook #'all-the-icons-ivy-rich-minibuffer-align-icons) (add-hook 'minibuffer-setup-hook #'all-the-icons-ivy-rich-minibuffer-align-icons)
(advice-add #'ivy-posframe--display :after #'all-the-icons-ivy-rich-ivy-posframe-align-icons) (advice-add #'ivy-posframe--display :after #'all-the-icons-ivy-rich-ivy-posframe-align-icons)
(global-set-key [remap kill-buffer] #'all-the-icons-ivy-rich-kill-buffer) (advice-add #'kill-buffer :around #'all-the-icons-ivy-rich-kill-buffer)
(setq ivy-rich-display-transformers-list all-the-icons-ivy-rich-display-transformers-list)) (setq ivy-rich-display-transformers-list all-the-icons-ivy-rich-display-transformers-list))
(progn (progn
(remove-hook 'minibuffer-setup-hook #'all-the-icons-ivy-rich-minibuffer-align-icons) (remove-hook 'minibuffer-setup-hook #'all-the-icons-ivy-rich-minibuffer-align-icons)
(advice-remove #'ivy-posframe--display #'all-the-icons-ivy-rich-ivy-posframe-align-icons) (advice-remove #'ivy-posframe--display #'all-the-icons-ivy-rich-ivy-posframe-align-icons)
(global-unset-key [remap kill-buffer]) (advice-remove #'kill-buffer #'all-the-icons-ivy-rich-kill-buffer)
(setq ivy-rich-display-transformers-list all-the-icons-ivy-rich-display-transformers-old-list))) (setq ivy-rich-display-transformers-list all-the-icons-ivy-rich-display-transformers-old-list)))
(ivy-rich-reload)) (ivy-rich-reload))

6
lisp/all-the-icons/all-the-icons-pkg.el
View File

@@ -1,6 +1,8 @@
(define-package "all-the-icons" "20220929.2303" "A library for inserting Developer icons" (define-package "all-the-icons" "20230909.2053" "A library for inserting Developer icons"
'((emacs "24.3")) '((emacs "24.3"))
:commit "51bf77da1ebc3c199dfc11f54c0dce67559f5f40" :authors :commit "be9d5dcda9c892e8ca1535e288620eec075eb0be" :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")

68
lisp/all-the-icons/all-the-icons.el
View File

@@ -210,6 +210,8 @@
("rd" all-the-icons-fileicon "R" :face all-the-icons-lblue) ("rd" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("rdx" all-the-icons-fileicon "R" :face all-the-icons-lblue) ("rdx" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("rsx" all-the-icons-fileicon "R" :face all-the-icons-lblue) ("rsx" all-the-icons-fileicon "R" :face all-the-icons-lblue)
("beancount" all-the-icons-faicon "credit-card" :face all-the-icons-lgreen)
("ledger" all-the-icons-faicon "credit-card" :face all-the-icons-lgreen)
("svelte" all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red) ("svelte" all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red)
("gql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink) ("gql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
("graphql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink) ("graphql" all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
@@ -247,6 +249,7 @@
("sass" all-the-icons-alltheicon "sass" :face all-the-icons-dpink) ("sass" all-the-icons-alltheicon "sass" :face all-the-icons-dpink)
("less" all-the-icons-alltheicon "less" :height 0.8 :face all-the-icons-dyellow) ("less" all-the-icons-alltheicon "less" :height 0.8 :face all-the-icons-dyellow)
("postcss" all-the-icons-fileicon "postcss" :face all-the-icons-dred) ("postcss" all-the-icons-fileicon "postcss" :face all-the-icons-dred)
("pcss" all-the-icons-fileicon "postcss" :face all-the-icons-dred)
("sss" all-the-icons-fileicon "postcss" :face all-the-icons-dred) ("sss" all-the-icons-fileicon "postcss" :face all-the-icons-dred)
("styl" all-the-icons-alltheicon "stylus" :face all-the-icons-lgreen) ("styl" all-the-icons-alltheicon "stylus" :face all-the-icons-lgreen)
("csv" all-the-icons-octicon "graph" :v-adjust 0.0 :face all-the-icons-dblue) ("csv" all-the-icons-octicon "graph" :v-adjust 0.0 :face all-the-icons-dblue)
@@ -277,11 +280,14 @@
("react" all-the-icons-alltheicon "react" :height 1.1 :face all-the-icons-lblue) ("react" all-the-icons-alltheicon "react" :height 1.1 :face all-the-icons-lblue)
("ts" all-the-icons-fileicon "typescript" :height 1.0 :v-adjust -0.1 :face all-the-icons-blue-alt) ("ts" all-the-icons-fileicon "typescript" :height 1.0 :v-adjust -0.1 :face all-the-icons-blue-alt)
("js" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow) ("js" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow)
("mjs" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow)
("es" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow) ("es" all-the-icons-alltheicon "javascript" :height 1.0 :v-adjust 0.0 :face all-the-icons-yellow)
("jsx" all-the-icons-fileicon "jsx-2" :height 1.0 :v-adjust -0.1 :face all-the-icons-cyan-alt) ("jsx" all-the-icons-fileicon "jsx-2" :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) ("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)
@@ -386,6 +392,7 @@
("ogv" all-the-icons-faicon "film" :face all-the-icons-dblue) ("ogv" all-the-icons-faicon "film" :face all-the-icons-dblue)
("mkv" all-the-icons-faicon "film" :face all-the-icons-blue) ("mkv" all-the-icons-faicon "film" :face all-the-icons-blue)
("webm" all-the-icons-faicon "film" :face all-the-icons-blue) ("webm" all-the-icons-faicon "film" :face all-the-icons-blue)
("dav" all-the-icons-faicon "film" :face all-the-icons-blue)
;; Fonts ;; Fonts
("ttf" all-the-icons-fileicon "font" :v-adjust 0.0 :face all-the-icons-dcyan) ("ttf" all-the-icons-fileicon "font" :v-adjust 0.0 :face all-the-icons-dcyan)
("woff" all-the-icons-fileicon "font" :v-adjust 0.0 :face all-the-icons-cyan) ("woff" all-the-icons-fileicon "font" :v-adjust 0.0 :face all-the-icons-cyan)
@@ -397,6 +404,8 @@
("doc" all-the-icons-fileicon "word" :face all-the-icons-blue) ("doc" all-the-icons-fileicon "word" :face all-the-icons-blue)
("docx" all-the-icons-fileicon "word" :face all-the-icons-blue) ("docx" all-the-icons-fileicon "word" :face all-the-icons-blue)
("docm" all-the-icons-fileicon "word" :face all-the-icons-blue) ("docm" all-the-icons-fileicon "word" :face all-the-icons-blue)
("eml" all-the-icons-faicon "envelope" :face all-the-icons-blue)
("msg" all-the-icons-faicon "envelope" :face all-the-icons-blue)
("texi" all-the-icons-fileicon "tex" :face all-the-icons-lred) ("texi" all-the-icons-fileicon "tex" :face all-the-icons-lred)
("tex" all-the-icons-fileicon "tex" :face all-the-icons-lred) ("tex" all-the-icons-fileicon "tex" :face all-the-icons-lred)
("md" all-the-icons-octicon "markdown" :v-adjust 0.0 :face all-the-icons-lblue) ("md" all-the-icons-octicon "markdown" :v-adjust 0.0 :face all-the-icons-lblue)
@@ -405,7 +414,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)
("ppttx" all-the-icons-fileicon "powerpoint" :face all-the-icons-orange) ("pptx" 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)
@@ -577,13 +586,17 @@ for performance sake.")
(erc-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0) (erc-mode all-the-icons-faicon "commenting-o" :height 1.0 :v-adjust 0.0)
(inferior-emacs-lisp-mode all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1 :face all-the-icons-lblue) (inferior-emacs-lisp-mode all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1 :face all-the-icons-lblue)
(dired-mode all-the-icons-octicon "file-directory" :v-adjust 0.0) (dired-mode all-the-icons-octicon "file-directory" :v-adjust 0.0)
(wdired-mode all-the-icons-octicon "file-directory" :v-adjust 0.0 :face all-the-icons-dcyan)
(lisp-interaction-mode all-the-icons-fileicon "lisp" :v-adjust -0.1 :face all-the-icons-orange) (lisp-interaction-mode all-the-icons-fileicon "lisp" :v-adjust -0.1 :face all-the-icons-orange)
(sly-mrepl-mode all-the-icons-fileicon "clisp" :v-adjust -0.1 :face all-the-icons-orange) (sly-mrepl-mode all-the-icons-fileicon "clisp" :v-adjust -0.1 :face all-the-icons-orange)
(slime-repl-mode all-the-icons-fileicon "clisp" :v-adjust -0.1 :face all-the-icons-orange) (slime-repl-mode all-the-icons-fileicon "clisp" :v-adjust -0.1 :face all-the-icons-orange)
(org-mode all-the-icons-fileicon "org" :v-adjust 0.0 :face all-the-icons-lgreen) (org-mode all-the-icons-fileicon "org" :v-adjust 0.0 :face all-the-icons-lgreen)
(typescript-mode all-the-icons-fileicon "typescript" :v-adjust -0.1 :face all-the-icons-blue-alt) (typescript-mode all-the-icons-fileicon "typescript" :v-adjust -0.1 :face all-the-icons-blue-alt)
(typescript-ts-mode all-the-icons-fileicon "typescript" :v-adjust -0.1 :face all-the-icons-blue-alt)
(typescript-tsx-mode all-the-icons-fileicon "tsx" :v-adjust -0.1 :face all-the-icons-cyan-alt) (typescript-tsx-mode all-the-icons-fileicon "tsx" :v-adjust -0.1 :face all-the-icons-cyan-alt)
(tsx-ts-mode all-the-icons-fileicon "tsx" :v-adjust -0.1 :face all-the-icons-cyan-alt)
(js-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow) (js-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js-ts-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js-jsx-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow) (js-jsx-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js2-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow) (js2-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
(js3-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow) (js3-mode all-the-icons-alltheicon "javascript" :v-adjust -0.1 :face all-the-icons-yellow)
@@ -602,6 +615,7 @@ 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)
@@ -612,6 +626,10 @@ for performance sake.")
(mu4e-main-mode all-the-icons-octicon "mail" :v-adjust 0.0) (mu4e-main-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(mu4e-view-mode all-the-icons-octicon "mail-read" :v-adjust 0.0) (mu4e-view-mode all-the-icons-octicon "mail-read" :v-adjust 0.0)
(sieve-mode all-the-icons-octicon "mail" :v-adjust 0.0) (sieve-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(gnus-group-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(gnus-summary-mode all-the-icons-octicon "mail" :v-adjust 0.0)
(gnus-article-mode all-the-icons-octicon "mail-read" :v-adjust 0.0)
(message-mode all-the-icons-octicon "pencil" :v-adjust 0.0)
(package-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver) (package-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver)
(paradox-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver) (paradox-menu-mode all-the-icons-faicon "archive" :height 1.0 :v-adjust 0.0 :face all-the-icons-silver)
(Custom-mode all-the-icons-octicon "settings" :v-adjust -0.1) (Custom-mode all-the-icons-octicon "settings" :v-adjust -0.1)
@@ -624,30 +642,39 @@ for performance sake.")
(text-mode all-the-icons-octicon "file-text" :v-adjust 0.0 :face all-the-icons-cyan) (text-mode all-the-icons-octicon "file-text" :v-adjust 0.0 :face all-the-icons-cyan)
(enh-ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-lred) (enh-ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-lred)
(ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-lred) (ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-lred)
(ruby-ts-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-lred)
(inf-ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red) (inf-ruby-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
(projectile-rails-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red) (projectile-rails-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
(rspec-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red) (rspec-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
(rake-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red) (rake-compilation-mode all-the-icons-alltheicon "ruby-alt" :face all-the-icons-red)
(sh-mode all-the-icons-alltheicon "terminal" :face all-the-icons-purple) (sh-mode all-the-icons-alltheicon "terminal" :face all-the-icons-purple)
(bash-ts-mode all-the-icons-alltheicon "terminal" :face all-the-icons-purple)
(shell-mode all-the-icons-alltheicon "terminal" :face all-the-icons-purple) (shell-mode all-the-icons-alltheicon "terminal" :face all-the-icons-purple)
(fish-mode all-the-icons-alltheicon "terminal" :face all-the-icons-lpink) (fish-mode all-the-icons-alltheicon "terminal" :face all-the-icons-lpink)
(nginx-mode all-the-icons-fileicon "nginx" :height 0.9 :face all-the-icons-dgreen) (nginx-mode all-the-icons-fileicon "nginx" :height 0.9 :face all-the-icons-dgreen)
(apache-mode all-the-icons-alltheicon "apache" :height 0.9 :face all-the-icons-dgreen) (apache-mode all-the-icons-alltheicon "apache" :height 0.9 :face all-the-icons-dgreen)
(makefile-mode all-the-icons-fileicon "gnu" :face all-the-icons-dorange) (makefile-mode all-the-icons-fileicon "gnu" :face all-the-icons-dorange)
(cmake-mode all-the-icons-fileicon "cmake" :face all-the-icons-red) (cmake-mode all-the-icons-fileicon "cmake" :face all-the-icons-red)
(cmake-ts-mode all-the-icons-fileicon "cmake" :face all-the-icons-red)
(dockerfile-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-blue) (dockerfile-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-blue)
(dockerfile-ts-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-blue)
(docker-compose-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-lblue) (docker-compose-mode all-the-icons-fileicon "dockerfile" :face all-the-icons-lblue)
(nxml-mode all-the-icons-faicon "file-code-o" :height 0.95 :face all-the-icons-lorange) (nxml-mode all-the-icons-faicon "file-code-o" :height 0.95 :face all-the-icons-lorange)
(json-mode all-the-icons-octicon "settings" :face all-the-icons-yellow) (json-mode all-the-icons-octicon "settings" :face all-the-icons-yellow)
(json-ts-mode all-the-icons-octicon "settings" :face all-the-icons-yellow)
(jsonian-mode all-the-icons-octicon "settings" :face all-the-icons-yellow) (jsonian-mode all-the-icons-octicon "settings" :face all-the-icons-yellow)
(yaml-mode all-the-icons-octicon "settings" :v-adjust 0.0 :face all-the-icons-dyellow) (yaml-mode all-the-icons-octicon "settings" :v-adjust 0.0 :face all-the-icons-dyellow)
(yaml-ts-mode all-the-icons-octicon "settings" :v-adjust 0.0 :face all-the-icons-dyellow)
(elisp-byte-code-mode all-the-icons-octicon "file-binary" :v-adjust 0.0 :face all-the-icons-dsilver) (elisp-byte-code-mode all-the-icons-octicon "file-binary" :v-adjust 0.0 :face all-the-icons-dsilver)
(archive-mode all-the-icons-octicon "file-zip" :v-adjust 0.0 :face all-the-icons-lmaroon) (archive-mode all-the-icons-octicon "file-zip" :v-adjust 0.0 :face all-the-icons-lmaroon)
(elm-mode all-the-icons-fileicon "elm" :face all-the-icons-blue) (elm-mode all-the-icons-fileicon "elm" :face all-the-icons-blue)
(erlang-mode all-the-icons-alltheicon "erlang" :face all-the-icons-red :v-adjust -0.1 :height 0.9) (erlang-mode all-the-icons-alltheicon "erlang" :face all-the-icons-red :v-adjust -0.1 :height 0.9)
(elixir-mode all-the-icons-alltheicon "elixir" :face all-the-icons-lorange :v-adjust -0.1 :height 0.9) (elixir-mode all-the-icons-alltheicon "elixir" :face all-the-icons-lorange :v-adjust -0.1 :height 0.9)
(java-mode all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple) (java-mode all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple)
(java-ts-mode all-the-icons-alltheicon "java" :height 1.0 :face all-the-icons-purple)
(go-mode all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue) (go-mode all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
(go-ts-mode all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
(go-mod-ts-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
(go-dot-mod-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt) (go-dot-mod-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
(go-dot-work-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt) (go-dot-work-mode all-the-icons-fileicon "config-go" :height 1.0 :face all-the-icons-blue-alt)
(graphql-mode all-the-icons-fileicon "graphql" :face all-the-icons-dpink) (graphql-mode all-the-icons-fileicon "graphql" :face all-the-icons-dpink)
@@ -658,22 +685,29 @@ for performance sake.")
(php-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver) (php-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver)
(prolog-mode all-the-icons-alltheicon "prolog" :height 1.1 :face all-the-icons-lmaroon) (prolog-mode all-the-icons-alltheicon "prolog" :height 1.1 :face all-the-icons-lmaroon)
(python-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue) (python-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue)
(python-ts-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue)
(inferior-python-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue) (inferior-python-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue)
(racket-mode all-the-icons-fileicon "racket" :height 1.2 :face all-the-icons-red) (racket-mode all-the-icons-fileicon "racket" :height 1.2 :face all-the-icons-red)
(rust-mode all-the-icons-alltheicon "rust" :height 1.2 :face all-the-icons-maroon) (rust-mode all-the-icons-alltheicon "rust" :height 1.2 :face all-the-icons-maroon)
(rustic-mode all-the-icons-alltheicon "rust" :height 1.2 :face all-the-icons-maroon)
(rust-ts-mode all-the-icons-alltheicon "rust" :height 1.2 :face all-the-icons-maroon)
(scala-mode all-the-icons-alltheicon "scala" :face all-the-icons-red) (scala-mode all-the-icons-alltheicon "scala" :face all-the-icons-red)
(scheme-mode all-the-icons-fileicon "scheme" :height 1.2 :face all-the-icons-red) (scheme-mode all-the-icons-fileicon "scheme" :height 1.2 :face all-the-icons-red)
(swift-mode all-the-icons-alltheicon "swift" :height 1.0 :v-adjust -0.1 :face all-the-icons-green) (swift-mode all-the-icons-alltheicon "swift" :height 1.0 :v-adjust -0.1 :face all-the-icons-green)
(svelte-mode all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red) (svelte-mode all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red)
(c-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue) (c-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue)
(c-ts-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue)
(c++-mode all-the-icons-alltheicon "cplusplus-line" :v-adjust -0.2 :face all-the-icons-blue) (c++-mode all-the-icons-alltheicon "cplusplus-line" :v-adjust -0.2 :face all-the-icons-blue)
(c++-ts-mode all-the-icons-alltheicon "cplusplus-line" :v-adjust -0.2 :face all-the-icons-blue)
(csharp-mode all-the-icons-alltheicon "csharp-line" :face all-the-icons-dblue) (csharp-mode all-the-icons-alltheicon "csharp-line" :face all-the-icons-dblue)
(csharp-ts-mode all-the-icons-alltheicon "csharp-line" :face all-the-icons-dblue)
(clojure-mode all-the-icons-alltheicon "clojure" :height 1.0 :face all-the-icons-blue) (clojure-mode all-the-icons-alltheicon "clojure" :height 1.0 :face all-the-icons-blue)
(cider-repl-mode all-the-icons-alltheicon "clojure" :height 1.0 :face all-the-icons-green) (cider-repl-mode all-the-icons-alltheicon "clojure" :height 1.0 :face all-the-icons-green)
(clojurescript-mode all-the-icons-fileicon "cljs" :height 1.0 :face all-the-icons-dblue) (clojurescript-mode all-the-icons-fileicon "cljs" :height 1.0 :face all-the-icons-dblue)
(coffee-mode all-the-icons-alltheicon "coffeescript" :height 1.0 :face all-the-icons-maroon) (coffee-mode all-the-icons-alltheicon "coffeescript" :height 1.0 :face all-the-icons-maroon)
(lisp-mode all-the-icons-fileicon "lisp" :face all-the-icons-orange) (lisp-mode all-the-icons-fileicon "lisp" :face all-the-icons-orange)
(css-mode all-the-icons-alltheicon "css3" :face all-the-icons-yellow) (css-mode all-the-icons-alltheicon "css3" :face all-the-icons-yellow)
(css-ts-mode all-the-icons-alltheicon "css3" :face all-the-icons-yellow)
(scss-mode all-the-icons-alltheicon "sass" :face all-the-icons-pink) (scss-mode all-the-icons-alltheicon "sass" :face all-the-icons-pink)
(sass-mode all-the-icons-alltheicon "sass" :face all-the-icons-dpink) (sass-mode all-the-icons-alltheicon "sass" :face all-the-icons-dpink)
(less-css-mode all-the-icons-alltheicon "less" :height 0.8 :face all-the-icons-dyellow) (less-css-mode all-the-icons-alltheicon "less" :height 0.8 :face all-the-icons-dyellow)
@@ -684,6 +718,7 @@ for performance sake.")
(literate-haskell-mode all-the-icons-alltheicon "haskell" :height 1.0 :face all-the-icons-red) (literate-haskell-mode all-the-icons-alltheicon "haskell" :height 1.0 :face all-the-icons-red)
(haml-mode all-the-icons-fileicon "haml" :face all-the-icons-lyellow) (haml-mode all-the-icons-fileicon "haml" :face all-the-icons-lyellow)
(html-mode all-the-icons-alltheicon "html5" :face all-the-icons-orange) (html-mode all-the-icons-alltheicon "html5" :face all-the-icons-orange)
(html-ts-mode all-the-icons-alltheicon "html5" :face all-the-icons-orange)
(rhtml-mode all-the-icons-alltheicon "html5" :face all-the-icons-lred) (rhtml-mode all-the-icons-alltheicon "html5" :face all-the-icons-lred)
(mustache-mode all-the-icons-fileicon "moustache" :face all-the-icons-green) (mustache-mode all-the-icons-fileicon "moustache" :face all-the-icons-green)
(slim-mode all-the-icons-octicon "dashboard" :v-adjust 0.0 :face all-the-icons-yellow) (slim-mode all-the-icons-octicon "dashboard" :v-adjust 0.0 :face all-the-icons-yellow)
@@ -703,6 +738,7 @@ for performance sake.")
(vhdl-mode all-the-icons-fileicon "vhdl" :face all-the-icons-blue) (vhdl-mode all-the-icons-fileicon "vhdl" :face all-the-icons-blue)
(haskell-cabal-mode all-the-icons-fileicon "cabal" :face all-the-icons-lblue) (haskell-cabal-mode all-the-icons-fileicon "cabal" :face all-the-icons-lblue)
(kotlin-mode all-the-icons-fileicon "kotlin" :face all-the-icons-orange) (kotlin-mode all-the-icons-fileicon "kotlin" :face all-the-icons-orange)
(kotlin-ts-mode all-the-icons-fileicon "kotlin" :face all-the-icons-orange)
(nim-mode all-the-icons-fileicon "nimrod" :face all-the-icons-yellow) (nim-mode all-the-icons-fileicon "nimrod" :face all-the-icons-yellow)
(sql-mode all-the-icons-octicon "database" :face all-the-icons-silver) (sql-mode all-the-icons-octicon "database" :face all-the-icons-silver)
(lua-mode all-the-icons-fileicon "lua" :face all-the-icons-dblue) (lua-mode all-the-icons-fileicon "lua" :face all-the-icons-dblue)
@@ -722,15 +758,26 @@ for performance sake.")
(hy-mode all-the-icons-fileicon "hy" :face all-the-icons-blue) (hy-mode all-the-icons-fileicon "hy" :face all-the-icons-blue)
(glsl-mode all-the-icons-fileicon "vertex-shader" :face all-the-icons-green) (glsl-mode all-the-icons-fileicon "vertex-shader" :face all-the-icons-green)
(zig-mode all-the-icons-fileicon "zig" :face all-the-icons-orange) (zig-mode all-the-icons-fileicon "zig" :face all-the-icons-orange)
(exwm-mode all-the-icons-octicon "browser" :v-adjust 0.2 :face all-the-icons-purple)
(beancount-mode all-the-icons-faicon "credit-card" :face all-the-icons-lgreen)
(ledger-mode all-the-icons-faicon "credit-card" :face all-the-icons-lgreen)
(odin-mode all-the-icons-fileicon "odin" :height 1.1 :face all-the-icons-lblue) (odin-mode all-the-icons-fileicon "odin" :height 1.1 :face all-the-icons-lblue)
(pdf-view-mode all-the-icons-octicon "file-pdf" :v-adjust 0.0 :face all-the-icons-dred) (pdf-view-mode all-the-icons-octicon "file-pdf" :v-adjust 0.0 :face all-the-icons-dred)
(spacemacs-buffer-mode all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1 :face all-the-icons-purple)
(elfeed-search-mode all-the-icons-faicon "rss-square" :face all-the-icons-orange) (elfeed-search-mode all-the-icons-faicon "rss-square" :face all-the-icons-orange)
(elfeed-show-mode all-the-icons-faicon "rss" :face all-the-icons-orange) (elfeed-show-mode all-the-icons-faicon "rss" :face all-the-icons-orange)
(emms-browser-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-lyrics-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-show-all-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-metaplaylist-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-tag-editor-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-playlist-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(lilypond-mode all-the-icons-faicon "music" :face all-the-icons-green) (lilypond-mode all-the-icons-faicon "music" :face all-the-icons-green)
(magik-session-mode all-the-icons-alltheicon "terminal" :face all-the-icons-blue) (magik-session-mode all-the-icons-alltheicon "terminal" :face all-the-icons-blue)
(magik-cb-mode all-the-icons-faicon "book" :face all-the-icons-blue) (magik-cb-mode all-the-icons-faicon "book" :face all-the-icons-blue)
(meson-mode all-the-icons-fileicon "meson" :face all-the-icons-purple) (meson-mode all-the-icons-fileicon "meson" :face all-the-icons-purple)
(man-common all-the-icons-fileicon "man-page" :face all-the-icons-blue))) (man-common all-the-icons-fileicon "man-page" :face all-the-icons-blue)
(ess-r-mode all-the-icons-fileicon "R" :face all-the-icons-lblue)))
(defvar all-the-icons-url-alist (defvar all-the-icons-url-alist
'( '(
@@ -843,8 +890,8 @@ for performance sake.")
(eq major-mode auto-mode))) (eq major-mode auto-mode)))
(defun all-the-icons-match-to-alist (file alist) (defun all-the-icons-match-to-alist (file alist)
"Match FILE against an entry in ALIST using `string-match'." "Match FILE against an entry in ALIST using `string-match-p'."
(cdr (cl-find-if (lambda (it) (string-match (car it) file)) alist))) (cdr (cl-find-if (lambda (it) (string-match-p (car it) file)) alist)))
(defun all-the-icons-dir-is-submodule (dir) (defun all-the-icons-dir-is-submodule (dir)
"Checker whether or not DIR is a git submodule." "Checker whether or not DIR is a git submodule."
@@ -916,20 +963,21 @@ inserting functions.
Note: You want chevron, please use `all-the-icons-icon-for-dir-with-chevron'." Note: You want chevron, please use `all-the-icons-icon-for-dir-with-chevron'."
(let* ((dirname (file-name-base (directory-file-name dir))) (let* ((dirname (file-name-base (directory-file-name dir)))
(path (expand-file-name dir))
(icon (all-the-icons-match-to-alist dirname all-the-icons-dir-icon-alist)) (icon (all-the-icons-match-to-alist dirname all-the-icons-dir-icon-alist))
(args (cdr icon))) (args (cdr icon)))
(when arg-overrides (setq args (append `(,(car args)) arg-overrides (cdr args)))) (when arg-overrides (setq args (append `(,(car args)) arg-overrides (cdr args))))
(if (file-remote-p dir) ;; don't call expand-file-name on a remote dir as this can make emacs hang
(apply #'all-the-icons-octicon "terminal" (cdr args))
(let
((path (expand-file-name dir)))
(cond (cond
((file-remote-p path)
(apply #'all-the-icons-octicon "terminal" (cdr args)))
((file-symlink-p path) ((file-symlink-p path)
(apply #'all-the-icons-octicon "file-symlink-directory" (cdr args))) (apply #'all-the-icons-octicon "file-symlink-directory" (cdr args)))
((all-the-icons-dir-is-submodule path) ((all-the-icons-dir-is-submodule path)
(apply #'all-the-icons-octicon "file-submodule" (cdr args))) (apply #'all-the-icons-octicon "file-submodule" (cdr args)))
((file-exists-p (format "%s/.git" path)) ((file-exists-p (format "%s/.git" path))
(apply #'all-the-icons-octicon "repo" (cdr args))) (apply #'all-the-icons-octicon "repo" (cdr args)))
(t (apply (car icon) args))))) (t (apply (car icon) args)))))))
;;;###autoload ;;;###autoload
(defun all-the-icons-icon-for-file (file &rest arg-overrides) (defun all-the-icons-icon-for-file (file &rest arg-overrides)
@@ -1164,7 +1212,7 @@ pause for DURATION seconds between printing each character."
(mapc (mapc
(lambda (it) (lambda (it)
(insert (format "%s - %s\n" (funcall insert-f (car it) :height height) (car it))) (insert (format "%s - %s\n" (funcall insert-f (car it) :height height) (car it)))
(when duration (sit-for duration 0))) (when duration (sit-for duration)))
data))) data)))
(defmacro all-the-icons-define-icon (name alist family &optional font-name) (defmacro all-the-icons-define-icon (name alist family &optional font-name)
@@ -1219,8 +1267,6 @@ 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")

16
lisp/amx/amx-pkg.el Normal file
View File

@@ -0,0 +1,16 @@
(define-package "amx" "20230413.1210" "Alternative M-x with extra features."
'((emacs "24.4")
(s "0"))
:commit "1c2428d21e9d2ee8bee944b572a39ca8c91ca13b" :authors
'(("Ryan C. Thompson" . "rct@thompsonclan.org")
("Cornelius Mika" . "cornelius.mika@gmail.com"))
:maintainers
'(("Ryan C. Thompson" . "rct@thompsonclan.org"))
:maintainer
'("Ryan C. Thompson" . "rct@thompsonclan.org")
:keywords
'("convenience" "usability" "completion")
:url "http://github.com/DarwinAwardWinner/amx/")
;; Local Variables:
;; no-byte-compile: t
;; End:

16
lisp/amx.el → lisp/amx/amx.el
View File

@@ -8,8 +8,6 @@
;; Cornelius Mika <cornelius.mika@gmail.com> ;; Cornelius Mika <cornelius.mika@gmail.com>
;; Maintainer: Ryan C. Thompson <rct@thompsonclan.org> ;; Maintainer: Ryan C. Thompson <rct@thompsonclan.org>
;; URL: http://github.com/DarwinAwardWinner/amx/ ;; URL: http://github.com/DarwinAwardWinner/amx/
;; Package-Version: 20210305.118
;; Package-Commit: 37f9c7ae55eb0331b27200fb745206fc58ceffc0
;; Package-Requires: ((emacs "24.4") (s "0")) ;; Package-Requires: ((emacs "24.4") (s "0"))
;; Version: 3.4 ;; Version: 3.4
;; Keywords: convenience, usability, completion ;; Keywords: convenience, usability, completion
@@ -238,6 +236,7 @@ nil) if you don't find it useful."
"\\`self-insert-and-exit\\'" "\\`self-insert-and-exit\\'"
"\\`ad-Orig-" "\\`ad-Orig-"
"\\`menu-bar" "\\`menu-bar"
"\\`kill-emacs\\'"
amx-command-marked-ignored-p amx-command-marked-ignored-p
amx-command-obsolete-p amx-command-obsolete-p
amx-command-mouse-interactive-p) amx-command-mouse-interactive-p)
@@ -622,7 +621,7 @@ May not work for things like ido and ivy."
(cl-defun amx-completing-read-helm (choices &key initial-input predicate def) (cl-defun amx-completing-read-helm (choices &key initial-input predicate def)
"Amx backend for helm completion." "Amx backend for helm completion."
(require 'helm-config) (require 'helm)
(require 'helm-mode) ; Provides `helm-comp-read-map' (require 'helm-mode) ; Provides `helm-comp-read-map'
(helm-comp-read (amx-prompt-with-prefix-arg) choices (helm-comp-read (amx-prompt-with-prefix-arg) choices
:initial-input initial-input :initial-input initial-input
@@ -630,7 +629,7 @@ May not work for things like ido and ivy."
:default def :default def
:name "Helm M-x Completions" :name "Helm M-x Completions"
:buffer "Helm M-x Completions" :buffer "Helm M-x Completions"
:history extended-command-history :history 'extended-command-history
:reverse-history t :reverse-history t
:must-match t :must-match t
:fuzzy (or (bound-and-true-p helm-mode-fuzzy-match) :fuzzy (or (bound-and-true-p helm-mode-fuzzy-match)
@@ -675,7 +674,8 @@ May not work for things like ido and ivy."
:auto-activate '(bound-and-true-p selectrum-mode)) :auto-activate '(bound-and-true-p selectrum-mode))
(defsubst amx-auto-select-backend () (defsubst amx-auto-select-backend ()
(cl-loop for (bname b) on amx-known-backends by 'cddr (cl-loop
for (bname b) on amx-known-backends by 'cddr
;; Don't auto-select the auto backend, or the ;; Don't auto-select the auto backend, or the
;; default backend. ;; default backend.
unless (memq bname '(auto standard)) unless (memq bname '(auto standard))
@@ -771,10 +771,10 @@ This should be the name of backend defined using
;; This speeds up sorting. ;; This speeds up sorting.
(let (new-commands) (let (new-commands)
(mapatoms (lambda (symbol) (mapatoms (lambda (symbol)
(when (commandp symbol)
(let ((known-command (assq symbol amx-data))) (let ((known-command (assq symbol amx-data)))
(if known-command (if known-command
(setq amx-cache (cons known-command amx-cache)) (setq amx-cache (cons known-command amx-cache))
(when (commandp symbol)
(setq new-commands (cons (list symbol) new-commands))))))) (setq new-commands (cons (list symbol) new-commands)))))))
(if (eq (length amx-cache) 0) (if (eq (length amx-cache) 0)
(setq amx-cache new-commands) (setq amx-cache new-commands)
@@ -848,8 +848,8 @@ has changed."
This function is normally idempotent, only having an effect the This function is normally idempotent, only having an effect the
first time it is called, so it is safe to call it at the first time it is called, so it is safe to call it at the
beginning of any function that expects amx to be initialized. beginning of any function that expects amx to be initialized.
However, optional arg REINIT forces the initialization needs to However, optional arg REINIT forces the initialization to be
be re-run. Interactively, reinitialize when a prefix arg is re-run. Interactively, reinitialize when a prefix arg is
provided." provided."
(interactive "P") (interactive "P")
(when (or reinit (not amx-initialized)) (when (or reinit (not amx-initialized))

8
lisp/anaconda-mode/anaconda-mode-pkg.el
View File

@@ -1,13 +1,17 @@
(define-package "anaconda-mode" "20220922.741" "Code navigation, documentation lookup and completion for Python" (define-package "anaconda-mode" "20230821.2131" "Code navigation, documentation lookup and completion for Python"
'((emacs "25.1") '((emacs "25.1")
(pythonic "0.1.0") (pythonic "0.1.0")
(dash "2.6.0") (dash "2.6.0")
(s "1.9") (s "1.9")
(f "0.16.2")) (f "0.16.2"))
:commit "ca8edbaa7662d97e4a4416ec9a8d743863303911" :authors :commit "9dbd65b034cef519c01f63703399ae59651f85ca" :authors
'(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainers
'(("Artem Malyshev" . "proofit404@gmail.com")) '(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainer :maintainer
'("Artem Malyshev" . "proofit404@gmail.com") '("Artem Malyshev" . "proofit404@gmail.com")
:keywords
'("convenience" "anaconda")
:url "https://github.com/proofit404/anaconda-mode") :url "https://github.com/proofit404/anaconda-mode")
;; Local Variables: ;; Local Variables:
;; no-byte-compile: t ;; no-byte-compile: t

48
lisp/anaconda-mode/anaconda-mode.el
View File

@@ -6,6 +6,7 @@
;; URL: https://github.com/proofit404/anaconda-mode ;; URL: https://github.com/proofit404/anaconda-mode
;; Version: 0.1.15 ;; Version: 0.1.15
;; Package-Requires: ((emacs "25.1") (pythonic "0.1.0") (dash "2.6.0") (s "1.9") (f "0.16.2")) ;; Package-Requires: ((emacs "25.1") (pythonic "0.1.0") (dash "2.6.0") (s "1.9") (f "0.16.2"))
;; Keywords: convenience anaconda
;; 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
@@ -28,6 +29,7 @@
(require 'ansi-color) (require 'ansi-color)
(require 'pythonic) (require 'pythonic)
(require 'cl-lib)
(require 'tramp) (require 'tramp)
(require 'xref) (require 'xref)
(require 'json) (require 'json)
@@ -77,6 +79,13 @@
"Time in seconds `anaconda-mode' waits for a synchronous response." "Time in seconds `anaconda-mode' waits for a synchronous response."
:type 'integer) :type 'integer)
; create a defcustom that only allows for 'never, 'always, or 'remote
(defcustom anaconda-mode-disable-rpc 'never
"Disable RPC calls to the `anaconda-mode' server when remote."
:type '(choice (const :tag "Never" never)
(const :tag "Always" always)
(const :tag "Remote" remote)))
;;; Compatibility ;;; Compatibility
;; Functions from posframe which is an optional dependency ;; Functions from posframe which is an optional dependency
@@ -361,8 +370,11 @@ called when `anaconda-mode-port' will be bound."
(defun anaconda-mode-call (command callback) (defun anaconda-mode-call (command callback)
"Make remote procedure call for COMMAND. "Make remote procedure call for COMMAND.
Apply CALLBACK to the result asynchronously." Apply CALLBACK to the result asynchronously."
(unless (or (eq anaconda-mode-disable-rpc 'always)
(and (eq anaconda-mode-disable-rpc 'remote)
(pythonic-remote-p)))
(anaconda-mode-start (anaconda-mode-start
(lambda () (anaconda-mode-jsonrpc command callback)))) (lambda () (anaconda-mode-jsonrpc command callback)))))
(defun anaconda-mode-call-sync (command callback) (defun anaconda-mode-call-sync (command callback)
"Make remote procedure call for COMMAND. "Make remote procedure call for COMMAND.
@@ -699,26 +711,29 @@ Show ERROR-MESSAGE if result is empty."
;;; Eldoc. ;;; Eldoc.
(defun anaconda-mode-eldoc-function () (defun anaconda-mode-eldoc-function (callback &rest _ignored)
"Show eldoc for context at point." "Show eldoc for context at point."
(anaconda-mode-call "eldoc" 'anaconda-mode-eldoc-callback) (anaconda-mode-call
"eldoc"
(lambda (x)
(funcall callback (anaconda-mode-eldoc-format x))))
;; Don't show response buffer name as ElDoc message. ;; Don't show response buffer name as ElDoc message.
nil) nil)
(defun anaconda-mode-eldoc-callback (result)
"Display eldoc from server RESULT."
(eldoc-message (anaconda-mode-eldoc-format result)))
(defun anaconda-mode-eldoc-format (result) (defun anaconda-mode-eldoc-format (result)
"Format eldoc string from RESULT." "Format eldoc string from RESULT."
(when result (when result
(let ((doc (anaconda-mode-eldoc-format-definition (let ((doc (cl-map 'list
(aref result 0) (lambda (s)
(aref result 1) (anaconda-mode-eldoc-format-definition
(aref result 2)))) (aref s 0)
(aref s 1)
(aref s 2)))
result)))
(if anaconda-mode-eldoc-as-single-line (if anaconda-mode-eldoc-as-single-line
(substring doc 0 (min (frame-width) (length doc))) (let ((d (mapconcat #'identity doc ", ")))
doc)))) (substring d 0 (min (frame-width) (length d))))
(mapconcat #'identity doc "\n")))))
(defun anaconda-mode-eldoc-format-definition (name index params) (defun anaconda-mode-eldoc-format-definition (name index params)
"Format function definition from NAME, INDEX and PARAMS." "Format function definition from NAME, INDEX and PARAMS."
@@ -768,13 +783,14 @@ Show ERROR-MESSAGE if result is empty."
(defun turn-on-anaconda-eldoc-mode () (defun turn-on-anaconda-eldoc-mode ()
"Turn on `anaconda-eldoc-mode'." "Turn on `anaconda-eldoc-mode'."
(make-local-variable 'eldoc-documentation-function) (add-hook 'eldoc-documentation-functions
(setq-local eldoc-documentation-function 'anaconda-mode-eldoc-function) 'anaconda-mode-eldoc-function nil 't)
(eldoc-mode +1)) (eldoc-mode +1))
(defun turn-off-anaconda-eldoc-mode () (defun turn-off-anaconda-eldoc-mode ()
"Turn off `anaconda-eldoc-mode'." "Turn off `anaconda-eldoc-mode'."
(kill-local-variable 'eldoc-documentation-function) (remove-hook 'eldoc-documentation-functions
'anaconda-mode-eldoc-function 't)
(eldoc-mode -1)) (eldoc-mode -1))
(provide 'anaconda-mode) (provide 'anaconda-mode)

10
lisp/anaconda-mode/anaconda-mode.py
View File

@@ -192,11 +192,11 @@ def get_references(script, line, column):
@script_method @script_method
def eldoc(script, line, column): def eldoc(script, line, column):
signatures = script.get_signatures(line, column) signatures = script.get_signatures(line, column)
if len(signatures) == 1: if len(signatures) >= 1:
signature = signatures[0] return [(s.name,
return [signature.name, s.index,
signature.index, [param.description[6:] for param in s.params])
[param.description[6:] for param in signature.params]] for s in signatures]
# Run. # Run.

2
lisp/async/async-bytecomp.el
View File

@@ -6,7 +6,7 @@
;; Thierry Volpiatto <thievol@posteo.net> ;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async byte-compile ;; Keywords: dired async byte-compile
;; X-URL: https://github.com/jwiegley/dired-async ;; X-URL: https://github.com/jwiegley/emacs-async
;; 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

6
lisp/async/async-pkg.el
View File

@@ -1,7 +1,9 @@
(define-package "async" "20221217.649" "Asynchronous processing in Emacs" (define-package "async" "20230528.622" "Asynchronous processing in Emacs"
'((emacs "24.4")) '((emacs "24.4"))
:commit "c4772bec684776e93f1b8d845b452dc850ee2315" :authors :commit "3ae74c0a4ba223ba373e0cb636c385e08d8838be" :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

166
lisp/async/async.el
View File

@@ -46,11 +46,17 @@
(defvar async-send-over-pipe t) (defvar async-send-over-pipe t)
(defvar async-in-child-emacs nil) (defvar async-in-child-emacs nil)
(defvar async-callback nil) (defvar async-callback nil)
(defvar async-callback-for-process nil) (defvar async-callback-for-process nil
"Non-nil if the subprocess is not Emacs executing a lisp form.")
(defvar async-callback-value nil) (defvar async-callback-value nil)
(defvar async-callback-value-set nil) (defvar async-callback-value-set nil)
(defvar async-current-process nil) (defvar async-current-process nil)
(defvar async--procvar nil) (defvar async--procvar nil)
(defvar async-read-marker nil
"Position from which we read the last message packet.
Message packets are delivered from client line-by-line as base64
encoded strings.")
(defvar async-child-init nil (defvar async-child-init nil
"Initialisation file for async child Emacs. "Initialisation file for async child Emacs.
@@ -171,12 +177,16 @@ It is intended to be used as follows:
(prog1 (prog1
(funcall async-callback proc) (funcall async-callback proc)
(unless async-debug (unless async-debug
(kill-buffer (current-buffer)))) ;; we need to check this because theoretically
;; `async-callback' could've killed it already
(when (buffer-live-p (process-buffer proc))
(kill-buffer (process-buffer proc)))))
(set (make-local-variable 'async-callback-value) proc) (set (make-local-variable 'async-callback-value) proc)
(set (make-local-variable 'async-callback-value-set) t)) (set (make-local-variable 'async-callback-value-set) t))
;; Maybe strip out unreadable "#"; They are replaced by ;; Maybe strip out unreadable "#"; They are replaced by
;; empty string unless they are prefixing a special ;; empty string unless they are prefixing a special
;; object like a marker. See issue #145. ;; object like a marker. See issue #145.
(widen)
(goto-char (point-min)) (goto-char (point-min))
(save-excursion (save-excursion
;; Transform markers in list like ;; Transform markers in list like
@@ -189,22 +199,70 @@ It is intended to be used as follows:
(replace-match "(" t t)) (replace-match "(" t t))
(goto-char (point-max)) (goto-char (point-max))
(backward-sexp) (backward-sexp)
(async-handle-result async-callback (read (current-buffer)) (let ((value (read (current-buffer))))
(current-buffer))) (async-handle-result async-callback value (current-buffer))))
(set (make-local-variable 'async-callback-value) (set (make-local-variable 'async-callback-value)
(list 'error (list 'error
(format "Async process '%s' failed with exit code %d" (format "Async process '%s' failed with exit code %d"
(process-name proc) (process-exit-status proc)))) (process-name proc) (process-exit-status proc))))
(set (make-local-variable 'async-callback-value-set) t)))))) (set (make-local-variable 'async-callback-value-set) t))))))
(defun async-read-from-client (proc string)
"Process text from client process.
The string chunks usually arrive in maximum of 4096 bytes, so a
long client message might be split into multiple calls of this
function.
We use a marker `async-read-marker' to track the position of the
lasts complete line. Every time we get new input, we try to look
for newline, and if found, process the entire line and bump the
marker position to the end of this next line."
(with-current-buffer (process-buffer proc)
(goto-char (point-max))
(save-excursion
(insert string))
(while (search-forward "\n" nil t)
(save-excursion
(save-restriction
(widen)
(narrow-to-region async-read-marker (point))
(goto-char (point-min))
(let (msg)
(condition-case nil
;; It is safe to throw errors in the read because we
;; send messages always on their own line, and they
;; are always a base64 encoded string, so a message
;; will always read. We will also ignore the rest
;; of this line since there won't be anything
;; interesting.
(while (setq msg (read (current-buffer)))
(let ((msg-decoded (ignore-errors (base64-decode-string msg))))
(when msg-decoded
(setq msg-decoded (car (read-from-string msg-decoded)))
(when (and (listp msg-decoded)
(async-message-p msg-decoded)
async-callback)
(funcall async-callback msg-decoded)))))
;; This is OK, we reached the end of the chunk subprocess sent
;; at this time.
(invalid-read-syntax t)
(end-of-file t)))
(goto-char (point-max))
(move-marker async-read-marker (point)))))))
(defun async--receive-sexp (&optional stream) (defun async--receive-sexp (&optional stream)
;; FIXME: Why use `utf-8-auto' instead of `utf-8-unix'? This is ;; FIXME: Why use `utf-8-auto' instead of `utf-8-unix'? This is
;; a communication channel over which we have complete control, ;; a communication channel over which we have complete control,
;; so we get to choose exactly which encoding and EOL we use, isn't it? ;; 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)) (let ((sexp (decode-coding-string (base64-decode-string (read stream))
'utf-8-auto)) 'utf-8-emacs-unix))
;; Parent expects UTF-8 encoded text. ;; Parent expects UTF-8 encoded text.
(coding-system-for-write 'utf-8-auto)) (coding-system-for-write 'utf-8-emacs-unix))
(if async-debug (if async-debug
(message "Received sexp {{{%s}}}" (pp-to-string sexp))) (message "Received sexp {{{%s}}}" (pp-to-string sexp)))
(setq sexp (read sexp)) (setq sexp (read sexp))
@@ -221,7 +279,7 @@ It is intended to be used as follows:
(print-symbols-bare t)) (print-symbols-bare t))
(prin1 sexp (current-buffer)) (prin1 sexp (current-buffer))
;; Just in case the string we're sending might contain EOF ;; Just in case the string we're sending might contain EOF
(encode-coding-region (point-min) (point-max) 'utf-8-auto) (encode-coding-region (point-min) (point-max) 'utf-8-emacs-unix)
(base64-encode-region (point-min) (point-max) t) (base64-encode-region (point-min) (point-max) t)
(goto-char (point-min)) (insert ?\") (goto-char (point-min)) (insert ?\")
(goto-char (point-max)) (insert ?\" ?\n))) (goto-char (point-max)) (insert ?\" ?\n)))
@@ -237,17 +295,27 @@ It is intended to be used as follows:
"Called from the child Emacs process' command line." "Called from the child Emacs process' command line."
;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent
;; process expects. ;; process expects.
(let ((coding-system-for-write 'utf-8-auto) (let ((coding-system-for-write 'utf-8-emacs-unix)
(args-left command-line-args-left)) (args-left command-line-args-left))
(setq async-in-child-emacs t (setq async-in-child-emacs t
debug-on-error async-debug debug-on-error async-debug
command-line-args-left nil) command-line-args-left nil)
(condition-case-unless-debug err (condition-case-unless-debug err
(prin1 (funcall (let ((ret (funcall
(async--receive-sexp (unless async-send-over-pipe (async--receive-sexp (unless async-send-over-pipe
args-left)))) args-left)))))
;; The newlines makes client messages more robust and also
;; handle some weird line-buffering issues on windows.
;; Sometimes, the last "chunk" was not read by the filter,
;; so a newline here should force a buffer flush.
(princ "\n")
(prin1 ret)
(princ "\n"))
(error (error
(prin1 (list 'async-signal err)))))) (progn
(princ "\n")
(prin1 (list 'async-signal err))
(princ "\n"))))))
(defun async-ready (future) (defun async-ready (future)
"Query a FUTURE to see if it is ready. "Query a FUTURE to see if it is ready.
@@ -277,20 +345,51 @@ its FINISH-FUNC is nil."
#'identity async-callback-value (current-buffer)))))) #'identity async-callback-value (current-buffer))))))
(defun async-message-p (value) (defun async-message-p (value)
"Return non-nil of VALUE is an async.el message packet." "Return non-nil if VALUE is an async.el message packet."
(and (listp value) (and (listp value)
(plist-get value :async-message))) (plist-get value :async-message)))
(defun async-send (&rest args) (defun async-send (process-or-key &rest args)
"Send the given messages to the asychronous Emacs PROCESS." "Send the given message to the asychronous child or parent Emacs.
To send messages from the parent to a child, PROCESS-OR-KEY is
the child process object. ARGS is a plist. Example:
(async-send proc :operation :load-file :file \"this file\")
To send messages from the child to the parent, PROCESS-OR-KEY is
the first key of the plist, ARGS is a value followed by
optionally more key-value pairs. Example:
(async-send :status \"finished\" :file-size 123)"
(let ((args (append args '(:async-message t)))) (let ((args (append args '(:async-message t))))
(if async-in-child-emacs (if async-in-child-emacs
(if async-callback ;; `princ' because async--insert-sexp already quotes everything.
(funcall async-callback args)) (princ
(async--transmit-sexp (car args) (list 'quote (cdr args)))))) (with-temp-buffer
(async--insert-sexp (cons process-or-key args))
;; always make sure that one message package has its own
;; line as there can be any random debug garbage printed
;; above it.
(concat "\n" (buffer-string))))
(async--transmit-sexp process-or-key (list 'quote args)))))
(defun async-receive () (defun async-receive ()
"Send the given messages to the asychronous Emacs PROCESS." "Receive message from parent Emacs.
The child process blocks until a message is received.
Message is a plist with one key :async-message set to t always
automatically added to signify this plist is an async message.
You can use `async-message-p' to test if the payload was a
message.
Use
(let ((msg (async-receive))) ...)
to read and process a message."
(async--receive-sexp)) (async--receive-sexp))
;;;###autoload ;;;###autoload
@@ -302,11 +401,26 @@ object will return the process object when the program is
finished. Set DEFAULT-DIRECTORY to change PROGRAM's current finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
working directory." working directory."
(let* ((buf (generate-new-buffer (concat "*" name "*"))) (let* ((buf (generate-new-buffer (concat "*" name "*")))
(buf-err (generate-new-buffer (concat "*" name ":err*")))
(proc (let ((process-connection-type nil)) (proc (let ((process-connection-type nil))
(apply #'start-process name buf program program-args)))) (make-process
:name name
:buffer buf
:stderr buf-err
:command (cons program program-args)))))
(set-process-sentinel
(get-buffer-process buf-err)
(lambda (proc _change)
(unless (or async-debug (process-live-p proc))
(kill-buffer (process-buffer proc)))))
(with-current-buffer buf (with-current-buffer buf
(set (make-local-variable 'async-callback) finish-func) (set (make-local-variable 'async-callback) finish-func)
(set (make-local-variable 'async-read-marker)
(set-marker (make-marker) (point-min) buf))
(set-marker-insertion-type async-read-marker nil)
(set-process-sentinel proc #'async-when-done) (set-process-sentinel proc #'async-when-done)
(set-process-filter proc #'async-read-from-client)
(unless (string= name "emacs") (unless (string= name "emacs")
(set (make-local-variable 'async-callback-for-process) t)) (set (make-local-variable 'async-callback-for-process) t))
proc))) proc)))
@@ -348,6 +462,16 @@ When done, the return value is passed to FINISH-FUNC. Example:
(message \"Async process done, result should be 222: %s\" (message \"Async process done, result should be 222: %s\"
result))) result)))
If you call `async-send' from a child process, the message will
be also passed to the FINISH-FUNC. You can test RESULT to see if
it is a message by using `async-message-p'. If nil, it means
this is the final result. Example of the FINISH-FUNC:
(lambda (result)
(if (async-message-p result)
(message \"Received a message from child process: %s\" result)
(message \"Async process done, result: %s\" result)))
If FINISH-FUNC is nil or missing, a future is returned that can If FINISH-FUNC is nil or missing, a future is returned that can
be inspected using `async-get', blocking until the value is be inspected using `async-get', blocking until the value is
ready. Example: ready. Example:
@@ -392,7 +516,7 @@ returns nil. It can still be useful, however, as an argument to
`async-ready' or `async-wait'." `async-ready' or `async-wait'."
(let ((sexp start-func) (let ((sexp start-func)
;; Subordinate Emacs will send text encoded in UTF-8. ;; Subordinate Emacs will send text encoded in UTF-8.
(coding-system-for-read 'utf-8-auto)) (coding-system-for-read 'utf-8-emacs-unix))
(setq async--procvar (setq async--procvar
(apply 'async-start-process (apply 'async-start-process
"emacs" (file-truename "emacs" (file-truename

19
lisp/async/dired-async.el
View File

@@ -6,7 +6,7 @@
;; Thierry Volpiatto <thievol@posteo.net> ;; Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async network ;; Keywords: dired async network
;; X-URL: https://github.com/jwiegley/dired-async ;; X-URL: https://github.com/jwiegley/emacs-async
;; 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
@@ -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) async-quiet-switch create-dir)
(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,7 +344,17 @@ 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
@@ -353,7 +363,8 @@ 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.

15
lisp/avy/avy-pkg.el Normal file
View File

@@ -0,0 +1,15 @@
(define-package "avy" "20230420.404" "Jump to arbitrary positions in visible text and select text quickly."
'((emacs "24.1")
(cl-lib "0.5"))
:commit "be612110cb116a38b8603df367942e2bb3d9bdbe" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainers
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainer
'("Oleh Krehel" . "ohwoeowho@gmail.com")
:keywords
'("point" "location")
:url "https://github.com/abo-abo/avy")
;; Local Variables:
;; no-byte-compile: t
;; End:

19
lisp/avy.el → lisp/avy/avy.el
View File

@@ -4,8 +4,6 @@
;; Author: Oleh Krehel <ohwoeowho@gmail.com> ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; URL: https://github.com/abo-abo/avy ;; URL: https://github.com/abo-abo/avy
;; Package-Version: 20220910.1936
;; Package-Commit: 955c8dedd68c74f3cf692c1249513f048518c4c9
;; Version: 0.5.0 ;; Version: 0.5.0
;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
;; Keywords: point, location ;; Keywords: point, location
@@ -397,7 +395,7 @@ SEQ-LEN is how many elements of KEYS it takes to identify a match."
(defvar avy-command nil (defvar avy-command nil
"Store the current command symbol. "Store the current command symbol.
E.g. 'avy-goto-line or 'avy-goto-char.") E.g. `avy-goto-line' or `avy-goto-char'.")
(defun avy-tree (lst keys) (defun avy-tree (lst keys)
"Coerce LST into a balanced tree. "Coerce LST into a balanced tree.
@@ -840,11 +838,11 @@ Set `avy-style' according to COMMAND as well."
avy-last-candidates)) avy-last-candidates))
(min-dist (min-dist
(apply #'min (apply #'min
(mapcar (lambda (x) (abs (- (caar x) (point)))) avy-last-candidates))) (mapcar (lambda (x) (abs (- (if (listp (car x)) (caar x) (car x)) (point)))) avy-last-candidates)))
(pos (pos
(cl-position-if (cl-position-if
(lambda (x) (lambda (x)
(= (- (caar x) (point)) min-dist)) (= (- (if (listp (car x)) (caar x) (car x)) (point)) min-dist))
avy-last-candidates))) avy-last-candidates)))
(funcall advancer pos avy-last-candidates))) (funcall advancer pos avy-last-candidates)))
@@ -854,7 +852,8 @@ Set `avy-style' according to COMMAND as well."
(avy--last-candidates-cycle (avy--last-candidates-cycle
(lambda (pos lst) (lambda (pos lst)
(when (> pos 0) (when (> pos 0)
(goto-char (caar (nth (1- pos) lst))))))) (let ((candidate (nth (1- pos) lst)))
(goto-char (if (listp (car candidate)) (caar candidate) (car candidate))))))))
(defun avy-next () (defun avy-next ()
"Go to the next candidate of the last `avy-read'." "Go to the next candidate of the last `avy-read'."
@@ -862,7 +861,8 @@ Set `avy-style' according to COMMAND as well."
(avy--last-candidates-cycle (avy--last-candidates-cycle
(lambda (pos lst) (lambda (pos lst)
(when (< pos (1- (length lst))) (when (< pos (1- (length lst)))
(goto-char (caar (nth (1+ pos) lst))))))) (let ((candidate (nth (1+ pos) lst)))
(goto-char (if (listp (car candidate)) (caar candidate) (car candidate))))))))
;;;###autoload ;;;###autoload
(defun avy-process (candidates &optional overlay-fn cleanup-fn) (defun avy-process (candidates &optional overlay-fn cleanup-fn)
@@ -935,14 +935,14 @@ multiple OVERLAY-FN invocations."
(null (assoc invisible buffer-invisibility-spec))))) (null (assoc invisible buffer-invisibility-spec)))))
(defun avy--next-visible-point () (defun avy--next-visible-point ()
"Return the next closest point without 'invisible property." "Return the next closest point without `invisible' property."
(let ((s (point))) (let ((s (point)))
(while (and (not (= (point-max) (setq s (next-char-property-change s)))) (while (and (not (= (point-max) (setq s (next-char-property-change s))))
(not (avy--visible-p s)))) (not (avy--visible-p s))))
s)) s))
(defun avy--next-invisible-point () (defun avy--next-invisible-point ()
"Return the next closest point with 'invisible property." "Return the next closest point with `invisible' property."
(let ((s (point))) (let ((s (point)))
(while (and (not (= (point-max) (setq s (next-char-property-change s)))) (while (and (not (= (point-max) (setq s (next-char-property-change s))))
(avy--visible-p s))) (avy--visible-p s)))
@@ -1666,6 +1666,7 @@ When BOTTOM-UP is non-nil, display avy candidates from top to bottom"
(defvar linum-overlays) (defvar linum-overlays)
(defvar linum-format) (defvar linum-format)
(declare-function linum--face-width "linum") (declare-function linum--face-width "linum")
(declare-function linum-mode "linum")
(define-minor-mode avy-linum-mode (define-minor-mode avy-linum-mode
"Minor mode that uses avy hints for `linum-mode'." "Minor mode that uses avy hints for `linum-mode'."

17
lisp/biblio-core/biblio-core-pkg.el Normal file
View File

@@ -0,0 +1,17 @@
(define-package "biblio-core" "20230202.1721" "A framework for looking up and displaying bibliographic entries"
'((emacs "24.3")
(let-alist "1.0.4")
(seq "1.11")
(dash "2.12.1"))
:commit "ee52f6cda82ea6fbc3b400e7b12132595cc0374c" :authors
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainers
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainer
'("Clément Pit-Claudel" . "clement.pitclaudel@live.com")
:keywords
'("bib" "tex" "convenience" "hypermedia")
:url "https://github.com/cpitclaudel/biblio.el")
;; Local Variables:
;; no-byte-compile: t
;; End:

11
lisp/biblio-core.el → lisp/biblio-core/biblio-core.el
View File

@@ -3,9 +3,7 @@
;; Copyright (C) 2016 Clément Pit-Claudel ;; Copyright (C) 2016 Clément Pit-Claudel
;; Author: Clément Pit-Claudel <clement.pitclaudel@live.com> ;; Author: Clément Pit-Claudel <clement.pitclaudel@live.com>
;; Version: 0.2.1 ;; Version: 0.3
;; Package-Version: 20210418.406
;; Package-Commit: 517ec18f00f91b61481214b178f7ae0b8fbc499b
;; Package-Requires: ((emacs "24.3") (let-alist "1.0.4") (seq "1.11") (dash "2.12.1")) ;; Package-Requires: ((emacs "24.3") (let-alist "1.0.4") (seq "1.11") (dash "2.12.1"))
;; Keywords: bib, tex, convenience, hypermedia ;; Keywords: bib, tex, convenience, hypermedia
;; URL: https://github.com/cpitclaudel/biblio.el ;; URL: https://github.com/cpitclaudel/biblio.el
@@ -215,7 +213,7 @@ URL and CALLBACK; see `url-queue-retrieve'"
(if biblio-synchronous (if biblio-synchronous
(with-current-buffer (url-retrieve-synchronously url) (with-current-buffer (url-retrieve-synchronously url)
(funcall callback nil)) (funcall callback nil))
(setq url-queue-timeout 1) (setq url-queue-timeout 5)
(url-queue-retrieve url callback))) (url-queue-retrieve url callback)))
(defun biblio-strip (str) (defun biblio-strip (str)
@@ -485,7 +483,10 @@ will be called with the metadata of the current item.")
(defun biblio--completing-read-function () (defun biblio--completing-read-function ()
"Return ido, unless user picked another completion package." "Return ido, unless user picked another completion package."
(if (eq completing-read-function #'completing-read-default) (if (and (eq completing-read-function #'completing-read-default)
(not (catch 'advised ;; https://github.com/cpitclaudel/biblio.el/issues/55
(advice-mapc (lambda (&rest _args) (throw 'advised t))
'completing-read-default))))
#'ido-completing-read #'ido-completing-read
completing-read-function)) completing-read-function))

4
lisp/biblio/biblio-pkg.el
View File

@@ -1,7 +1,7 @@
(define-package "biblio" "20210418.406" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org" (define-package "biblio" "20230202.1721" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org"
'((emacs "24.3") '((emacs "24.3")
(biblio-core "0.2")) (biblio-core "0.2"))
:commit "368f45bf9a64450705a63598224c5af96160af76" :authors :commit "ee52f6cda82ea6fbc3b400e7b12132595cc0374c" :authors
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com")) '(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainer :maintainer
'("Clément Pit-Claudel" . "clement.pitclaudel@live.com") '("Clément Pit-Claudel" . "clement.pitclaudel@live.com")

4
lisp/biblio/biblio.el
View File

@@ -3,8 +3,8 @@
;; Copyright (C) 2016 Clément Pit-Claudel ;; Copyright (C) 2016 Clément Pit-Claudel
;; Author: Clément Pit-Claudel <clement.pitclaudel@live.com> ;; Author: Clément Pit-Claudel <clement.pitclaudel@live.com>
;; Version: 0.2 ;; Version: 0.3
;; Package-Requires: ((emacs "24.3") (biblio-core "0.2")) ;; Package-Requires: ((emacs "24.3") (biblio-core "0.3"))
;; Keywords: bib, tex, convenience, hypermedia ;; Keywords: bib, tex, convenience, hypermedia
;; URL: https://github.com/cpitclaudel/biblio.el ;; URL: https://github.com/cpitclaudel/biblio.el

19
lisp/bibtex-completion/bibtex-completion-pkg.el Normal file
View File

@@ -0,0 +1,19 @@
(define-package "bibtex-completion" "20230918.953" "A BibTeX backend for completion frameworks"
'((parsebib "1.0")
(s "1.9.0")
(dash "2.6.0")
(f "0.16.2")
(cl-lib "0.5")
(biblio "0.2")
(emacs "26.1"))
:commit "95551744de8210867e9d34feaf47ae639ea04114" :authors
'(("Titus von der Malsburg" . "malsburg@posteo.de")
("Justin Burkett" . "justin@burkett.cc"))
:maintainers
'(("Titus von der Malsburg" . "malsburg@posteo.de"))
:maintainer
'("Titus von der Malsburg" . "malsburg@posteo.de")
:url "https://github.com/tmalsburg/helm-bibtex")
;; Local Variables:
;; no-byte-compile: t
;; End:

13
lisp/bibtex-completion.el → lisp/bibtex-completion/bibtex-completion.el
View File

@@ -4,8 +4,6 @@
;; Justin Burkett <justin@burkett.cc> ;; Justin Burkett <justin@burkett.cc>
;; Maintainer: Titus von der Malsburg <malsburg@posteo.de> ;; Maintainer: Titus von der Malsburg <malsburg@posteo.de>
;; URL: https://github.com/tmalsburg/helm-bibtex ;; URL: https://github.com/tmalsburg/helm-bibtex
;; Package-Version: 20221024.857
;; Package-Commit: 78f5931e1cc82e7ae2bcf0508cf31d0d1629a8dd
;; Version: 1.0.0 ;; Version: 1.0.0
;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1")) ;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1"))
@@ -1187,6 +1185,9 @@ string if FIELD is not present in ENTRY and DEFAULT is nil."
("editor-abbrev" ("editor-abbrev"
(when-let ((value (bibtex-completion-get-value "editor" entry))) (when-let ((value (bibtex-completion-get-value "editor" entry)))
(bibtex-completion-apa-format-editors-abbrev value))) (bibtex-completion-apa-format-editors-abbrev value)))
((or "journal" "journaltitle")
(or (bibtex-completion-get-value "journal" entry)
(bibtex-completion-get-value "journaltitle" entry)))
(_ (_
;; Real fields: ;; Real fields:
(let ((value (bibtex-completion-get-value field entry))) (let ((value (bibtex-completion-get-value field entry)))
@@ -1218,9 +1219,11 @@ string if FIELD is not present in ENTRY and DEFAULT is nil."
;; the journal in its title. ;; the journal in its title.
("pages" (s-join "–" (s-split "[^0-9]+" value t))) ("pages" (s-join "–" (s-split "[^0-9]+" value t)))
("doi" (s-concat " http://dx.doi.org/" value)) ("doi" (s-concat " http://dx.doi.org/" value))
("year" (or value ("year" value)
(car (split-string (bibtex-completion-get-value "date" entry "") "-")))) (_ value))
(_ value)))))) (pcase field
("year" (car (split-string (bibtex-completion-get-value "date" entry "") "-"))))
))))
default "")) default ""))
(defun bibtex-completion-apa-format-authors (value &optional abbrev) (defun bibtex-completion-apa-format-authors (value &optional abbrev)

14
lisp/bind-key/bind-key-pkg.el Normal file
View File

@@ -0,0 +1,14 @@
(define-package "bind-key" "20230203.2004" "A simple way to manage personal keybindings"
'((emacs "24.3"))
:commit "77945e002f11440eae72d8730d3de218163d551e" :authors
'(("John Wiegley" . "johnw@newartisans.com"))
:maintainers
'(("John Wiegley" . "johnw@newartisans.com"))
:maintainer
'("John Wiegley" . "johnw@newartisans.com")
:keywords
'("keys" "keybinding" "config" "dotemacs" "extensions")
:url "https://github.com/jwiegley/use-package")
;; Local Variables:
;; no-byte-compile: t
;; End:

5
lisp/bind-key.el → lisp/bind-key/bind-key.el
View File

@@ -6,8 +6,6 @@
;; Maintainer: John Wiegley <johnw@newartisans.com> ;; Maintainer: John Wiegley <johnw@newartisans.com>
;; Created: 16 Jun 2012 ;; Created: 16 Jun 2012
;; Version: 2.4.1 ;; Version: 2.4.1
;; Package-Version: 20221209.2013
;; Package-Commit: bcf0984cf55b70fe6896c6a15f61df92b24f8ffd
;; Package-Requires: ((emacs "24.3")) ;; Package-Requires: ((emacs "24.3"))
;; Keywords: keys keybinding config dotemacs extensions ;; Keywords: keys keybinding config dotemacs extensions
;; URL: https://github.com/jwiegley/use-package ;; URL: https://github.com/jwiegley/use-package
@@ -168,7 +166,8 @@ KEY-NAME may be a vector, in which case it is passed straight to
spelled-out keystrokes, e.g., \"C-c C-z\". See the documentation spelled-out keystrokes, e.g., \"C-c C-z\". See the documentation
of `edmacro-mode' for details. of `edmacro-mode' for details.
COMMAND must be an interactive function or lambda form. COMMAND must be an interactive function, lambda form, or a cons
`(STRING . DEFN)'.
KEYMAP, if present, should be a keymap variable or symbol. KEYMAP, if present, should be a keymap variable or symbol.
For example: For example:

15
lisp/cfrs/cfrs-pkg.el Normal file
View File

@@ -0,0 +1,15 @@
(define-package "cfrs" "20220129.1149" "Child-frame based read-string"
'((emacs "26.1")
(dash "2.11.0")
(s "1.10.0")
(posframe "0.6.0"))
:commit "f3a21f237b2a54e6b9f8a420a9da42b4f0a63121" :authors
'(("Alexander Miller" . "alexanderm@web.de"))
:maintainers
'(("Alexander Miller" . "alexanderm@web.de"))
:maintainer
'("Alexander Miller" . "alexanderm@web.de")
:url "https://github.com/Alexander-Miller/cfrs")
;; Local Variables:
;; no-byte-compile: t
;; End:

4
lisp/cfrs.el → lisp/cfrs/cfrs.el
View File

@@ -4,9 +4,7 @@
;; Author: Alexander Miller <alexanderm@web.de> ;; Author: Alexander Miller <alexanderm@web.de>
;; Package-Requires: ((emacs "26.1") (dash "2.11.0") (s "1.10.0") (posframe "0.6.0")) ;; Package-Requires: ((emacs "26.1") (dash "2.11.0") (s "1.10.0") (posframe "0.6.0"))
;; Package-Commit: f3a21f237b2a54e6b9f8a420a9da42b4f0a63121 ;; Package-Version: 1.6.0
;; Package-Version: 20220129.1149
;; Package-X-Original-Version: 1.6.0
;; Homepage: https://github.com/Alexander-Miller/cfrs ;; Homepage: https://github.com/Alexander-Miller/cfrs
;; This program is free software; you can redistribute it and/or modify ;; This program is free software; you can redistribute it and/or modify

9
lisp/citeproc/citeproc-cite.el
View File

@@ -141,7 +141,7 @@ links else). For legacy reasons, any other value is treated as
;; Add cite prefix and suffix ;; Add cite prefix and suffix
(when (s-present-p plain-suff) (when (s-present-p plain-suff)
(push (citeproc-rt-from-str suff) result) (push (citeproc-rt-from-str suff) result)
(unless (= (aref plain-suff 0) ?\s) (unless (memql (aref plain-suff 0) '(?, ?\s))
(push " " result))) (push " " result)))
(push rendered-varlist result) (push rendered-varlist result)
(when (s-present-p plain-pref) (when (s-present-p plain-pref)
@@ -237,11 +237,11 @@ For the optional INTERNAL-LINKS argument see
(cadr first-elt) (cadr first-elt)
first-elt)) first-elt))
(author-cite (author-cite
(append '((suppress-author . nil) (stop-rendering-at . names)) (append '((suppress-author . nil) (stop-rendering-at . names)
(prefix) (suffix) (locator))
first-cite)) first-cite))
(rendered-author (citeproc-cite--render author-cite style 'no-links))) (rendered-author (citeproc-cite--render author-cite style 'no-links)))
(when (and (listp rendered-author) (when (listp rendered-author)
(alist-get 'stopped-rendering (car rendered-author)))
(setq result `(nil ,rendered-author " " ,result))))) (setq result `(nil ,rendered-author " " ,result)))))
;; Capitalize first ;; Capitalize first
(when (citeproc-citation-capitalize-first c) (when (citeproc-citation-capitalize-first c)
@@ -548,6 +548,7 @@ Possible values are `last', `first' and `subsequent'.")
(unless (citeproc-proc-finalized proc) (unless (citeproc-proc-finalized proc)
(citeproc-proc-process-uncited proc) (citeproc-proc-process-uncited proc)
(citeproc-sb-add-subbib-info proc) (citeproc-sb-add-subbib-info proc)
(citeproc-sb-prune-unrendered proc)
(citeproc-proc-update-sortkeys proc) (citeproc-proc-update-sortkeys proc)
(citeproc-proc-sort-itds proc) (citeproc-proc-sort-itds proc)
(citeproc-proc-update-positions proc) (citeproc-proc-update-positions proc)

10
lisp/citeproc/citeproc-formatters.el
View File

@@ -164,8 +164,10 @@ Performs finalization by removing unnecessary zero-width spaces."
(setq result (citeproc-s-replace-all-seq (setq result (citeproc-s-replace-all-seq
result '((" ​" . " ") ("​ " . " ") ("​," . ",") ("​;" . ";") result '((" ​" . " ") ("​ " . " ") ("​," . ",") ("​;" . ";")
("​:" . ":") ("​." . ".")))) ("​:" . ":") ("​." . "."))))
;; Starting and ending z-w spaces are also removed. ;; Starting and ending z-w spaces are also removed, but not before an
(when (= (aref result 0) 8203) ;; asterisk to avoid creating an Org heading.
(when (and (= (aref result 0) 8203)
(not (= (aref result 1) ?*)))
(setq result (substring result 1))) (setq result (substring result 1)))
(when (= (aref result (- (length result) 1)) 8203) (when (= (aref result (- (length result) 1)) 8203)
(setq result (substring result 0 -1)))) (setq result (substring result 0 -1))))
@@ -371,7 +373,9 @@ CSL tests."
:rt (citeproc-formatter-fun-create citeproc-fmt--org-latex-alist) :rt (citeproc-formatter-fun-create citeproc-fmt--org-latex-alist)
:bib #'citeproc-fmt--org-latex-bib-formatter)) :bib #'citeproc-fmt--org-latex-bib-formatter))
(latex . ,(citeproc-formatter-create (latex . ,(citeproc-formatter-create
:rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist))) :rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist)
:bib (lambda (x _) (concat (mapconcat #'identity x "\n\n")
"\\bigskip"))))
(plain . ,(citeproc-formatter-create :rt #'citeproc-rt-to-plain (plain . ,(citeproc-formatter-create :rt #'citeproc-rt-to-plain
:no-external-links t))) :no-external-links t)))
"Alist mapping supported output formats to formatter structs.") "Alist mapping supported output formats to formatter structs.")

5
lisp/citeproc/citeproc-itemdata.el
View File

@@ -45,9 +45,10 @@ OCCURRED-BEFORE is used during bibliography generation to
DISAMB-POS contains the position on which cite disambiguation is DISAMB-POS contains the position on which cite disambiguation is
based. Possible values are 'first, 'ibid and 'subsequent, based. Possible values are 'first, 'ibid and 'subsequent,
SUBBIB-NOS is a list of numeric indexes of sub-bibliographies SUBBIB-NOS is a list of numeric indexes of sub-bibliographies
in which the item occurs." in which the item occurs,
UNCITED is t iff the item has no associated citation."
varvals rawcite rawbibitem rc-uptodate sort-key occurred-before varvals rawcite rawbibitem rc-uptodate sort-key occurred-before
disamb-pos subbib-nos) disamb-pos subbib-nos uncited)
(defun citeproc-itd-getvar (itd var) (defun citeproc-itd-getvar (itd var)
"Return itemdata ITD's value for VAR ." "Return itemdata ITD's value for VAR ."

6
lisp/citeproc/citeproc-pkg.el
View File

@@ -1,4 +1,4 @@
(define-package "citeproc" "20221216.1238" "A CSL 1.0.2 Citation Processor" (define-package "citeproc" "20230228.1414" "A CSL 1.0.2 Citation Processor"
'((emacs "26") '((emacs "26")
(dash "2.13.0") (dash "2.13.0")
(s "1.12.0") (s "1.12.0")
@@ -7,7 +7,9 @@
(string-inflection "1.0") (string-inflection "1.0")
(org "9") (org "9")
(parsebib "2.4")) (parsebib "2.4"))
:commit "3cb83db147bdda208520246e82dbf9878fa3cbd0" :authors :commit "290320fc579f886255f00d7268600df7fa5cc7e8" :authors
'(("András Simonyi" . "andras.simonyi@gmail.com"))
:maintainers
'(("András Simonyi" . "andras.simonyi@gmail.com")) '(("András Simonyi" . "andras.simonyi@gmail.com"))
:maintainer :maintainer
'("András Simonyi" . "andras.simonyi@gmail.com") '("András Simonyi" . "andras.simonyi@gmail.com")

11
lisp/citeproc/citeproc-proc.el
View File

@@ -99,11 +99,11 @@ sorted."
(push (cons 'editor-translator editor) result)) (push (cons 'editor-translator editor) result))
result)) result))
(defun citeproc-proc--put-item (proc item itemid) (defun citeproc-proc--put-item (proc item itemid &optional uncited)
"Put parsed csl-json ITEM with ITEMID into PROC. "Put parsed csl-json ITEM with ITEMID into PROC.
Return the added itemdata structure." Return the added itemdata structure."
(let* ((int-vars (citeproc-proc--internalize-item proc item)) (let* ((int-vars (citeproc-proc--internalize-item proc item))
(itemdata (citeproc-itemdata-create :varvals int-vars :rc-uptodate nil))) (itemdata (citeproc-itemdata-create :varvals int-vars :uncited uncited)))
(citeproc-proc-put-itd-put itemid itemdata proc) (citeproc-proc-put-itd-put itemid itemdata proc)
(citeproc-itd-setvar itemdata 'citation-number (citeproc-itd-setvar itemdata 'citation-number
(number-to-string (hash-table-count (number-to-string (hash-table-count
@@ -150,7 +150,7 @@ Return the itemdata struct that was added."
(citeproc-proc--put-item (citeproc-proc--put-item
proc proc
(or item `((unprocessed-with-id . ,id))) (or item `((unprocessed-with-id . ,id)))
id)))))) id t))))))
(defun citeproc-proc-delete-occurrence-info (proc) (defun citeproc-proc-delete-occurrence-info (proc)
"Remove all itemdata occurrence info from PROC." "Remove all itemdata occurrence info from PROC."
@@ -225,6 +225,11 @@ Return the PROC-internal representation of REP."
(when bib-sort (setf (citeproc-style-bib-sort style) (byte-compile bib-sort))) (when bib-sort (setf (citeproc-style-bib-sort style) (byte-compile bib-sort)))
(when cite-sort (setf (citeproc-style-cite-sort style) (byte-compile cite-sort))))) (when cite-sort (setf (citeproc-style-cite-sort style) (byte-compile cite-sort)))))
(defun citeproc-proc-filtered-bib-p (proc)
"Return whether PROC has nontrivial filters"
(let ((filters (citeproc-proc-bib-filters proc)))
(and filters (not (equal filters '(nil))))))
(provide 'citeproc-proc) (provide 'citeproc-proc)
;;; citeproc-proc.el ends here ;;; citeproc-proc.el ends here

10
lisp/citeproc/citeproc-sort.el
View File

@@ -169,17 +169,17 @@ MODE is either `cite' or `bib'."
(defun citeproc-proc-sort-itds (proc) (defun citeproc-proc-sort-itds (proc)
"Sort the itemdata in PROC." "Sort the itemdata in PROC."
(let ((sorted-bib-p (citeproc-style-bib-sort (citeproc-proc-style proc))) (let ((is-sorted-bib (citeproc-style-bib-sort (citeproc-proc-style proc)))
(filters (citeproc-proc-bib-filters proc))) (is-filtered (citeproc-proc-filtered-bib-p proc)))
(when (or sorted-bib-p filters) (when (or is-sorted-bib is-filtered)
(let* ((itds (hash-table-values (citeproc-proc-itemdata proc))) (let* ((itds (hash-table-values (citeproc-proc-itemdata proc)))
(sorted (if sorted-bib-p (sorted (if is-sorted-bib
(let ((sort-orders (citeproc-style-bib-sort-orders (let ((sort-orders (citeproc-style-bib-sort-orders
(citeproc-proc-style proc)))) (citeproc-proc-style proc))))
(citeproc-sort-itds itds sort-orders)) (citeproc-sort-itds itds sort-orders))
(citeproc-sort-itds-on-citnum itds)))) (citeproc-sort-itds-on-citnum itds))))
;; Additionally sort according to subbibliographies if there are filters. ;; Additionally sort according to subbibliographies if there are filters.
(when filters (when is-filtered
(setq sorted (sort sorted #'citeproc-sort-itds-on-subbib))) (setq sorted (sort sorted #'citeproc-sort-itds-on-subbib)))
;; Set the CSL citation-number field according to the sort order. ;; Set the CSL citation-number field according to the sort order.
(--each-indexed sorted (--each-indexed sorted

17
lisp/citeproc/citeproc-subbibs.el
View File

@@ -54,6 +54,7 @@ see the documentation of `citeproc-add-subbib-filters'."
(defun citeproc-sb-add-subbib-info (proc) (defun citeproc-sb-add-subbib-info (proc)
"Add subbibliography information to the items in PROC." "Add subbibliography information to the items in PROC."
(when (citeproc-proc-filtered-bib-p proc)
(let ((filters (citeproc-proc-bib-filters proc))) (let ((filters (citeproc-proc-bib-filters proc)))
(maphash (maphash
(lambda (_ itemdata) (lambda (_ itemdata)
@@ -64,7 +65,21 @@ see the documentation of `citeproc-add-subbib-filters'."
(when (citeproc-sb--match-p varvals it) it-index) (when (citeproc-sb--match-p varvals it) it-index)
filters)))) filters))))
(setf (citeproc-itemdata-subbib-nos itemdata) subbib-nos))) (setf (citeproc-itemdata-subbib-nos itemdata) subbib-nos)))
(citeproc-proc-itemdata proc)))) (citeproc-proc-itemdata proc)))))
(defun citeproc-sb-prune-unrendered (proc)
"Remove all itemdata about unrendered items from PROC.
An item is unrendered if
- there are subbibfilters but none of them matches it, and
- it is not cited."
(when (citeproc-proc-filtered-bib-p proc)
(let ((itemdata (citeproc-proc-itemdata proc)))
(maphash
(lambda (id data)
(when (and (citeproc-itemdata-uncited data)
(null (citeproc-itemdata-subbib-nos data)))
(remhash id itemdata)))
itemdata))))
(provide 'citeproc-subbibs) (provide 'citeproc-subbibs)

10
lisp/citeproc/citeproc.el
View File

@@ -1,13 +1,13 @@
;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*- ;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2022 András Simonyi ;; Copyright (C) 2017-2023 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com> ;; Author: András Simonyi <andras.simonyi@gmail.com>
;; Maintainer: András Simonyi <andras.simonyi@gmail.com> ;; Maintainer: András Simonyi <andras.simonyi@gmail.com>
;; URL: https://github.com/andras-simonyi/citeproc-el ;; URL: https://github.com/andras-simonyi/citeproc-el
;; Keywords: bib ;; Keywords: bib
;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4")) ;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4"))
;; Version: 0.9 ;; Version: 0.9.3
;; 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
@@ -196,8 +196,8 @@ formatting parameters keyed to the parameter names as symbols:
punct-in-quote))) punct-in-quote)))
itemdata) itemdata)
(let* ((raw-bib (let* ((raw-bib
(if (cdr filters) (if (citeproc-proc-filtered-bib-p proc)
;; There are several filters, we need to select and sort the subbibs. ;; There are filters, we need to select and sort the subbibs.
(let* ((nr-of-filters (length filters)) (let* ((nr-of-filters (length filters))
(result (make-list nr-of-filters nil)) (result (make-list nr-of-filters nil))
;; We store boolean to-be-sorted flags for each sub-bib ;; We store boolean to-be-sorted flags for each sub-bib
@@ -228,7 +228,7 @@ formatting parameters keyed to the parameter names as symbols:
result)) result))
;; Generate the raw bibs. ;; Generate the raw bibs.
(--map (mapcar #'citeproc-itemdata-rawbibitem it) result)) (--map (mapcar #'citeproc-itemdata-rawbibitem it) result))
;; No filters, so raw-bib is a list containg a single raw bibliograhy. ;; No filters, so raw-bib is a list containing a single raw bibliograhy.
(list (mapcar #'citeproc-itemdata-rawbibitem (list (mapcar #'citeproc-itemdata-rawbibitem
(citeproc-sort-itds-on-citnum (hash-table-values itemdata)))))) (citeproc-sort-itds-on-citnum (hash-table-values itemdata))))))
;; Perform author-substitution. ;; Perform author-substitution.

14
lisp/cl-libify/cl-libify-pkg.el Normal file
View File

@@ -0,0 +1,14 @@
(define-package "cl-libify" "20181130.230" "Update elisp code to use cl-lib instead of cl"
'((emacs "25"))
:commit "e205b96f944a4f312fd523804cbbaf00027a3c8b" :authors
'(("Steve Purcell" . "steve@sanityinc.com"))
:maintainers
'(("Steve Purcell" . "steve@sanityinc.com"))
:maintainer
'("Steve Purcell" . "steve@sanityinc.com")
:keywords
'("lisp")
:url "https://github.com/purcell/cl-libify")
;; Local Variables:
;; no-byte-compile: t
;; End:

4
lisp/cl-libify.el → lisp/cl-libify/cl-libify.el
View File

@@ -4,11 +4,9 @@
;; Author: Steve Purcell <steve@sanityinc.com> ;; Author: Steve Purcell <steve@sanityinc.com>
;; Keywords: lisp ;; Keywords: lisp
;; Package-Commit: e205b96f944a4f312fd523804cbbaf00027a3c8b
;; Homepage: https://github.com/purcell/cl-libify ;; Homepage: https://github.com/purcell/cl-libify
;; Package-Requires: ((emacs "25")) ;; Package-Requires: ((emacs "25"))
;; Package-Version: 20181130.230 ;; Package-Version: 0
;; Package-X-Original-Version: 0
;; 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
lisp/company-anaconda/company-anaconda-pkg.el Normal file
View File

@@ -0,0 +1,19 @@
(define-package "company-anaconda" "20230821.2126" "Anaconda backend for company-mode"
'((emacs "25.1")
(company "0.8.0")
(anaconda-mode "0.1.1")
(cl-lib "0.5.0")
(dash "2.6.0")
(s "1.9"))
:commit "14867265e474f7a919120bbac74870c3256cbacf" :authors
'(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainers
'(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainer
'("Artem Malyshev" . "proofit404@gmail.com")
:keywords
'("convenience" "company" "anaconda")
:url "https://github.com/proofit404/anaconda-mode")
;; Local Variables:
;; no-byte-compile: t
;; End:

5
lisp/company-anaconda.el → lisp/company-anaconda/company-anaconda.el
View File

@@ -4,10 +4,9 @@
;; Author: Artem Malyshev <proofit404@gmail.com> ;; Author: Artem Malyshev <proofit404@gmail.com>
;; URL: https://github.com/proofit404/anaconda-mode ;; URL: https://github.com/proofit404/anaconda-mode
;; Package-Version: 20200404.1859
;; Package-Commit: da1566db41a68809ef7f91ebf2de28118067c89b
;; Version: 0.2.0 ;; Version: 0.2.0
;; Package-Requires: ((company "0.8.0") (anaconda-mode "0.1.1") (cl-lib "0.5.0") (dash "2.6.0") (s "1.9")) ;; Package-Requires: ((emacs "25.1") (company "0.8.0") (anaconda-mode "0.1.1") (cl-lib "0.5.0") (dash "2.6.0") (s "1.9"))
;; Keywords: convenience company anaconda
;; 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

15
lisp/company-ledger/company-ledger-pkg.el Normal file
View File

@@ -0,0 +1,15 @@
(define-package "company-ledger" "20210910.250" "Fuzzy auto-completion for Ledger & friends"
'((emacs "24.3")
(company "0.8.0"))
:commit "55fdddd6c5e9c061c685b474ef5e148a4ac9b576" :authors
'(("Debanjum Singh Solanky" . "debanjumATgmailDOTcom"))
:maintainers
'(("Debanjum Singh Solanky" . "debanjumATgmailDOTcom"))
:maintainer
'("Debanjum Singh Solanky" . "debanjumATgmailDOTcom")
:keywords
'("abbrev" "matching" "auto-complete" "beancount" "ledger" "company")
:url "https://github.com/debanjum/company-ledger")
;; Local Variables:
;; no-byte-compile: t
;; End:

2
lisp/company-ledger.el → lisp/company-ledger/company-ledger.el
View File

@@ -5,8 +5,6 @@
;; Author: Debanjum Singh Solanky <debanjum AT gmail DOT com> ;; Author: Debanjum Singh Solanky <debanjum AT gmail DOT com>
;; Description: Fuzzy auto-completion for ledger & friends ;; Description: Fuzzy auto-completion for ledger & friends
;; Keywords: abbrev, matching, auto-complete, beancount, ledger, company ;; Keywords: abbrev, matching, auto-complete, beancount, ledger, company
;; Package-Version: 20210910.250
;; Package-Commit: 55fdddd6c5e9c061c685b474ef5e148a4ac9b576
;; Version: 0.1.0 ;; Version: 0.1.0
;; Package-Requires: ((emacs "24.3") (company "0.8.0")) ;; Package-Requires: ((emacs "24.3") (company "0.8.0"))
;; URL: https://github.com/debanjum/company-ledger ;; URL: https://github.com/debanjum/company-ledger

16
lisp/company-quickhelp/company-quickhelp-pkg.el Normal file
View File

@@ -0,0 +1,16 @@
(define-package "company-quickhelp" "20231026.1714" "Popup documentation for completion candidates"
'((emacs "24.3")
(company "0.8.9")
(pos-tip "0.4.6"))
:commit "5bda859577582cc42d16fc0eaf5f7c8bedfd9e69" :authors
'(("Lars Andersen" . "expez@expez.com"))
:maintainers
'(("Lars Andersen" . "expez@expez.com"))
:maintainer
'("Lars Andersen" . "expez@expez.com")
:keywords
'("company" "popup" "documentation" "quickhelp")
:url "https://www.github.com/expez/company-quickhelp")
;; Local Variables:
;; no-byte-compile: t
;; End:

5
lisp/company-quickhelp.el → lisp/company-quickhelp/company-quickhelp.el
View File

@@ -4,8 +4,6 @@
;; Author: Lars Andersen <expez@expez.com> ;; Author: Lars Andersen <expez@expez.com>
;; URL: https://www.github.com/expez/company-quickhelp ;; URL: https://www.github.com/expez/company-quickhelp
;; Package-Version: 20221212.534
;; Package-Commit: 9505fb09d064581da142d75c139d48b5cf695bd5
;; Keywords: company popup documentation quickhelp ;; Keywords: company popup documentation quickhelp
;; Version: 2.2.0 ;; Version: 2.2.0
;; Package-Requires: ((emacs "24.3") (company "0.8.9") (pos-tip "0.4.6")) ;; Package-Requires: ((emacs "24.3") (company "0.8.9") (pos-tip "0.4.6"))
@@ -55,7 +53,7 @@
"Delay, in seconds, before the quickhelp popup appears. "Delay, in seconds, before the quickhelp popup appears.
If set to nil the popup won't automatically appear, but can still If set to nil the popup won't automatically appear, but can still
be triggered manually using `company-quickhelp-show'." be triggered manually using `company-quickhelp-manual-begin'."
:type '(choice (number :tag "Delay in seconds") :type '(choice (number :tag "Delay in seconds")
(const :tag "Don't popup help automatically" nil)) (const :tag "Don't popup help automatically" nil))
:group 'company-quickhelp) :group 'company-quickhelp)
@@ -235,7 +233,6 @@ currently active `company' completion candidate."
(defun company-quickhelp-hide () (defun company-quickhelp-hide ()
(company-cancel)) (company-cancel))
(defun company-quickhelp-pos-tip-available-p () (defun company-quickhelp-pos-tip-available-p ()
"Return t if and only if pos-tip is expected work in the current frame." "Return t if and only if pos-tip is expected work in the current frame."
(and (and

15
lisp/company-statistics/company-statistics-pkg.el Normal file
View File

@@ -0,0 +1,15 @@
(define-package "company-statistics" "20170210.1933" "Sort candidates using completion history"
'((emacs "24.3")
(company "0.8.5"))
:commit "e62157d43b2c874d2edbd547c3bdfb05d0a7ae5c" :authors
'(("Ingo Lohmar" . "i.lohmar@gmail.com"))
:maintainers
'(("Ingo Lohmar" . "i.lohmar@gmail.com"))
:maintainer
'("Ingo Lohmar" . "i.lohmar@gmail.com")
:keywords
'("abbrev" "convenience" "matching")
:url "https://github.com/company-mode/company-statistics")
;; Local Variables:
;; no-byte-compile: t
;; End:

2
lisp/company-statistics.el → lisp/company-statistics/company-statistics.el
View File

@@ -4,8 +4,6 @@
;; Author: Ingo Lohmar <i.lohmar@gmail.com> ;; Author: Ingo Lohmar <i.lohmar@gmail.com>
;; URL: https://github.com/company-mode/company-statistics ;; URL: https://github.com/company-mode/company-statistics
;; Package-Version: 20170210.1933
;; Package-Commit: e62157d43b2c874d2edbd547c3bdfb05d0a7ae5c
;; Version: 0.2.3 ;; Version: 0.2.3
;; Keywords: abbrev, convenience, matching ;; Keywords: abbrev, convenience, matching
;; Package-Requires: ((emacs "24.3") (company "0.8.5")) ;; Package-Requires: ((emacs "24.3") (company "0.8.5"))

2
lisp/company-web/company-web-pkg.el
View File

@@ -5,6 +5,8 @@
(web-completion-data "0.1.0")) (web-completion-data "0.1.0"))
:commit "e0c6bfa3ae7006c73d0fdfc0fdb69816309baf1b" :authors :commit "e0c6bfa3ae7006c73d0fdfc0fdb69816309baf1b" :authors
'(("Olexandr Sydorchuk" . "olexandr.syd@gmail.com")) '(("Olexandr Sydorchuk" . "olexandr.syd@gmail.com"))
:maintainers
'(("Olexandr Sydorchuk" . "olexandr.syd@gmail.com"))
:maintainer :maintainer
'("Olexandr Sydorchuk" . "olexandr.syd@gmail.com") '("Olexandr Sydorchuk" . "olexandr.syd@gmail.com")
:keywords :keywords

27
lisp/company/company-capf.el
View File

@@ -1,6 +1,6 @@
;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*- ;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc. ;; Copyright (C) 2013-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
@@ -135,27 +135,10 @@ so we can't just use the preceding variable instead.")
(`match (`match
;; Ask the for the `:company-match' function. If that doesn't help, ;; Ask the for the `:company-match' function. If that doesn't help,
;; fallback to sniffing for face changes to get a suitable value. ;; fallback to sniffing for face changes to get a suitable value.
(let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) (let ((f (or (plist-get (nthcdr 4 company-capf--current-completion-data)
:company-match))) :company-match)
(if f (funcall f arg) #'company--match-from-capf-face)))
(let* ((match-start nil) (pos -1) (funcall f arg)))
(prop-value nil) (faces nil)
(has-face-p nil) chunks
(limit (length arg)))
(while (< pos limit)
(setq pos
(if (< pos 0) 0 (next-property-change pos arg limit)))
(setq prop-value (or
(get-text-property pos 'face arg)
(get-text-property pos 'font-lock-face arg))
faces (if (listp prop-value) prop-value (list prop-value))
has-face-p (memq 'completions-common-part faces))
(cond ((and (not match-start) has-face-p)
(setq match-start pos))
((and match-start (not has-face-p))
(push (cons match-start pos) chunks)
(setq match-start nil))))
(nreverse chunks)))))
(`duplicates t) (`duplicates t)
(`no-cache t) ;Not much can be done here, as long as we handle (`no-cache t) ;Not much can be done here, as long as we handle
;non-prefix matches. ;non-prefix matches.

30
lisp/company/company-clang.el
View File

@@ -1,6 +1,6 @@
;;; company-clang.el --- company-mode completion backend for Clang -*- lexical-binding: t -*- ;;; company-clang.el --- company-mode completion backend for Clang -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2011, 2013-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher
@@ -119,10 +119,9 @@ or automatically through a custom `company-clang-prefix-guesser'."
;; parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: Handle Pattern (syntactic hints would be neat).
;; Do we ever see OVERLOAD (or OVERRIDE)? ;; Do we ever see OVERLOAD (or OVERRIDE)?
(defconst company-clang--completion-pattern (defconst company-clang--completion-pattern
"^COMPLETION: \\_<\\(%s[a-zA-Z0-9_:]*\\)\\(?:\\(?: (InBase)\\)? : \\(.*\\)$\\)?$") "^COMPLETION: \\_<\\(%s[a-zA-Z0-9_:]*\\|Pattern\\)\\(?:\\(?: (InBase)\\)? : \\(.*\\)$\\)?$")
(defconst company-clang--error-buffer-name "*clang-error*") (defconst company-clang--error-buffer-name "*clang-error*")
@@ -138,14 +137,14 @@ or automatically through a custom `company-clang-prefix-guesser'."
(regexp-quote prefix))) (regexp-quote prefix)))
(case-fold-search nil) (case-fold-search nil)
(results (make-hash-table :test 'equal :size (/ (point-max) 100))) (results (make-hash-table :test 'equal :size (/ (point-max) 100)))
lines match) lines)
(while (re-search-forward pattern nil t) (while (re-search-forward pattern nil t)
(setq match (match-string-no-properties 1)) (let ((match (match-string-no-properties 1))
(unless (equal match "Pattern") (meta (match-string-no-properties 2)))
(save-match-data (when (equal match "Pattern")
(setq match (company-clang--pattern-to-match meta)))
(when (string-match ":" match) (when (string-match ":" match)
(setq match (substring match 0 (match-beginning 0))))) (setq match (substring match 0 (match-beginning 0))))
(let ((meta (match-string-no-properties 2)))
;; Avoiding duplicates: ;; Avoiding duplicates:
;; https://github.com/company-mode/company-mode/issues/841 ;; https://github.com/company-mode/company-mode/issues/841
(cond (cond
@@ -154,7 +153,7 @@ or automatically through a custom `company-clang-prefix-guesser'."
(puthash match meta results)) (puthash match meta results))
;; Or it's the first time we see this completion ;; Or it's the first time we see this completion
((eq (gethash match results 'none) 'none) ((eq (gethash match results 'none) 'none)
(puthash match nil results)))))) (puthash match nil results)))))
(maphash (maphash
(lambda (match meta) (lambda (match meta)
(when meta (when meta
@@ -163,6 +162,15 @@ or automatically through a custom `company-clang-prefix-guesser'."
results) results)
lines)) lines))
(defun company-clang--pattern-to-match (pat)
(let ((start 0)
(end nil))
(when (string-match "#]" pat)
(setq start (match-end 0)))
(when (string-match "[ \(]<#" pat start)
(setq end (match-beginning 0)))
(substring pat start end)))
(defun company-clang--meta (candidate) (defun company-clang--meta (candidate)
(get-text-property 0 'meta candidate)) (get-text-property 0 'meta candidate))
@@ -178,6 +186,8 @@ or automatically through a custom `company-clang-prefix-guesser'."
(delete-region pt (point))) (delete-region pt (point)))
(buffer-string))))) (buffer-string)))))
;; TODO: Parse the original formatting here, rather than guess.
;; Strip it every time in the `meta' handler instead.
(defun company-clang--annotation-1 (candidate) (defun company-clang--annotation-1 (candidate)
(let ((meta (company-clang--meta candidate))) (let ((meta (company-clang--meta candidate)))
(cond (cond

60
lisp/company/company-dabbrev-code.el
View File

@@ -1,6 +1,6 @@
;;; company-dabbrev-code.el --- dabbrev-like company-mode backend for code -*- lexical-binding: t -*- ;;; company-dabbrev-code.el --- dabbrev-like company-mode backend for code -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2016, 2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2011, 2013-2016, 2021-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher
@@ -69,11 +69,29 @@ also `company-dabbrev-code-time-limit'."
"Non-nil to ignore case when collecting completion candidates." "Non-nil to ignore case when collecting completion candidates."
:type 'boolean) :type 'boolean)
(defcustom company-dabbrev-code-completion-styles nil
"Non-nil to use the completion styles for fuzzy matching."
:type '(choice (const :tag "Prefix matching only" nil)
(const :tag "Matching according to `completion-styles'" t)
(list :tag "Custom list of styles" symbol)))
(defun company-dabbrev-code--make-regexp (prefix) (defun company-dabbrev-code--make-regexp (prefix)
(concat "\\_<" (if (equal prefix "") (let ((prefix-re
"\\([a-zA-Z]\\|\\s_\\)" (cond
((equal prefix "")
"\\([a-zA-Z]\\|\\s_\\)")
((not company-dabbrev-code-completion-styles)
(regexp-quote prefix)) (regexp-quote prefix))
"\\(\\sw\\|\\s_\\)*\\_>")) (t
;; Use the cache at least after 2 chars. We could also cache
;; earlier, for users who set company-min-p-l to 1 or 0.
(let ((prefix (if (>= (length prefix) 2)
(substring prefix 0 2)
prefix)))
(mapconcat #'regexp-quote
(mapcar #'string prefix)
"\\(\\sw\\|\\s_\\)*"))))))
(concat "\\_<" prefix-re "\\(\\sw\\|\\s_\\)*\\_>")))
;;;###autoload ;;;###autoload
(defun company-dabbrev-code (command &optional arg &rest _ignored) (defun company-dabbrev-code (command &optional arg &rest _ignored)
@@ -88,18 +106,46 @@ comments or strings."
(or company-dabbrev-code-everywhere (or company-dabbrev-code-everywhere
(not (company-in-string-or-comment))) (not (company-in-string-or-comment)))
(or (company-grab-symbol) 'stop))) (or (company-grab-symbol) 'stop)))
(candidates (let ((case-fold-search company-dabbrev-code-ignore-case)) (candidates
(let* ((case-fold-search company-dabbrev-code-ignore-case)
(regexp (company-dabbrev-code--make-regexp arg)))
(company-dabbrev-code--filter
arg
(company-cache-fetch
'dabbrev-code-candidates
(lambda ()
(company-dabbrev--search (company-dabbrev--search
(company-dabbrev-code--make-regexp arg) regexp
company-dabbrev-code-time-limit company-dabbrev-code-time-limit
(pcase company-dabbrev-code-other-buffers (pcase company-dabbrev-code-other-buffers
(`t (list major-mode)) (`t (list major-mode))
(`code company-dabbrev-code-modes) (`code company-dabbrev-code-modes)
(`all `all)) (`all `all))
(not company-dabbrev-code-everywhere)))) (not company-dabbrev-code-everywhere)))
:expire t
:check-tag regexp))))
(kind 'text) (kind 'text)
(no-cache t)
(ignore-case company-dabbrev-code-ignore-case) (ignore-case company-dabbrev-code-ignore-case)
(match (when company-dabbrev-code-completion-styles
(company--match-from-capf-face arg)))
(duplicates t))) (duplicates t)))
(defun company-dabbrev-code--filter (prefix table)
(let ((completion-ignore-case company-dabbrev-code-ignore-case)
(completion-styles (if (listp company-dabbrev-code-completion-styles)
company-dabbrev-code-completion-styles
completion-styles))
res)
(if (not company-dabbrev-code-completion-styles)
(all-completions prefix table)
(setq res (completion-all-completions
prefix
table
nil (length prefix)))
(if (numberp (cdr (last res)))
(setcdr (last res) nil))
res)))
(provide 'company-dabbrev-code) (provide 'company-dabbrev-code)
;;; company-dabbrev-code.el ends here ;;; company-dabbrev-code.el ends here

57
lisp/company/company-dabbrev.el
View File

@@ -1,6 +1,6 @@
;;; company-dabbrev.el --- dabbrev-like company-mode completion backend -*- lexical-binding: t -*- ;;; company-dabbrev.el --- dabbrev-like company-mode completion backend -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2018, 2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2011, 2013-2018, 2021-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher
@@ -70,10 +70,7 @@ candidate is inserted, even some of its characters have different case."
The value of nil means keep them as-is. The value of nil means keep them as-is.
`case-replace' means use the value of `case-replace'. `case-replace' means use the value of `case-replace'.
Any other value means downcase. Any other value means downcase."
If you set this value to nil, you may also want to set
`company-dabbrev-ignore-case' to any value other than `keep-prefix'."
:type '(choice :type '(choice
(const :tag "Keep as-is" nil) (const :tag "Keep as-is" nil)
(const :tag "Downcase" t) (const :tag "Downcase" t)
@@ -114,7 +111,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(when (and (>= (length match) company-dabbrev-minimum-length) (when (and (>= (length match) company-dabbrev-minimum-length)
(not (and company-dabbrev-ignore-invisible (not (and company-dabbrev-ignore-invisible
(invisible-p (match-beginning 0))))) (invisible-p (match-beginning 0)))))
(push match symbols))))) (puthash match t symbols)))))
(goto-char (if pos (1- pos) (point-min))) (goto-char (if pos (1- pos) (point-min)))
;; Search before pos. ;; Search before pos.
(let ((tmp-end (point))) (let ((tmp-end (point)))
@@ -147,7 +144,9 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(defun company-dabbrev--search (regexp &optional limit other-buffer-modes (defun company-dabbrev--search (regexp &optional limit other-buffer-modes
ignore-comments) ignore-comments)
(let* ((start (current-time)) (let* ((start (current-time))
(symbols (company-dabbrev--search-buffer regexp (point) nil start limit (symbols (company-dabbrev--search-buffer regexp (point)
(make-hash-table :test 'equal)
start limit
ignore-comments))) ignore-comments)))
(when other-buffer-modes (when other-buffer-modes
(cl-dolist (buffer (delq (current-buffer) (buffer-list))) (cl-dolist (buffer (delq (current-buffer) (buffer-list)))
@@ -175,8 +174,28 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
1))) 1)))
(defun company-dabbrev--filter (prefix candidates) (defun company-dabbrev--filter (prefix candidates)
(let ((completion-ignore-case company-dabbrev-ignore-case)) (let* ((completion-ignore-case company-dabbrev-ignore-case)
(all-completions prefix candidates))) (filtered (all-completions prefix candidates))
(lp (length prefix))
(downcase (if (eq company-dabbrev-downcase 'case-replace)
case-replace
company-dabbrev-downcase)))
(when downcase
(let ((ptr filtered))
(while ptr
(setcar ptr (downcase (car ptr)))
(setq ptr (cdr ptr)))))
(if (and (eq company-dabbrev-ignore-case 'keep-prefix)
(not (= lp 0)))
(company-substitute-prefix prefix filtered)
filtered)))
(defun company-dabbrev--fetch ()
(company-dabbrev--search (company-dabbrev--make-regexp)
company-dabbrev-time-limit
(pcase company-dabbrev-other-buffers
(`t (list major-mode))
(`all `all))))
;;;###autoload ;;;###autoload
(defun company-dabbrev (command &optional arg &rest _ignored) (defun company-dabbrev (command &optional arg &rest _ignored)
@@ -186,21 +205,13 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(interactive (company-begin-backend 'company-dabbrev)) (interactive (company-begin-backend 'company-dabbrev))
(prefix (company-dabbrev--prefix)) (prefix (company-dabbrev--prefix))
(candidates (candidates
(let* ((case-fold-search company-dabbrev-ignore-case) (company-dabbrev--filter
(words (company-dabbrev--search (company-dabbrev--make-regexp) arg
company-dabbrev-time-limit (company-cache-fetch 'dabbrev-candidates #'company-dabbrev--fetch
(pcase company-dabbrev-other-buffers :expire t)))
(`t (list major-mode))
(`all `all))))
(downcase-p (if (eq company-dabbrev-downcase 'case-replace)
case-replace
company-dabbrev-downcase)))
(setq words (company-dabbrev--filter arg words))
(if downcase-p
(mapcar 'downcase words)
words)))
(kind 'text) (kind 'text)
(ignore-case company-dabbrev-ignore-case) (no-cache t)
(ignore-case (and company-dabbrev-ignore-case t))
(duplicates t))) (duplicates t)))
(provide 'company-dabbrev) (provide 'company-dabbrev)

38
lisp/company/company-ispell.el
View File

@@ -1,6 +1,6 @@
;;; company-ispell.el --- company-mode completion backend using Ispell ;;; company-ispell.el --- company-mode completion backend using Ispell
;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher
@@ -33,30 +33,35 @@
"Completion backend using Ispell." "Completion backend using Ispell."
:group 'company) :group 'company)
(defun company--set-dictionary (symbol value)
(set-default-toplevel-value symbol value)
(company-cache-delete 'ispell-candidates))
(defcustom company-ispell-dictionary nil (defcustom company-ispell-dictionary nil
"Dictionary to use for `company-ispell'. "Dictionary to use for `company-ispell'.
If nil, use `ispell-complete-word-dict'." If nil, use `ispell-complete-word-dict'."
:type '(choice (const :tag "default (nil)" nil) :type '(choice (const :tag "default (nil)" nil)
(file :tag "dictionary" t))) (file :tag "dictionary" t))
:set #'company--set-dictionary)
(defvar company-ispell-available 'unknown) (defvar company-ispell-available 'unknown)
(defalias 'company-ispell--lookup-words
(if (fboundp 'ispell-lookup-words)
'ispell-lookup-words
'lookup-words))
(defun company-ispell-available () (defun company-ispell-available ()
(when (eq company-ispell-available 'unknown) (when (eq company-ispell-available 'unknown)
(condition-case err (condition-case err
(progn (progn
(company-ispell--lookup-words "WHATEVER") (ispell-lookup-words "WHATEVER")
(setq company-ispell-available t)) (setq company-ispell-available t))
(error (error
(message "Company-Ispell: %s" (error-message-string err)) (message "Company-Ispell: %s" (error-message-string err))
(setq company-ispell-available nil)))) (setq company-ispell-available nil))))
company-ispell-available) company-ispell-available)
(defun company--ispell-dict ()
(or company-ispell-dictionary
ispell-complete-word-dict
ispell-alternate-dictionary))
;;;###autoload ;;;###autoload
(defun company-ispell (command &optional arg &rest ignored) (defun company-ispell (command &optional arg &rest ignored)
"`company-mode' completion backend using Ispell." "`company-mode' completion backend using Ispell."
@@ -66,18 +71,23 @@ If nil, use `ispell-complete-word-dict'."
(prefix (when (company-ispell-available) (prefix (when (company-ispell-available)
(company-grab-word))) (company-grab-word)))
(candidates (candidates
(let ((words (company-ispell--lookup-words (let* ((dict (company--ispell-dict))
arg (all-words
(or company-ispell-dictionary ispell-complete-word-dict))) (company-cache-fetch 'ispell-candidates
(lambda () (ispell-lookup-words "" dict))
:check-tag dict))
(completion-ignore-case t)) (completion-ignore-case t))
(if (string= arg "") (if (string= arg "")
;; Small optimization. ;; Small optimization.
words all-words
(company-substitute-prefix
arg
;; Work around issue #284. ;; Work around issue #284.
(all-completions arg words)))) (all-completions arg all-words)))))
(kind 'text) (kind 'text)
(no-cache t)
(sorted t) (sorted t)
(ignore-case 'keep-prefix))) (ignore-case t)))
(provide 'company-ispell) (provide 'company-ispell)
;;; company-ispell.el ends here ;;; company-ispell.el ends here

2
lisp/company/company-keywords.el
View File

@@ -1,6 +1,6 @@
;;; company-keywords.el --- A company backend for programming language keywords ;;; company-keywords.el --- A company backend for programming language keywords
;; Copyright (C) 2009-2011, 2013-2018, 2020-2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2011, 2013-2018, 2020-2022 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher

8
lisp/company/company-pkg.el
View File

@@ -1,7 +1,9 @@
(define-package "company" "20221206.2122" "Modular text completion framework" (define-package "company" "20231023.1033" "Modular text completion framework"
'((emacs "25.1")) '((emacs "25.1"))
:commit "6884e3ad717419b4a64a5fab08c8cb9bd20a0b27" :maintainer :commit "66201465a962ac003f320a1df612641b2b276ab5" :maintainers
'("Dmitry Gutov" . "dgutov@yandex.ru") '(("Dmitry Gutov" . "dmitry@gutov.dev"))
:maintainer
'("Dmitry Gutov" . "dmitry@gutov.dev")
:keywords :keywords
'("abbrev" "convenience" "matching") '("abbrev" "convenience" "matching")
:url "http://company-mode.github.io/") :url "http://company-mode.github.io/")

1
lisp/company/company-tempo.el
View File

@@ -63,6 +63,7 @@
(interactive (company-begin-backend 'company-tempo)) (interactive (company-begin-backend 'company-tempo))
(prefix (or (car (tempo-find-match-string tempo-match-finder)) "")) (prefix (or (car (tempo-find-match-string tempo-match-finder)) ""))
(candidates (all-completions arg (tempo-build-collection))) (candidates (all-completions arg (tempo-build-collection)))
(kind 'snippet)
(meta (company-tempo-meta arg)) (meta (company-tempo-meta arg))
(post-completion (when company-tempo-expand (company-tempo-insert arg))) (post-completion (when company-tempo-expand (company-tempo-insert arg)))
(sorted t))) (sorted t)))

2
lisp/company/company-tng.el
View File

@@ -140,7 +140,7 @@ confirm the selection and finish the completion."
:type 'boolean) :type 'boolean)
;;;###autoload ;;;###autoload
(define-obsolete-function-alias 'company-tng-configure-default 'company-tng-mode "0.9.14" (define-obsolete-function-alias 'company-tng-configure-default 'company-tng-mode "0.10.0"
"Applies the default configuration to enable company-tng.") "Applies the default configuration to enable company-tng.")
(declare-function eglot--snippet-expansion-fn "eglot") (declare-function eglot--snippet-expansion-fn "eglot")

2
lisp/company/company-yasnippet.el
View File

@@ -1,6 +1,6 @@
;;; company-yasnippet.el --- company-mode completion backend for Yasnippet ;;; company-yasnippet.el --- company-mode completion backend for Yasnippet
;; Copyright (C) 2014-2015, 2020-2021 Free Software Foundation, Inc. ;; Copyright (C) 2014-2015, 2020-2022 Free Software Foundation, Inc.
;; Author: Dmitry Gutov ;; Author: Dmitry Gutov

287
lisp/company/company.el
View File

@@ -1,11 +1,11 @@
;;; company.el --- Modular text completion framework -*- lexical-binding: t -*- ;;; company.el --- Modular text completion framework -*- lexical-binding: t -*-
;; Copyright (C) 2009-2022 Free Software Foundation, Inc. ;; Copyright (C) 2009-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher ;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru> ;; Maintainer: Dmitry Gutov <dmitry@gutov.dev>
;; URL: http://company-mode.github.io/ ;; URL: http://company-mode.github.io/
;; Version: 0.9.13 ;; Version: 0.10.2
;; Keywords: abbrev, convenience, matching ;; Keywords: abbrev, convenience, matching
;; Package-Requires: ((emacs "25.1")) ;; Package-Requires: ((emacs "25.1"))
@@ -134,17 +134,17 @@
(defface company-tooltip-quick-access (defface company-tooltip-quick-access
'((default :inherit company-tooltip-annotation)) '((default :inherit company-tooltip-annotation))
"Face used for the quick-access hints shown in the tooltip." "Face used for the quick-access hints shown in the tooltip."
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(defface company-tooltip-quick-access-selection (defface company-tooltip-quick-access-selection
'((default :inherit company-tooltip-annotation-selection)) '((default :inherit company-tooltip-annotation-selection))
"Face used for the selected quick-access hints shown in the tooltip." "Face used for the selected quick-access hints shown in the tooltip."
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(define-obsolete-face-alias (define-obsolete-face-alias
'company-scrollbar-fg 'company-scrollbar-fg
'company-tooltip-scrollbar-thumb 'company-tooltip-scrollbar-thumb
"0.9.14") "0.10.0")
(defface company-tooltip-scrollbar-thumb (defface company-tooltip-scrollbar-thumb
'((((background light)) '((((background light))
@@ -156,7 +156,7 @@
(define-obsolete-face-alias (define-obsolete-face-alias
'company-scrollbar-bg 'company-scrollbar-bg
'company-tooltip-scrollbar-track 'company-tooltip-scrollbar-track
"0.9.14") "0.10.0")
(defface company-tooltip-scrollbar-track (defface company-tooltip-scrollbar-track
'((((background light)) '((((background light))
@@ -286,7 +286,7 @@ This doesn't include the margins and the scroll bar."
(defcustom company-tooltip-width-grow-only nil (defcustom company-tooltip-width-grow-only nil
"When non-nil, the tooltip width is not allowed to decrease." "When non-nil, the tooltip width is not allowed to decrease."
:type 'boolean :type 'boolean
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(defcustom company-tooltip-margin 1 (defcustom company-tooltip-margin 1
"Width of margin columns to show around the toolip." "Width of margin columns to show around the toolip."
@@ -309,6 +309,16 @@ This doesn't include the margins and the scroll bar."
:type 'boolean :type 'boolean
:package-version '(company . "0.8.1")) :package-version '(company . "0.8.1"))
(defcustom company-tooltip-annotation-padding nil
"Non-nil to specify the padding before annotation.
Depending on the value of `company-tooltip-align-annotations', the default
padding is either 0 or 1 space. This variable allows to override that
value to increase the padding. When annotations are right-aligned, it sets
the minimum padding, and otherwise just the constant one."
:type 'number
:package-version '(company "0.10.0"))
(defvar company-safe-backends (defvar company-safe-backends
'((company-abbrev . "Abbrev") '((company-abbrev . "Abbrev")
(company-bbdb . "BBDB") (company-bbdb . "BBDB")
@@ -577,12 +587,12 @@ this."
(define-obsolete-variable-alias (define-obsolete-variable-alias
'company-auto-complete 'company-auto-complete
'company-insertion-on-trigger 'company-insertion-on-trigger
"0.9.14") "0.10.0")
(define-obsolete-variable-alias (define-obsolete-variable-alias
'company-auto-commit 'company-auto-commit
'company-insertion-on-trigger 'company-insertion-on-trigger
"0.9.14") "0.10.0")
(defcustom company-insertion-on-trigger nil (defcustom company-insertion-on-trigger nil
"If enabled, allow triggering insertion of the selected candidate. "If enabled, allow triggering insertion of the selected candidate.
@@ -596,17 +606,17 @@ triggers."
(const :tag "On, if user interaction took place" (const :tag "On, if user interaction took place"
company-explicit-action-p) company-explicit-action-p)
(const :tag "On" t)) (const :tag "On" t))
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(define-obsolete-variable-alias (define-obsolete-variable-alias
'company-auto-complete-chars 'company-auto-complete-chars
'company-insertion-triggers 'company-insertion-triggers
"0.9.14") "0.10.0")
(define-obsolete-variable-alias (define-obsolete-variable-alias
'company-auto-commit-chars 'company-auto-commit-chars
'company-insertion-triggers 'company-insertion-triggers
"0.9.14") "0.10.0")
(defcustom company-insertion-triggers '(?\ ?\) ?.) (defcustom company-insertion-triggers '(?\ ?\) ?.)
"Determine triggers for `company-insertion-on-trigger'. "Determine triggers for `company-insertion-on-trigger'.
@@ -638,7 +648,7 @@ insertion."
(const :tag "Generic string fence." ?|) (const :tag "Generic string fence." ?|)
(const :tag "Generic comment fence." ?!)) (const :tag "Generic comment fence." ?!))
(function :tag "Predicate function")) (function :tag "Predicate function"))
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(defcustom company-idle-delay .2 (defcustom company-idle-delay .2
"The idle delay in seconds until completion starts automatically. "The idle delay in seconds until completion starts automatically.
@@ -692,15 +702,18 @@ commands in the `company-' namespace, abort completion."
(defun company-custom--set-quick-access (option value) (defun company-custom--set-quick-access (option value)
"Re-bind quick-access key sequences on OPTION VALUE change." "Re-bind quick-access key sequences on OPTION VALUE change."
;; When upgrading from an earlier version of company, might not be.
(when (fboundp #'company-keymap--unbind-quick-access)
(when (boundp 'company-active-map) (when (boundp 'company-active-map)
(company-keymap--unbind-quick-access company-active-map)) (company-keymap--unbind-quick-access company-active-map))
(when (boundp 'company-search-map) (when (boundp 'company-search-map)
(company-keymap--unbind-quick-access company-search-map)) (company-keymap--unbind-quick-access company-search-map)))
(custom-set-default option value) (custom-set-default option value)
(when (fboundp #'company-keymap--bind-quick-access)
(when (boundp 'company-active-map) (when (boundp 'company-active-map)
(company-keymap--bind-quick-access company-active-map)) (company-keymap--bind-quick-access company-active-map))
(when (boundp 'company-search-map) (when (boundp 'company-search-map)
(company-keymap--bind-quick-access company-search-map))) (company-keymap--bind-quick-access company-search-map))))
(defcustom company-quick-access-keys '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0") (defcustom company-quick-access-keys '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
"Character strings used as a part of quick-access key sequences. "Character strings used as a part of quick-access key sequences.
@@ -718,7 +731,7 @@ beside the candidates."
;; TODO un-comment on removal of `M-n' `company--select-next-and-warn'. ;; TODO un-comment on removal of `M-n' `company--select-next-and-warn'.
;; (const :tag "Dvorak home row" ("a" "o" "e" "u" "i" "d" "h" "t" "n" "s")) ;; (const :tag "Dvorak home row" ("a" "o" "e" "u" "i" "d" "h" "t" "n" "s"))
(repeat :tag "User defined" string)) (repeat :tag "User defined" string))
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(defcustom company-quick-access-modifier 'meta (defcustom company-quick-access-modifier 'meta
"Modifier key used for quick-access keys sequences. "Modifier key used for quick-access keys sequences.
@@ -729,7 +742,7 @@ See `company-quick-access-keys' for more details."
(const :tag "Super key" super) (const :tag "Super key" super)
(const :tag "Hyper key" hyper) (const :tag "Hyper key" hyper)
(const :tag "Control key" control)) (const :tag "Control key" control))
:package-version '(company . "0.9.14")) :package-version '(company . "0.10.0"))
(defun company-keymap--quick-access-modifier () (defun company-keymap--quick-access-modifier ()
"Return string representation of the `company-quick-access-modifier'." "Return string representation of the `company-quick-access-modifier'."
@@ -764,7 +777,7 @@ See `company-quick-access-keys' for more details."
(define-obsolete-variable-alias (define-obsolete-variable-alias
'company-show-numbers 'company-show-numbers
'company-show-quick-access 'company-show-quick-access
"0.9.14") "0.10.0")
(defcustom company-show-quick-access nil (defcustom company-show-quick-access nil
"If non-nil, show quick-access hints beside the candidates. "If non-nil, show quick-access hints beside the candidates.
@@ -791,7 +804,7 @@ return a string prefixed with one space."
'company-show-numbers-function 'company-show-numbers-function
"use `company-quick-access-hint-function' instead, "use `company-quick-access-hint-function' instead,
but adjust the expected values appropriately." but adjust the expected values appropriately."
"0.9.14") "0.10.0")
(defcustom company-quick-access-hint-function #'company-quick-access-hint-key (defcustom company-quick-access-hint-function #'company-quick-access-hint-key
"Function called to get quick-access hints for the candidates. "Function called to get quick-access hints for the candidates.
@@ -1031,10 +1044,10 @@ means that `company-mode' is always turned on except in `message-mode' buffers."
(defun company-install-map () (defun company-install-map ()
(unless (or (cdar company-emulation-alist) (unless (or (cdar company-emulation-alist)
(null company-my-keymap)) (null company-my-keymap))
(setf (cdar company-emulation-alist) company-my-keymap))) (setq-local company-emulation-alist `((t . ,company-my-keymap)))))
(defun company-uninstall-map () (defun company-uninstall-map ()
(setf (cdar company-emulation-alist) nil)) (kill-local-variable 'company-emulation-alist))
(defun company--company-command-p (keys) (defun company--company-command-p (keys)
"Checks if the keys are part of company's overriding keymap" "Checks if the keys are part of company's overriding keymap"
@@ -1051,6 +1064,10 @@ means that `company-mode' is always turned on except in `message-mode' buffers."
(row (cdr (or (posn-actual-col-row posn) (row (cdr (or (posn-actual-col-row posn)
;; When position is non-visible for some reason. ;; When position is non-visible for some reason.
(posn-col-row posn))))) (posn-col-row posn)))))
;; posn-col-row return value relative to the left
(when (eq (current-bidi-paragraph-direction) 'right-to-left)
(let ((ww (window-body-width)))
(setq col (- ww col))))
(when (bound-and-true-p display-line-numbers) (when (bound-and-true-p display-line-numbers)
(cl-decf col (+ 2 (line-number-display-width)))) (cl-decf col (+ 2 (line-number-display-width))))
(cons (+ col (window-hscroll)) row))) (cons (+ col (window-hscroll)) row)))
@@ -1116,6 +1133,69 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(car (setq ppss (cdr ppss))) (car (setq ppss (cdr ppss)))
(nth 3 ppss)))) (nth 3 ppss))))
(defun company-substitute-prefix (prefix strings)
(let ((len (length prefix)))
(mapcar
(lambda (s)
(if (eq t (compare-strings prefix 0 len s 0 len))
s
(concat prefix (substring s len))))
strings)))
(defun company--match-from-capf-face (str)
"Compute `match' result from a CAPF's completion fontification."
(let* ((match-start nil) (pos -1)
(prop-value nil) (faces nil)
(has-face-p nil) chunks
(limit (length str)))
(while (< pos limit)
(setq pos
(if (< pos 0) 0 (next-property-change pos str limit)))
(setq prop-value (or (get-text-property pos 'face str)
(get-text-property pos 'font-lock-face str))
faces (if (listp prop-value) prop-value (list prop-value))
has-face-p (memq 'completions-common-part faces))
(cond ((and (not match-start) has-face-p)
(setq match-start pos))
((and match-start (not has-face-p))
(push (cons match-start pos) chunks)
(setq match-start nil))))
(nreverse chunks)))
(defvar company--cache (make-hash-table :test #'equal :size 10))
(cl-defun company-cache-fetch (key
fetcher
&key expire check-tag)
"Fetch the value assigned to KEY in the cache.
When not found, or when found to be stale, calls FETCHER to compute the
result. When EXPIRE is non-nil, the value will be deleted at the end of
completion. CHECK-TAG, when present, is saved as well, and the entry will
be recomputed when this value changes."
;; We could make EXPIRE accept a time value as well.
(let ((res (gethash key company--cache 'none))
value)
(if (and (not (eq res 'none))
(or (not check-tag)
(equal check-tag (assoc-default :check-tag res))))
(assoc-default :value res)
(setq res (list (cons :value (setq value (funcall fetcher)))))
(if expire (push '(:expire . t) res))
(if check-tag (push `(:check-tag . ,check-tag) res))
(puthash key res company--cache)
value)))
(defun company-cache-delete (key)
"Delete KEY from cache."
(remhash key company--cache))
(defun company-cache-expire ()
"Delete all keys from the cache that are set to be expired."
(maphash (lambda (k v)
(when (assoc-default :expire v)
(remhash k company--cache)))
company--cache))
(defun company-call-backend (&rest args) (defun company-call-backend (&rest args)
(company--force-sync #'company-call-backend-raw args company-backend)) (company--force-sync #'company-call-backend-raw args company-backend))
@@ -1151,6 +1231,9 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(error (error "Company: backend %s error \"%s\" with args %s" (error (error "Company: backend %s error \"%s\" with args %s"
company-backend (error-message-string err) args)))) company-backend (error-message-string err) args))))
(defvar-local company--multi-uncached-backends nil)
(defvar-local company--multi-min-prefix nil)
(defun company--multi-backend-adapter (backends command &rest args) (defun company--multi-backend-adapter (backends command &rest args)
(let ((backends (cl-loop for b in backends (let ((backends (cl-loop for b in backends
when (or (keywordp b) when (or (keywordp b)
@@ -1165,9 +1248,30 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(pcase command (pcase command
(`candidates (`candidates
(company--multi-backend-adapter-candidates backends (car args) separate)) (company--multi-backend-adapter-candidates backends
(car args)
(or company--multi-min-prefix 0)
separate))
(`set-min-prefix (setq company--multi-min-prefix (car args)))
(`sorted separate) (`sorted separate)
(`duplicates (not separate)) (`duplicates (not separate))
((and `no-cache
(pred (lambda (_)
(let* (found
(uncached company--multi-uncached-backends))
(dolist (backend backends)
(when
(and (member backend uncached)
(company--good-prefix-p
(let ((company-backend backend))
(company-call-backend 'prefix))
(or company--multi-min-prefix 0)))
(setq found t
company--multi-uncached-backends
(delete backend
company--multi-uncached-backends))))
found))))
t)
((or `prefix `ignore-case `no-cache `require-match) ((or `prefix `ignore-case `no-cache `require-match)
(let (value) (let (value)
(cl-dolist (backend backends) (cl-dolist (backend backends)
@@ -1184,12 +1288,18 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(car backends)))) (car backends))))
(apply backend command args)))))))) (apply backend command args))))))))
(defun company--multi-backend-adapter-candidates (backends prefix separate) (defun company--multi-backend-adapter-candidates (backends prefix min-length separate)
(let ((pairs (cl-loop for backend in backends (let ((pairs (cl-loop for backend in backends
when (equal (company--prefix-str when (let ((bp (let ((company-backend backend))
(let ((company-backend backend)) (company-call-backend 'prefix))))
(company-call-backend 'prefix))) (and
prefix) ;; It's important that the lengths match.
(equal (company--prefix-str bp) prefix)
;; One might override min-length, another not.
(if (company--good-prefix-p bp min-length)
t
(push backend company--multi-uncached-backends)
nil)))
collect (cons (funcall backend 'candidates prefix) collect (cons (funcall backend 'candidates prefix)
(company--multi-candidates-mapper (company--multi-candidates-mapper
backend backend
@@ -1346,9 +1456,6 @@ To toggle the value of this variable, call `company-show-doc-buffer' with a
prefix argument.") prefix argument.")
(defun company-call-frontends (command) (defun company-call-frontends (command)
(when (and company-auto-update-doc
(memq command '(update show)))
(company-show-doc-buffer))
(cl-loop for frontend in company-frontends collect (cl-loop for frontend in company-frontends collect
(condition-case-unless-debug err (condition-case-unless-debug err
(funcall frontend command) (funcall frontend command)
@@ -1448,7 +1555,9 @@ update if FORCE-UPDATE."
(and candidates (and candidates
(not (cdr candidates)) (not (cdr candidates))
(eq t (compare-strings (car candidates) nil nil (eq t (compare-strings (car candidates) nil nil
prefix nil nil ignore-case)))) prefix nil nil ignore-case))
(not (eq (company-call-backend 'kind (car candidates))
'snippet))))
(defun company--fetch-candidates (prefix) (defun company--fetch-candidates (prefix)
(let* ((non-essential (not (company-explicit-action-p))) (let* ((non-essential (not (company-explicit-action-p)))
@@ -1620,7 +1729,7 @@ end of the match."
(let ((base-size (cdr company-icon-size)) (let ((base-size (cdr company-icon-size))
(dfh (default-font-height))) (dfh (default-font-height)))
(min (min
(if (> dfh (* 2 base-size)) (if (>= dfh (* 2 base-size))
(* 2 base-size) (* 2 base-size)
base-size) base-size)
(* company-icon-margin dfw)))))) (* company-icon-margin dfw))))))
@@ -1633,10 +1742,21 @@ end of the match."
:background (unless (eq bkg 'unspecified) :background (unless (eq bkg 'unspecified)
bkg))) bkg)))
(spacer-px-width (- (* company-icon-margin dfw) icon-size))) (spacer-px-width (- (* company-icon-margin dfw) icon-size)))
(cond
((<= company-icon-margin 2)
(concat (concat
(propertize " " 'display spec) (propertize " " 'display spec)
(propertize (company-space-string (1- company-icon-margin)) (propertize (company-space-string (1- company-icon-margin))
'display `(space . (:width (,spacer-px-width)))))) 'display `(space . (:width (,spacer-px-width))))))
(t
(let* ((spacer-left (/ spacer-px-width 2))
(spacer-right (- spacer-px-width spacer-left)))
(concat
(propertize (company-space-string 1)
'display `(space . (:width (,spacer-left))))
(propertize " " 'display spec)
(propertize (company-space-string (- company-icon-margin 2))
'display `(space . (:width (,spacer-right)))))))))
nil)) nil))
(defun company-vscode-dark-icons-margin (candidate selected) (defun company-vscode-dark-icons-margin (candidate selected)
@@ -1943,6 +2063,10 @@ prefix match (same case) will be prioritized."
;;;###autoload ;;;###autoload
(defun company-manual-begin () (defun company-manual-begin ()
"Start the completion interface.
Unlike `company-complete-selection' or `company-complete', this command
doesn't cause any immediate changes to the buffer text."
(interactive) (interactive)
(company-assert-enabled) (company-assert-enabled)
(setq company--manual-action t) (setq company--manual-action t)
@@ -2021,16 +2145,20 @@ For more details see `company-insertion-on-trigger' and
company-candidates) company-candidates)
(t (company-cancel)))) (t (company-cancel))))
(defun company--good-prefix-p (prefix) (defun company--good-prefix-p (prefix min-length)
(and (stringp (company--prefix-str prefix)) ;excludes 'stop (and (stringp (company--prefix-str prefix)) ;excludes 'stop
(or (eq (cdr-safe prefix) t) (or (eq (cdr-safe prefix) t)
(let ((len (or (cdr-safe prefix) (length prefix)))) (>= (or (cdr-safe prefix) (length prefix))
min-length))))
(defun company--prefix-min-length ()
(if company--manual-prefix (if company--manual-prefix
(or (not company-abort-manual-when-too-short) (if company-abort-manual-when-too-short
;; Must not be less than minimum or initial length. ;; Must not be less than minimum or initial length.
(>= len (min company-minimum-prefix-length (min company-minimum-prefix-length
(length company--manual-prefix)))) (length company--manual-prefix))
(>= len company-minimum-prefix-length)))))) 0)
company-minimum-prefix-length))
(defun company--continue () (defun company--continue ()
(when (company-call-backend 'no-cache company-prefix) (when (company-call-backend 'no-cache company-prefix)
@@ -2038,7 +2166,8 @@ For more details see `company-insertion-on-trigger' and
(setq company-candidates-cache nil)) (setq company-candidates-cache nil))
(let* ((new-prefix (company-call-backend 'prefix)) (let* ((new-prefix (company-call-backend 'prefix))
(ignore-case (company-call-backend 'ignore-case)) (ignore-case (company-call-backend 'ignore-case))
(c (when (and (company--good-prefix-p new-prefix) (c (when (and (company--good-prefix-p new-prefix
(company--prefix-min-length))
(setq new-prefix (company--prefix-str new-prefix)) (setq new-prefix (company--prefix-str new-prefix))
(= (- (point) (length new-prefix)) (= (- (point) (length new-prefix))
(- company-point (length company-prefix)))) (- company-point (length company-prefix))))
@@ -2067,7 +2196,8 @@ For more details see `company-insertion-on-trigger' and
(t (company--continue-failed new-prefix))))) (t (company--continue-failed new-prefix)))))
(defun company--begin-new () (defun company--begin-new ()
(let (prefix c) (let ((min-prefix (company--prefix-min-length))
prefix c)
(cl-dolist (backend (if company-backend (cl-dolist (backend (if company-backend
;; prefer manual override ;; prefer manual override
(list company-backend) (list company-backend)
@@ -2080,8 +2210,10 @@ For more details see `company-insertion-on-trigger' and
(company-call-backend 'prefix))) (company-call-backend 'prefix)))
(company--multi-backend-adapter backend 'prefix))) (company--multi-backend-adapter backend 'prefix)))
(when prefix (when prefix
(when (company--good-prefix-p prefix) (when (company--good-prefix-p prefix min-prefix)
(let ((ignore-case (company-call-backend 'ignore-case))) (let ((ignore-case (company-call-backend 'ignore-case)))
;; Keep this undocumented, esp. while only 1 backend needs it.
(company-call-backend 'set-min-prefix min-prefix)
(setq company-prefix (company--prefix-str prefix) (setq company-prefix (company--prefix-str prefix)
company-backend backend company-backend backend
c (company-calculate-candidates company-prefix ignore-case)) c (company-calculate-candidates company-prefix ignore-case))
@@ -2136,7 +2268,10 @@ For more details see `company-insertion-on-trigger' and
company--manual-action nil company--manual-action nil
company--manual-prefix nil company--manual-prefix nil
company--point-max nil company--point-max nil
company--multi-uncached-backends nil
company--multi-min-prefix nil
company-point nil) company-point nil)
(company-cache-expire)
(when company-timer (when company-timer
(cancel-timer company-timer)) (cancel-timer company-timer))
(company-echo-cancel t) (company-echo-cancel t)
@@ -2200,7 +2335,14 @@ For more details see `company-insertion-on-trigger' and
(let (company-idle-delay) ; Against misbehavior while debugging. (let (company-idle-delay) ; Against misbehavior while debugging.
(company--perform))) (company--perform)))
(if company-candidates (if company-candidates
(progn
(company-call-frontends 'post-command) (company-call-frontends 'post-command)
(when company-auto-update-doc
(condition-case nil
(unless (company--electric-command-p)
(company-show-doc-buffer))
(user-error nil)
(quit nil))))
(let ((delay (company--idle-delay))) (let ((delay (company--idle-delay)))
(and (numberp delay) (and (numberp delay)
(not defining-kbd-macro) (not defining-kbd-macro)
@@ -2688,12 +2830,13 @@ inserted."
(call-interactively 'company-complete-selection) (call-interactively 'company-complete-selection)
(call-interactively 'company-complete-common) (call-interactively 'company-complete-common)
(when company-candidates (when company-candidates
(setq this-command 'company-complete-common))))) (setq this-command 'company-complete-common)))
this-command))
(define-obsolete-function-alias (define-obsolete-function-alias
'company-complete-number 'company-complete-number
'company-complete-tooltip-row 'company-complete-tooltip-row
"0.9.14") "0.10.0")
(defun company-complete-tooltip-row (number) (defun company-complete-tooltip-row (number)
"Insert a candidate visible on the tooltip's row NUMBER. "Insert a candidate visible on the tooltip's row NUMBER.
@@ -2803,16 +2946,19 @@ from the candidates list.")
'(scroll-other-window scroll-other-window-down mwheel-scroll) '(scroll-other-window scroll-other-window-down mwheel-scroll)
"List of Commands that won't break out of electric commands.") "List of Commands that won't break out of electric commands.")
(defun company--electric-command-p ()
(memq this-command company--electric-commands))
(defun company--electric-restore-window-configuration () (defun company--electric-restore-window-configuration ()
"Restore window configuration (after electric commands)." "Restore window configuration (after electric commands)."
(when (and company--electric-saved-window-configuration (when (and company--electric-saved-window-configuration
(not (memq this-command company--electric-commands))) (not (company--electric-command-p)))
(set-window-configuration company--electric-saved-window-configuration) (set-window-configuration company--electric-saved-window-configuration)
(setq company--electric-saved-window-configuration nil))) (setq company--electric-saved-window-configuration nil)))
(defmacro company--electric-do (&rest body) (defmacro company--electric-do (&rest body)
(declare (indent 0) (debug t)) (declare (indent 0) (debug t))
`(when (company-manual-begin) `(when company-candidates
(cl-assert (null company--electric-saved-window-configuration)) (cl-assert (null company--electric-saved-window-configuration))
(setq company--electric-saved-window-configuration (current-window-configuration)) (setq company--electric-saved-window-configuration (current-window-configuration))
(let ((height (window-height)) (let ((height (window-height))
@@ -2835,11 +2981,7 @@ from the candidates list.")
(selection (or company-selection 0))) (selection (or company-selection 0)))
(let* ((selected (nth selection company-candidates)) (let* ((selected (nth selection company-candidates))
(doc-buffer (or (company-call-backend 'doc-buffer selected) (doc-buffer (or (company-call-backend 'doc-buffer selected)
(if company-auto-update-doc (user-error "No documentation available")))
(company-doc-buffer
(format "%s: No documentation available"
selected))
(user-error "No documentation available"))))
start) start)
(when (consp doc-buffer) (when (consp doc-buffer)
(setq start (cdr doc-buffer) (setq start (cdr doc-buffer)
@@ -2856,10 +2998,8 @@ automatically show the documentation buffer for each selection."
(interactive "P") (interactive "P")
(when toggle-auto-update (when toggle-auto-update
(setq company-auto-update-doc (not company-auto-update-doc))) (setq company-auto-update-doc (not company-auto-update-doc)))
(if company-auto-update-doc
(company--show-doc-buffer)
(company--electric-do (company--electric-do
(company--show-doc-buffer)))) (company--show-doc-buffer)))
(put 'company-show-doc-buffer 'company-keep t) (put 'company-show-doc-buffer 'company-keep t)
(defun company-show-location () (defun company-show-location ()
@@ -3072,21 +3212,23 @@ If SHOW-VERSION is non-nil, show the version in the echo area."
(_ (setq value (company-reformat (company--pre-render value)) (_ (setq value (company-reformat (company--pre-render value))
annotation (and annotation (company--pre-render annotation t)))) annotation (and annotation (company--pre-render annotation t))))
(ann-ralign company-tooltip-align-annotations) (ann-ralign company-tooltip-align-annotations)
(ann-padding (or company-tooltip-annotation-padding 0))
(ann-truncate (< width (ann-truncate (< width
(+ (length value) (length annotation) (+ (length value) (length annotation)
(if ann-ralign 1 0)))) ann-padding)))
(ann-start (+ margin (ann-start (+ margin
(if ann-ralign (if ann-ralign
(if ann-truncate (if ann-truncate
(1+ (length value)) (+ (length value) ann-padding)
(- width (length annotation))) (- width (length annotation)))
(length value)))) (+ (length value) ann-padding))))
(ann-end (min (+ ann-start (length annotation)) (+ margin width))) (ann-end (min (+ ann-start (length annotation)) (+ margin width)))
(line (concat left (line (concat left
(if (or ann-truncate (not ann-ralign)) (if (or ann-truncate (not ann-ralign))
(company-safe-substring (company-safe-substring
(concat value (concat value
(when (and annotation ann-ralign) " ") (when annotation
(company-space-string ann-padding))
annotation) annotation)
0 width) 0 width)
(concat (concat
@@ -3225,7 +3367,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area."
'company--show-numbers 'company--show-numbers
"use `company-quick-access-hint-key' instead, "use `company-quick-access-hint-key' instead,
but adjust the expected values appropriately." but adjust the expected values appropriately."
"0.9.14") "0.10.0")
(defsubst company--window-height () (defsubst company--window-height ()
(if (fboundp 'window-screen-lines) (if (fboundp 'window-screen-lines)
@@ -3314,6 +3456,9 @@ but adjust the expected values appropriately."
(defun company--create-lines (selection limit) (defun company--create-lines (selection limit)
(let ((len company-candidates-length) (let ((len company-candidates-length)
(window-width (company--window-width)) (window-width (company--window-width))
(company-tooltip-annotation-padding
(or company-tooltip-annotation-padding
(if company-tooltip-align-annotations 1 0)))
left-margins left-margins
left-margin-size left-margin-size
lines lines
@@ -3386,8 +3531,9 @@ but adjust the expected values appropriately."
(setq annotation (string-trim-left annotation)))) (setq annotation (string-trim-left annotation))))
(push (list value annotation left) items) (push (list value annotation left) items)
(setq width (max (+ (length value) (setq width (max (+ (length value)
(if (and annotation company-tooltip-align-annotations) (if annotation
(1+ (length annotation)) (+ (length annotation)
company-tooltip-annotation-padding)
(length annotation))) (length annotation)))
width)))) width))))
@@ -3610,7 +3756,7 @@ Returns a negative number if the tooltip should be displayed above point."
(pre-command (company-pseudo-tooltip-hide-temporarily)) (pre-command (company-pseudo-tooltip-hide-temporarily))
(unhide (unhide
(let ((ov company-pseudo-tooltip-overlay)) (let ((ov company-pseudo-tooltip-overlay))
(when (> (overlay-get ov 'company-height) 0) (when (and ov (> (overlay-get ov 'company-height) 0))
;; Sleight of hand: if the current line wraps, we adjust the ;; Sleight of hand: if the current line wraps, we adjust the
;; start of the overlay so that the popup does not zig-zag, ;; start of the overlay so that the popup does not zig-zag,
;; but don't update the popup's background. This seems just ;; but don't update the popup's background. This seems just
@@ -3730,6 +3876,10 @@ Delay is determined by `company-tooltip-idle-delay'."
(company-strip-prefix completion) (company-strip-prefix completion)
completion)) completion))
(when (string-prefix-p "\n" completion)
(setq completion (concat (propertize " " 'face 'company-preview) "\n"
(substring completion 1))))
(and (equal pos (point)) (and (equal pos (point))
(not (equal completion "")) (not (equal completion ""))
(add-text-properties 0 1 '(cursor 1) completion)) (add-text-properties 0 1 '(cursor 1) completion))
@@ -3829,13 +3979,18 @@ Delay is determined by `company-tooltip-idle-delay'."
:package-version '(company . "0.9.3")) :package-version '(company . "0.9.3"))
(defun company-echo-show (&optional getter) (defun company-echo-show (&optional getter)
(let ((last-msg company-echo-last-msg)
(message-log-max nil)
(message-truncate-lines company-echo-truncate-lines))
(when getter (when getter
(setq company-echo-last-msg (funcall getter))) (setq company-echo-last-msg (funcall getter)))
(let ((message-log-max nil) ;; Avoid modifying the echo area if we don't have anything to say, and we
(message-truncate-lines company-echo-truncate-lines)) ;; didn't put the previous message there (thus there's nothing to clear),
(if company-echo-last-msg ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=62816#20
(if (not (member company-echo-last-msg '(nil "")))
(message "%s" company-echo-last-msg) (message "%s" company-echo-last-msg)
(message "")))) (unless (member last-msg '(nil ""))
(message "")))))
(defun company-echo-show-soon (&optional getter delay) (defun company-echo-show-soon (&optional getter delay)
(company-echo-cancel) (company-echo-cancel)

171
lisp/company/company.info
View File

@@ -1,9 +1,9 @@
This is company.info, produced by makeinfo version 7.0.1 from This is company.info, produced by makeinfo version 6.8 from
company.texi. company.texi.
This user manual is for Company version 0.9.14snapshot (12 August 2022). This user manual is for Company version 0.10.0 (16 April 2023).
Copyright © 2021-2022 Free Software Foundation, Inc. Copyright © 2021-2023 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License, document under the terms of the GNU Free Documentation License,
@@ -26,9 +26,9 @@ The goal of this document is to lay out the foundational knowledge of
the package, so that the readers of the manual could competently start the package, so that the readers of the manual could competently start
adapting Company to their needs and preferences. adapting Company to their needs and preferences.
This user manual is for Company version 0.9.14snapshot (12 August 2022). This user manual is for Company version 0.10.0 (16 April 2023).
Copyright © 2021-2022 Free Software Foundation, Inc. Copyright © 2021-2023 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License, document under the terms of the GNU Free Documentation License,
@@ -206,8 +206,8 @@ shown according to the typed characters and the default (until a user
specifies otherwise) configurations. specifies otherwise) configurations.
To have Company always enabled for the following sessions, add the line To have Company always enabled for the following sessions, add the line
‘(global-company-mode)’ to the Emacs configuration file ‘(global-company-mode)’ to the Emacs configuration file (*note
(*note (emacs)Init File::). (emacs)Init File::).
 
File: company.info, Node: Usage Basics, Next: Commands, Prev: Initial Setup, Up: Getting Started File: company.info, Node: Usage Basics, Next: Commands, Prev: Initial Setup, Up: Getting Started
@@ -318,9 +318,9 @@ File: company.info, Node: Customization, Next: Frontends, Prev: Getting Start
Emacs provides two equally acceptable ways for user preferences Emacs provides two equally acceptable ways for user preferences
configuration: via customization interface (for more details, *note configuration: via customization interface (for more details, *note
(emacs)Easy Customization::) and a configuration file (emacs)Easy Customization::) and a configuration file (*note (emacs)Init
(*note (emacs)Init File::). Naturally, Company can be configured by File::). Naturally, Company can be configured by both of these
both of these approaches. approaches.
* Menu: * Menu:
@@ -531,6 +531,14 @@ user options.
[image src="./images/small/tooltip-annotations.png"] [image src="./images/small/tooltip-annotations.png"]
-- User Option: company-tooltip-annotation-padding
Adds left padding to the candidates’ annotations. It is disabled
by default. If ‘company-tooltip-align-annotations’ is enabled,
‘company-tooltip-annotation-padding’ defines the minimum spacing
between a candidate and annotation, with the default value of 1.
(setq company-tooltip-annotation-padding 1)
-- User Option: company-tooltip-limit -- User Option: company-tooltip-limit
Controls the maximum number of the candidates shown simultaneously Controls the maximum number of the candidates shown simultaneously
in the tooltip (the default value is ‘10’). When the number of the in the tooltip (the default value is ‘10’). When the number of the
@@ -1363,17 +1371,17 @@ Variable Index
* company-dabbrev-ignore-case: Text Completion. (line 47) * company-dabbrev-ignore-case: Text Completion. (line 47)
* company-dabbrev-minimum-length: Text Completion. (line 13) * company-dabbrev-minimum-length: Text Completion. (line 13)
* company-dabbrev-other-buffers: Text Completion. (line 23) * company-dabbrev-other-buffers: Text Completion. (line 23)
* company-dot-icons-format: Tooltip Frontends. (line 176) * company-dot-icons-format: Tooltip Frontends. (line 184)
* company-echo-truncate-lines: Echo Frontends. (line 33) * company-echo-truncate-lines: Echo Frontends. (line 33)
* company-files-chop-trailing-slash: File Name Completion. * company-files-chop-trailing-slash: File Name Completion.
(line 19) (line 19)
* company-files-exclusions: File Name Completion. * company-files-exclusions: File Name Completion.
(line 12) (line 12)
* company-format-margin-function: Tooltip Frontends. (line 151) * company-format-margin-function: Tooltip Frontends. (line 159)
* company-frontends: Frontends. (line 6) * company-frontends: Frontends. (line 6)
* company-global-modes: Configuration File. (line 31) * company-global-modes: Configuration File. (line 31)
* company-icon-margin: Tooltip Frontends. (line 162) * company-icon-margin: Tooltip Frontends. (line 170)
* company-icon-size: Tooltip Frontends. (line 162) * company-icon-size: Tooltip Frontends. (line 170)
* company-idle-delay: Configuration File. (line 17) * company-idle-delay: Configuration File. (line 17)
* company-insertion-on-trigger: Configuration File. (line 64) * company-insertion-on-trigger: Configuration File. (line 64)
* company-insertion-triggers: Configuration File. (line 72) * company-insertion-triggers: Configuration File. (line 72)
@@ -1388,20 +1396,21 @@ Variable Index
* company-selection-wrap-around: Configuration File. (line 43) * company-selection-wrap-around: Configuration File. (line 43)
* company-show-quick-access: Quick Access a Candidate. * company-show-quick-access: Quick Access a Candidate.
(line 12) (line 12)
* company-text-face-extra-attributes: Tooltip Frontends. (line 189) * company-text-face-extra-attributes: Tooltip Frontends. (line 197)
* company-text-icons-add-background: Tooltip Frontends. (line 197) * company-text-icons-add-background: Tooltip Frontends. (line 205)
* company-text-icons-format: Tooltip Frontends. (line 169) * company-text-icons-format: Tooltip Frontends. (line 177)
* company-text-icons-mapping: Tooltip Frontends. (line 185) * company-text-icons-mapping: Tooltip Frontends. (line 193)
* company-tooltip-align-annotations: Tooltip Frontends. (line 51) * company-tooltip-align-annotations: Tooltip Frontends. (line 51)
* company-tooltip-flip-when-above: Tooltip Frontends. (line 98) * company-tooltip-annotation-padding: Tooltip Frontends. (line 63)
* company-tooltip-flip-when-above: Tooltip Frontends. (line 106)
* company-tooltip-idle-delay: Tooltip Frontends. (line 21) * company-tooltip-idle-delay: Tooltip Frontends. (line 21)
* company-tooltip-limit: Tooltip Frontends. (line 63) * company-tooltip-limit: Tooltip Frontends. (line 71)
* company-tooltip-margin: Tooltip Frontends. (line 132) * company-tooltip-margin: Tooltip Frontends. (line 140)
* company-tooltip-maximum-width: Tooltip Frontends. (line 125) * company-tooltip-maximum-width: Tooltip Frontends. (line 133)
* company-tooltip-minimum: Tooltip Frontends. (line 83) * company-tooltip-minimum: Tooltip Frontends. (line 91)
* company-tooltip-minimum-width: Tooltip Frontends. (line 110) * company-tooltip-minimum-width: Tooltip Frontends. (line 118)
* company-tooltip-offset-display: Tooltip Frontends. (line 73) * company-tooltip-offset-display: Tooltip Frontends. (line 81)
* company-tooltip-width-grow-only: Tooltip Frontends. (line 120) * company-tooltip-width-grow-only: Tooltip Frontends. (line 128)
* company-transformers: Candidates Post-Processing. * company-transformers: Candidates Post-Processing.
(line 6) (line 6)
@@ -1425,11 +1434,11 @@ Function Index
* company-complete-selection: Commands. (line 21) * company-complete-selection: Commands. (line 21)
* company-dabbrev: Text Completion. (line 6) * company-dabbrev: Text Completion. (line 6)
* company-dabbrev-code: Code Completion. (line 25) * company-dabbrev-code: Code Completion. (line 25)
* company-detect-icons-margin: Tooltip Frontends. (line 206) * company-detect-icons-margin: Tooltip Frontends. (line 214)
* company-diag: Backends Usage Basics. * company-diag: Backends Usage Basics.
(line 11) (line 11)
* company-diag <1>: Troubleshooting. (line 6) * company-diag <1>: Troubleshooting. (line 6)
* company-dot-icons-margin: Tooltip Frontends. (line 175) * company-dot-icons-margin: Tooltip Frontends. (line 183)
* company-echo-frontend: Echo Frontends. (line 21) * company-echo-frontend: Echo Frontends. (line 21)
* company-echo-metadata-frontend: Echo Frontends. (line 9) * company-echo-metadata-frontend: Echo Frontends. (line 9)
* company-echo-strip-common-frontend: Echo Frontends. (line 27) * company-echo-strip-common-frontend: Echo Frontends. (line 27)
@@ -1467,11 +1476,11 @@ Function Index
* company-sort-prefer-same-case-prefix: Candidates Post-Processing. * company-sort-prefer-same-case-prefix: Candidates Post-Processing.
(line 33) (line 33)
* company-tempo: Template Expansion. (line 11) * company-tempo: Template Expansion. (line 11)
* company-text-icons-margin: Tooltip Frontends. (line 168) * company-text-icons-margin: Tooltip Frontends. (line 176)
* company-tng-frontend: Structure. (line 26) * company-tng-frontend: Structure. (line 26)
* company-tng-mode: Structure. (line 26) * company-tng-mode: Structure. (line 26)
* company-vscode-dark-icons-margin: Tooltip Frontends. (line 160) * company-vscode-dark-icons-margin: Tooltip Frontends. (line 168)
* company-vscode-light-icons-margin: Tooltip Frontends. (line 161) * company-vscode-light-icons-margin: Tooltip Frontends. (line 169)
* company-yasnippet: Template Expansion. (line 16) * company-yasnippet: Template Expansion. (line 16)
* global-company-mode: Initial Setup. (line 18) * global-company-mode: Initial Setup. (line 18)
@@ -1515,7 +1524,7 @@ Concept Index
* candidate <1>: Usage Basics. (line 12) * candidate <1>: Usage Basics. (line 12)
* candidate <2>: Usage Basics. (line 15) * candidate <2>: Usage Basics. (line 15)
* candidate <3>: Preview Frontends. (line 6) * candidate <3>: Preview Frontends. (line 6)
* color: Tooltip Frontends. (line 215) * color: Tooltip Frontends. (line 223)
* color <1>: Quick Access a Candidate. * color <1>: Quick Access a Candidate.
(line 34) (line 34)
* common part: Usage Basics. (line 17) * common part: Usage Basics. (line 17)
@@ -1524,7 +1533,7 @@ Concept Index
* company-echo: Echo Frontends. (line 6) * company-echo: Echo Frontends. (line 6)
* company-preview: Preview Frontends. (line 6) * company-preview: Preview Frontends. (line 6)
* company-tng: Structure. (line 26) * company-tng: Structure. (line 26)
* company-tooltip: Tooltip Frontends. (line 215) * company-tooltip: Tooltip Frontends. (line 223)
* company-tooltip-search: Candidates Search. (line 6) * company-tooltip-search: Candidates Search. (line 6)
* complete: Terminology. (line 6) * complete: Terminology. (line 6)
* complete <1>: Usage Basics. (line 12) * complete <1>: Usage Basics. (line 12)
@@ -1541,7 +1550,7 @@ Concept Index
(line 6) (line 6)
* configure <2>: Configuration File. (line 6) * configure <2>: Configuration File. (line 6)
* configure <3>: Tooltip Frontends. (line 48) * configure <3>: Tooltip Frontends. (line 48)
* configure <4>: Tooltip Frontends. (line 215) * configure <4>: Tooltip Frontends. (line 223)
* configure <5>: Preview Frontends. (line 25) * configure <5>: Preview Frontends. (line 25)
* configure <6>: Echo Frontends. (line 38) * configure <6>: Echo Frontends. (line 38)
* configure <7>: Candidates Search. (line 30) * configure <7>: Candidates Search. (line 30)
@@ -1554,7 +1563,7 @@ Concept Index
(line 6) (line 6)
* custom <2>: Configuration File. (line 6) * custom <2>: Configuration File. (line 6)
* custom <3>: Tooltip Frontends. (line 48) * custom <3>: Tooltip Frontends. (line 48)
* custom <4>: Tooltip Frontends. (line 215) * custom <4>: Tooltip Frontends. (line 223)
* custom <5>: Preview Frontends. (line 25) * custom <5>: Preview Frontends. (line 25)
* custom <6>: Echo Frontends. (line 38) * custom <6>: Echo Frontends. (line 38)
* custom <7>: Candidates Search. (line 30) * custom <7>: Candidates Search. (line 30)
@@ -1573,7 +1582,7 @@ Concept Index
* error <1>: Troubleshooting. (line 25) * error <1>: Troubleshooting. (line 25)
* expansion: Template Expansion. (line 6) * expansion: Template Expansion. (line 6)
* extensible: Structure. (line 6) * extensible: Structure. (line 6)
* face: Tooltip Frontends. (line 215) * face: Tooltip Frontends. (line 223)
* face <1>: Preview Frontends. (line 6) * face <1>: Preview Frontends. (line 6)
* face <2>: Preview Frontends. (line 25) * face <2>: Preview Frontends. (line 25)
* face <3>: Echo Frontends. (line 6) * face <3>: Echo Frontends. (line 6)
@@ -1586,17 +1595,17 @@ Concept Index
* filter: Filter Candidates. (line 6) * filter: Filter Candidates. (line 6)
* finish: Usage Basics. (line 20) * finish: Usage Basics. (line 20)
* finish <1>: Commands. (line 30) * finish <1>: Commands. (line 30)
* font: Tooltip Frontends. (line 215) * font: Tooltip Frontends. (line 223)
* font <1>: Quick Access a Candidate. * font <1>: Quick Access a Candidate.
(line 34) (line 34)
* frontend: Structure. (line 6) * frontend: Structure. (line 6)
* frontend <1>: Structure. (line 10) * frontend <1>: Structure. (line 10)
* frontends: Frontends. (line 6) * frontends: Frontends. (line 6)
* grouped backends: Grouped Backends. (line 6) * grouped backends: Grouped Backends. (line 6)
* icon: Tooltip Frontends. (line 144) * icon: Tooltip Frontends. (line 152)
* install: Installation. (line 6) * install: Installation. (line 6)
* interface: Tooltip Frontends. (line 48) * interface: Tooltip Frontends. (line 48)
* interface <1>: Tooltip Frontends. (line 215) * interface <1>: Tooltip Frontends. (line 223)
* interface <2>: Preview Frontends. (line 25) * interface <2>: Preview Frontends. (line 25)
* interface <3>: Echo Frontends. (line 38) * interface <3>: Echo Frontends. (line 38)
* interface <4>: Candidates Search. (line 30) * interface <4>: Candidates Search. (line 30)
@@ -1605,12 +1614,12 @@ Concept Index
* intro: Initial Setup. (line 6) * intro: Initial Setup. (line 6)
* issue: Troubleshooting. (line 6) * issue: Troubleshooting. (line 6)
* issue tracker: Troubleshooting. (line 25) * issue tracker: Troubleshooting. (line 25)
* kind: Tooltip Frontends. (line 144) * kind: Tooltip Frontends. (line 152)
* location: Commands. (line 41) * location: Commands. (line 41)
* manual: Initial Setup. (line 8) * manual: Initial Setup. (line 8)
* manual <1>: Usage Basics. (line 10) * manual <1>: Usage Basics. (line 10)
* margin: Tooltip Frontends. (line 133) * margin: Tooltip Frontends. (line 141)
* margin <1>: Tooltip Frontends. (line 152) * margin <1>: Tooltip Frontends. (line 160)
* minor-mode: Initial Setup. (line 6) * minor-mode: Initial Setup. (line 6)
* module: Structure. (line 6) * module: Structure. (line 6)
* module <1>: Structure. (line 10) * module <1>: Structure. (line 10)
@@ -1650,45 +1659,45 @@ Concept Index
 
Tag Table: Tag Table:
Node: Top574 Node: Top563
Node: Overview2002 Node: Overview1982
Node: Terminology2410 Node: Terminology2390
Ref: Terminology-Footnote-13397 Ref: Terminology-Footnote-13377
Node: Structure3603 Node: Structure3583
Node: Getting Started5099 Node: Getting Started5079
Node: Installation5377 Node: Installation5357
Node: Initial Setup5760 Node: Initial Setup5740
Node: Usage Basics6606 Node: Usage Basics6586
Node: Commands7369 Node: Commands7349
Ref: Commands-Footnote-19804 Ref: Commands-Footnote-19784
Node: Customization9971 Node: Customization9951
Node: Customization Interface10443 Node: Customization Interface10423
Node: Configuration File10976 Node: Configuration File10956
Node: Frontends15642 Node: Frontends15622
Node: Tooltip Frontends16611 Node: Tooltip Frontends16591
Ref: Tooltip Frontends-Footnote-126980 Ref: Tooltip Frontends-Footnote-127358
Node: Preview Frontends27217 Node: Preview Frontends27595
Ref: Preview Frontends-Footnote-128473 Ref: Preview Frontends-Footnote-128851
Node: Echo Frontends28600 Node: Echo Frontends28978
Node: Candidates Search30133 Node: Candidates Search30511
Node: Filter Candidates31467 Node: Filter Candidates31845
Node: Quick Access a Candidate32247 Node: Quick Access a Candidate32625
Node: Backends33865 Node: Backends34243
Node: Backends Usage Basics34963 Node: Backends Usage Basics35341
Ref: Backends Usage Basics-Footnote-136178 Ref: Backends Usage Basics-Footnote-136556
Node: Grouped Backends36262 Node: Grouped Backends36640
Node: Package Backends37891 Node: Package Backends38269
Node: Code Completion38820 Node: Code Completion39198
Node: Text Completion41189 Node: Text Completion41567
Node: File Name Completion45623 Node: File Name Completion46001
Node: Template Expansion47171 Node: Template Expansion47549
Node: Candidates Post-Processing47890 Node: Candidates Post-Processing48268
Node: Troubleshooting49367 Node: Troubleshooting49745
Node: Index51040 Node: Index51418
Node: Key Index51203 Node: Key Index51581
Node: Variable Index52702 Node: Variable Index53080
Node: Function Index56752 Node: Function Index57203
Node: Concept Index61233 Node: Concept Index61684
 
End Tag Table End Tag Table

7
lisp/compat/.dir-locals.el
View File

@@ -1,7 +0,0 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
((emacs-lisp-mode
(byte-compile-docstring-max-column . 100)
(show-trailing-whitespace . t)
(indent-tabs-mode . nil)))

215
lisp/compat/NEWS.org
View File

@@ -1,9 +1,205 @@
#+options: toc:nil num:nil #+link: compat-srht https://todo.sr.ht/~pkal/compat/
#+link: compat https://todo.sr.ht/~pkal/compat/ #+link: compat-gh https://github.com/emacs-compat/compat/issues/
#+options: toc:nil num:nil author:nil
* Release of "Compat" Version 29.1.4.2
- compat-28: Improve =make-separator-line= visuals on graphic displays.
- compat-28: Add =native-comp-available-p=, which always returns nil.
- compat-29: Add variable =lisp-directory=.
(Release <2023-07-30 Sun>)
* Release of "Compat" Version 29.1.4.1
- compat-29: Add ~directory-abbrev-apply~.
- compat-29: Add ~directory-abbrev-make-regexp~.
(Release <2023-03-26 Sun>)
* Release of "Compat" Version 29.1.4.0
- compat-27: Drop obsolete ~compat-call dired-get-marked-files~.
- compat-28: Add support for ~defcustom~ type ~natnum~.
- compat-29: Add ~with-restriction~ and ~without-restriction~.
- compat-29: Add ~cl-constantly~.
- compat-29: Drop ~with-narrowing~ which was renamed to ~with-restriction~.
- compat-28: Add support for ~defcustom~ type ~key~.
(Release <2023-03-05 Sun>)
* Release of "Compat" Version 29.1.3.4
- Ensure that ~seq~ is required properly both at compile time and runtime, such
that compilation of downstream packages works even if Compat itself is not
compiled. Magit uses a complex continuous integration system, where Magit is
compiled and tested, while the Compat dependency is not compiled.
- compat-28: Add ~process-lines-handling-status~ and ~process-lines-ignore-status~.
(Release <2023-02-11 Sat>)
* Release of "Compat" Version 29.1.3.3
- compat-27: Add ~with-suppressed-warnings~.
- compat-29: Add ~cl-with-gensyms~ and ~cl-once-only~.
- compat-29: Load ~seq~, which is preloaded on Emacs 29.
(Release <2023-02-08 Wed>)
* Release of "Compat" Version 29.1.3.2
- compat-26: Add ~make-temp-file~ with optional argument TEXT.
- compat-27: Mark ~compat-call dired-get-marked-files~ as obsolete. See the
section limitations in the Compat manual.
- compat-29: Add ~funcall-with-delayed-message~ and ~with-delayed-message~.
- compat-29: Add ~ert-with-temp-file~ and ~ert-with-temp-directory~.
- compat-29: Add ~set-transient-map~ with optional arguments MESSAGE and TIMEOUT.
(Release <2023-02-01 Wed>)
* Release of "Compat" Version 29.1.3.1
- Fix regression, which prevented loading Compat in interpreted mode. We ensure
that Compat works interpreted and byte compiled by running the entire test
suite twice in the CI. See https://github.com/magit/magit/issues/4858 for the
corresponding Magit issue.
- compat-27: Add ~file-name-unquote~.
- compat-28: Add ~mark-thing-at-mouse~.
- compat-29: Replace ~string-lines~ with version from Emacs 29, support optional
KEEP-NEWLINES argument.
(Release <2023-01-25 Wed>)
* Release of "Compat" Version 29.1.3.0
- compat-25: Add ~hash-table-empty-p~.
- compat-25: Add ~macroexp-parse-body~ and ~macroexp-quote~.
- compat-25: Add ~region-noncontiguous-p~.
- compat-25: Add ~save-mark-and-excursion~.
- compat-26: Add ~read-answer~.
- compat-26: Add ~region-bounds~.
- compat-27: Add ~date-ordinal-to-time~.
- compat-27: Add ~file-size-human-readable-iec~.
- compat-27: Add ~major-mode-suspend~ and ~major-mode-restore~.
- compat-27: Add ~make-decoded-time~.
- compat-27: Add ~minibuffer-history-value~.
- compat-27: Add ~read-char-from-minibuffer~.
- compat-27: Add ~ring-resize~.
- compat-28: Add ~color-dark-p~.
- compat-28: Add ~directory-files-and-attributes~ with COUNT argument.
- compat-28: Add ~text-quoting-style~.
- compat-28: Add ~with-window-non-dedicated~.
- compat-29: Add ~buffer-local-set-state~ and ~buffer-local-restore-state~.
- compat-29: Add ~compiled-function-p~.
- compat-29: Add ~count-sentences~.
- compat-29: Add ~delete-line~.
- compat-29: Add ~get-scratch-buffer-create~.
- compat-29: Add ~list-of-strings-p~.
- compat-29: Add ~plist-get~ generalized variable.
- compat-29: Add ~plistp~.
- compat-29: Add ~read-multiple-choice~ with LONG-FORM argument.
- compat-29: Add ~readablep~.
- compat-29: Add ~substitute-quotes~.
- compat-29: Add ~use-region-beginning~, ~use-region-end~ and ~use-region-noncontiguous-p~.
- compat-29: Add ~with-narrowing~.
(Release <2023-01-22 Sun>)
* Release of "Compat" Version 29.1.2.0
- All compatibility functions are covered by tests!
- Add links from compatibility definitions to tests.
- BREAKING: Drop JSON parsing support (libjansson API, unused downstream).
- BREAKING: Drop ~null-device~ (unused downstream).
- BREAKING: Drop ~unlock-buffer~ (unused downstream).
- compat-26: Add ~buffer-hash~.
- compat-27: Add ~fixnump~ and ~bignump~.
- compat-27: Add ~with-minibuffer-selected-window~.
- compat-27: Add generalized variables for ~decoded-time-*~.
- compat-28: Add ~macroexp-warn-and-return~.
- compat-28: Add ~subr-native-elisp-p~.
- compat-28: Add ~bounds-of-thing-at-mouse~.
- compat-29: Add ~with-buffer-unmodified-if-unchanged~.
- compat-29: Fix and test ~define-key~ with REMOVE argument.
(Release <2023-01-16 Mon>)
* Release of "Compat" Version 29.1.1.1
- Add tests, 167 out of 203 definitions tested (82%).
- compat-25: Improve algorithmic complexity of ~sort~.
- compat-28: Add ~make-separator-line~.
- compat-29: Minor fixes to ~keymap-*~ functions.
- compat-29: Add ~with-memoization~.
- compat-29: Add ~buttonize~ and ~buttonize-region~.
(Release <2023-01-14 Sat>)
* Release of "Compat" Version 29.1.1.0
- The macros in ~compat-macs.el~ have been rewritten and simplified. The
refactoring allows to further refine the criteria under which compatibility
aliases, functions, macros and variables are installed.
- Remove deprecated, prefixed compatibility functions.
- Remove deprecated features ~compat-help~, ~compat-font-lock~ and ~compat-24~.
- Compat uses runtime checks (~boundp~, ~fboundp~) to ensure that existing
definitions are never overridden, when Compat is loaded on a newer Emacs than
it was compiled on.
- Compat compiles without byte compilation warnings on all supported Emacs
versions. Warnings are treated as errors in the test suite.
- Compat takes great care to remove unneeded definitions at compile time. On
recent Emacs 29 the byte compiled files are empty and not loaded, such that
Compat does not any cost to the Emacs process.
- compat-26: Fix and test ~image-property~ setter.
- compat-26: Fix and test ~read-multiple-choice~.
- compat-28: Fix and test ~with-existing-directory~.
- compat-28: Drop obsolete function ~make-directory-autoloads~.
- compat-29: Drop broken functions ~string-pixel-width~ and
~buffer-text-pixel-size~. These functions had poor performance which lead to a
downstream issue in the doom-modeline package. If a more efficient solution is
possible, the function will be added back. See [[compat-gh:8]] for the bug report.
- compat-29: Drop broken function ~string-limit~.
- compat-29: Drop broken macro ~with-buffer-unmodified-if-unchanged~, which relied
on ~buffer-hash~ which does not exist on all supported Emacs versions.
- compat-29: Add ~pos-bol~ and ~pos-eol~.
(Release <2023-01-07 Sat>)
* Release of "Compat" Version 29.1.0.1
- Add multiple new tests for existing APIs.
- Fix bugs in compatibility functions: ~setq-local~, ~proper-list-p, prop-match-p~,
~file-name-concat~, ~replace-regexp-in-region~, ~replace-string-in-region~.
- Add new Emacs 29 APIs. Some of them are still untested and may change. If you
intend to use an Emacs 29 API please be careful and if possible contribute
test cases. All untested functions are marked in the Compat code. Over time
tests for all functions will be added gradually.
- Add the macros ~compat-call~ and ~compat-function~ to call compatibility
functions. Since Compat avoids overwriting already existing functions, we must
define separate compatibility function definitions for functions which changed
their calling convention or behavior. These compatibility definitions can be
looked up using ~compat-function~ and called with ~compat-call~. For example ~assoc~
can be called with a ~TESTFN~ since Emacs 26. In Emacs 25 and older the calling
convention was ~(assoc KEY ALIST)~. In order to use the new calling convention
you can use ~(compat-call assoc KEY ALIST TESTFN)~.
- Deprecate all ~compat-*~ prefixed functions. Instead use the aforementioned
~compat-call~ or ~compat-function~ macros.
- Deprecate ~compat-help.el~ and ~compat-font-lock.el.~
- Development moved to GitHub.
- BREAKING: Drop broken function ~func-arity~. Using ~func-arity~ is generally
discouraged and the function is hard to implement properly due to all the
various function types. There it is unlikely that the function will get
reintroduced in Compat.
- BREAKING: Drop broken function ~directory-files-recursively~. In case you need
this function, a patch including tests is welcome.
- BREAKING: Drop support for Emacs 24.3. Emacs 24.4 is required now. In case you
still need Emacs 24.3 support, you can rely on Compat 28.1.2.2.
(Release <2023-01-05 Thu>)
* Release of "Compat" Version 28.1.2.2 * Release of "Compat" Version 28.1.2.2
This is a minor release that hopes to address [[compat:7]]. This is a minor release that hopes to address [[compat-srht:7]].
(Release <2022-08-25 Thu>) (Release <2022-08-25 Thu>)
@@ -25,7 +221,7 @@ include much more documentation that had been the case previously.
The main change of this release has been the major simplification of The main change of this release has been the major simplification of
Compat's initialisation system, improving the situation around issues Compat's initialisation system, improving the situation around issues
people had been reporting ([[compat:4]], once again) with unconventional people had been reporting ([[compat-srht:4]], once again) with unconventional
or unpopular packaging systems. or unpopular packaging systems.
In addition to this, the following functional changes have been made: In addition to this, the following functional changes have been made:
@@ -42,7 +238,7 @@ Minor improvements to manual are also part of this release.
This release just contains a hot-fix for an issue introduced in the This release just contains a hot-fix for an issue introduced in the
last version, where compat.el raises an error during byte compilation. last version, where compat.el raises an error during byte compilation.
See [[compat:4]]. See [[compat-srht:4]].
(Release <2022-06-19 Sun>) (Release <2022-06-19 Sun>)
@@ -62,7 +258,7 @@ Two main changes have necessitated a new patch release:
This is a minor release fixing a bug in =json-serialize=, that could This is a minor release fixing a bug in =json-serialize=, that could
cause unintended side-effects, not related to packages using Compat cause unintended side-effects, not related to packages using Compat
directly (see [[compat:2]]). directly (see [[compat-srht:2]]).
(Released <2022-05-05 Thu>) (Released <2022-05-05 Thu>)
@@ -98,11 +294,4 @@ as some of these changes a functional. These include:
- Handling out-of-directory byte compilation better. - Handling out-of-directory byte compilation better.
- Fixing the usage and edge-cases of =and-let*=. - Fixing the usage and edge-cases of =and-let*=.
Furthermore a bug tracker was added: https://todo.sr.ht/~pkal/compat,
which is the preferred way to report issues or feature requests.
General problems, questions, etc. are still better discussed on the
development mailing list: https://lists.sr.ht/~pkal/compat-devel.
(Released <2022-04-22 Fri>) (Released <2022-04-22 Fri>)

495
lisp/compat/compat-24.el
View File

@@ -1,495 +0,0 @@
;;; compat-24.el --- Compatibility Layer for Emacs 24.4 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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:
;; Find here the functionality added in Emacs 24.4, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-='
;; - `compat-<'
;; - `compat->'
;; - `compat-<='
;; - `compat->='
;; - `split-string'.
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "24.4")
;;;; Defined in data.c
(compat-defun = (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun < (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (< number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun > (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (> number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun <= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (<= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun >= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (>= number-or-marker (pop numbers-or-markers))
(throw 'fail nil)))
t))
(compat-defun bool-vector-exclusive-or (a b &optional c)
"Return A ^ B, bitwise exclusive or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (not (eq (aref a i) (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-union (a b &optional c)
"Return A | B, bitwise or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (or (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-intersection (a b &optional c)
"Return A & B, bitwise and.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-set-difference (a b &optional c)
"Return A &~ B, set difference.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (not (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-not (a &optional b)
"Compute ~A, set complement.
If optional second argument B is given, store result into B.
A and B must be bool vectors of the same length.
Return the destination vector."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (or (null b) (bool-vector-p b))
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(let ((dest (or b (make-bool-vector (length a) nil))))
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(aset dest i (not (aref a i))))
dest))
(compat-defun bool-vector-subsetp (a b)
"Return t if every t value in A is also t in B, nil otherwise.
A and B must be bool vectors of the same length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(catch 'not-subset
(dotimes (i (length a))
(when (if (aref a i) (not (aref b i)) nil)
(throw 'not-subset nil)))
t))
(compat-defun bool-vector-count-consecutive (a b i)
"Count how many consecutive elements in A equal B starting at I.
A is a bool vector, B is t or nil, and I is an index into A."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(setq b (and b t)) ;normalise to nil or t
(unless (< i (length a))
(signal 'args-out-of-range (list a i)))
(let ((len (length a)) (n i))
(while (and (< i len) (eq (aref a i) b))
(setq i (1+ i)))
(- i n)))
(compat-defun bool-vector-count-population (a)
"Count how many elements in A are t.
A is a bool vector. To count A's nil elements, subtract the
return value from A's length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(let ((n 0))
(dotimes (i (length a))
(when (aref a i)
(setq n (1+ n))))
n))
;;;; Defined in subr.el
;;* UNTESTED
(compat-defmacro with-eval-after-load (file &rest body)
"Execute BODY after FILE is loaded.
FILE is normally a feature name, but it can also be a file name,
in case that file does not provide any feature. See `eval-after-load'
for more details about the different forms of FILE and their semantics."
(declare (indent 1) (debug (form def-body)))
;; See https://nullprogram.com/blog/2018/02/22/ on how
;; `eval-after-load' is used to preserve compatibility with 24.3.
`(eval-after-load ,file `(funcall ',,`(lambda () ,@body))))
(compat-defun special-form-p (object)
"Non-nil if and only if OBJECT is a special form."
(if (and (symbolp object) (fboundp object))
(setq object (condition-case nil
(indirect-function object)
(void-function nil))))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
(compat-defun macrop (object)
"Non-nil if and only if OBJECT is a macro."
(let ((def (condition-case nil
(indirect-function object)
(void-function nil))))
(when (consp def)
(or (eq 'macro (car def))
(and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
(compat-defun string-suffix-p (suffix string &optional ignore-case)
"Return non-nil if SUFFIX is a suffix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying
attention to case differences."
(let ((start-pos (- (length string) (length suffix))))
(and (>= start-pos 0)
(eq t (compare-strings suffix nil nil
string start-pos nil ignore-case)))))
(compat-defun split-string (string &optional separators omit-nulls trim)
"Extend `split-string' by a TRIM argument.
The remaining arguments STRING, SEPARATORS and OMIT-NULLS are
handled just as with `split-string'."
:prefix t
(let* ((token (split-string string separators omit-nulls))
(trimmed (if trim
(mapcar
(lambda (token)
(when (string-match (concat "\\`" trim) token)
(setq token (substring token (match-end 0))))
(when (string-match (concat trim "\\'") token)
(setq token (substring token 0 (match-beginning 0))))
token)
token)
token)))
(if omit-nulls (delete "" trimmed) trimmed)))
(compat-defun delete-consecutive-dups (list &optional circular)
"Destructively remove `equal' consecutive duplicates from LIST.
First and last elements are considered consecutive if CIRCULAR is
non-nil."
(let ((tail list) last)
(while (cdr tail)
(if (equal (car tail) (cadr tail))
(setcdr tail (cddr tail))
(setq last tail
tail (cdr tail))))
(if (and circular
last
(equal (car tail) (car list)))
(setcdr last nil)))
list)
;;* UNTESTED
(compat-defun define-error (name message &optional parent)
"Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such an error
is signaled without being caught by a `condition-case'.
PARENT is either a signal or a list of signals from which it inherits.
Defaults to `error'."
(unless parent (setq parent 'error))
(let ((conditions
(if (consp parent)
(apply #'append
(mapcar (lambda (parent)
(cons parent
(or (get parent 'error-conditions)
(error "Unknown signal `%s'" parent))))
parent))
(cons parent (get parent 'error-conditions)))))
(put name 'error-conditions
(delete-dups (copy-sequence (cons name conditions))))
(when message (put name 'error-message message))))
;;;; Defined in minibuffer.el
;;* UNTESTED
(compat-defun completion-table-with-cache (fun &optional ignore-case)
"Create dynamic completion table from function FUN, with cache.
This is a wrapper for `completion-table-dynamic' that saves the last
argument-result pair from FUN, so that several lookups with the
same argument (or with an argument that starts with the first one)
only need to call FUN once. This can be useful when FUN performs a
relatively slow operation, such as calling an external process.
When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
(let* (last-arg last-result
(new-fun
(lambda (arg)
(if (and last-arg (string-prefix-p last-arg arg ignore-case))
last-result
(prog1
(setq last-result (funcall fun arg))
(setq last-arg arg))))))
(completion-table-dynamic new-fun)))
;;* UNTESTED
(compat-defun completion-table-merge (&rest tables)
"Create a completion table that collects completions from all TABLES."
(lambda (string pred action)
(cond
((null action)
(let ((retvals (mapcar (lambda (table)
(try-completion string table pred))
tables)))
(if (member string retvals)
string
(try-completion string
(mapcar (lambda (value)
(if (eq value t) string value))
(delq nil retvals))
pred))))
((eq action t)
(apply #'append (mapcar (lambda (table)
(all-completions string table pred))
tables)))
(t
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables)))))
;;;; Defined in subr-x.el
;;* UNTESTED
(compat-advise require (feature &rest args)
"Allow for Emacs 24.x to require the inexistent FEATURE subr-x."
;; As the compatibility advise around `require` is more a hack than
;; of of actual value, the highlighting is suppressed.
:no-highlight t
(if (eq feature 'subr-x)
(let ((entry (assq feature after-load-alist)))
(let ((load-file-name nil))
(dolist (form (cdr entry))
(funcall (eval form t)))))
(apply oldfun feature args)))
(compat-defun hash-table-keys (hash-table)
"Return a list of keys in HASH-TABLE."
(let (values)
(maphash
(lambda (k _v) (push k values))
hash-table)
values))
(compat-defun hash-table-values (hash-table)
"Return a list of values in HASH-TABLE."
(let (values)
(maphash
(lambda (_k v) (push v values))
hash-table)
values))
(compat-defun string-empty-p (string)
"Check whether STRING is empty."
(string= string ""))
(compat-defun string-join (strings &optional separator)
"Join all STRINGS using SEPARATOR.
Optional argument SEPARATOR must be a string, a vector, or a list of
characters; nil stands for the empty string."
(mapconcat #'identity strings separator))
(compat-defun string-blank-p (string)
"Check whether STRING is either empty or only whitespace.
The following characters count as whitespace here: space, tab, newline and
carriage return."
(string-match-p "\\`[ \t\n\r]*\\'" string))
(compat-defun string-remove-prefix (prefix string)
"Remove PREFIX from STRING if present."
(if (string-prefix-p prefix string)
(substring string (length prefix))
string))
(compat-defun string-remove-suffix (suffix string)
"Remove SUFFIX from STRING if present."
(if (string-suffix-p suffix string)
(substring string 0 (- (length string) (length suffix)))
string))
;;;; Defined in faces.el
;;* UNTESTED
(compat-defun face-spec-set (face spec &optional spec-type)
"Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
See `defface' for the format of SPEC.
The appearance of each face is controlled by its specs (set via
this function), and by the internal frame-specific face
attributes (set via `set-face-attribute').
This function also defines FACE as a valid face name if it is not
already one, and (re)calculates its attributes on existing
frames.
The optional argument SPEC-TYPE determines which spec to set:
nil, omitted or `face-override-spec' means the override spec,
which overrides all the other types of spec mentioned below
(this is usually what you want if calling this function
outside of Custom code);
`customized-face' or `saved-face' means the customized spec or
the saved custom spec;
`face-defface-spec' means the default spec
(usually set only via `defface');
`reset' means to ignore SPEC, but clear the `customized-face'
and `face-override-spec' specs;
Any other value means not to set any spec, but to run the
function for defining FACE and recalculating its attributes."
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
;; Save SPEC to the relevant symbol property.
(unless spec-type
(setq spec-type 'face-override-spec))
(if (memq spec-type '(face-defface-spec face-override-spec
customized-face saved-face))
(put face spec-type spec))
(if (memq spec-type '(reset saved-face))
(put face 'customized-face nil))
;; Setting the face spec via Custom empties out any override spec,
;; similar to how setting a variable via Custom changes its values.
(if (memq spec-type '(customized-face saved-face reset))
(put face 'face-override-spec nil))
;; If we reset the face based on its custom spec, it is unmodified
;; as far as Custom is concerned.
(unless (eq face 'face-override-spec)
(put face 'face-modified nil))
;; Initialize the face if it does not exist, then recalculate.
(make-empty-face face)
(dolist (frame (frame-list))
(face-spec-recalc face frame)))
(compat--inhibit-prefixed (provide 'compat-24))
;;; compat-24.el ends here

251
lisp/compat/compat-25.el
View File

@@ -1,11 +1,6 @@
;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*- ;;; compat-25.el --- Functionality added in Emacs 25.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; 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
@@ -22,23 +17,17 @@
;;; Commentary: ;;; Commentary:
;; Find here the functionality added in Emacs 25.1, needed by older ;; Functionality added in Emacs 25.1, needed by older Emacs versions.
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;;; Code: ;;; Code:
(require 'compat-macs "compat-macs.el") (eval-when-compile (load "compat-macs.el" nil t t))
(compat-declare-version "25.1") (compat-version "25.1")
;;;; Defined in alloc.c ;;;; Defined in alloc.c
(compat-defun bool-vector (&rest objects) (compat-defun bool-vector (&rest objects) ;; <compat-tests:bool-vector>
"Return a new bool-vector with specified arguments as elements. "Return a new bool-vector with specified arguments as elements.
Allows any number of arguments, including zero. Allows any number of arguments, including zero.
usage: (bool-vector &rest OBJECTS)" usage: (bool-vector &rest OBJECTS)"
@@ -53,53 +42,77 @@ usage: (bool-vector &rest OBJECTS)"
;;;; Defined in fns.c ;;;; Defined in fns.c
(compat-defun sort (seq predicate) (compat-defun sort (seq predicate) ;; <compat-tests:sort>
"Extend `sort' to sort SEQ as a vector." "Handle vector SEQ."
:prefix t :extended t
(cond (cond
((listp seq) ((listp seq)
(sort seq predicate)) (sort seq predicate))
((vectorp seq) ((vectorp seq)
(let ((cseq (sort (append seq nil) predicate))) (let* ((list (sort (append seq nil) predicate))
(dotimes (i (length cseq)) (p list) (i 0))
(setf (aref seq i) (nth i cseq))) (while p
(apply #'vector cseq))) (aset seq i (car p))
(setq i (1+ i) p (cdr p)))
(apply #'vector list)))
((signal 'wrong-type-argument 'list-or-vector-p)))) ((signal 'wrong-type-argument 'list-or-vector-p))))
;;;; Defined in editfns.c ;;;; Defined in editfns.c
(compat-defun format-message (string &rest objects) (compat-defalias format-message format) ;; <compat-tests:format-message>
"Format a string out of a format-string and arguments.
The first argument is a format control string.
The other arguments are substituted into it to make the result, a string.
This implementation is equivalent to `format'."
(apply #'format string objects))
;;;; Defined in minibuf.c
;; TODO advise read-buffer to handle 4th argument
;;;; Defined in fileio.c ;;;; Defined in fileio.c
(compat-defun directory-name-p (name) (compat-defun directory-name-p (name) ;; <compat-tests:directory-name-p>
"Return non-nil if NAME ends with a directory separator character." "Return non-nil if NAME ends with a directory separator character."
:realname compat--directory-name-p
(eq (eval-when-compile (eq (eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos)) (if (memq system-type '(cygwin windows-nt ms-dos))
?\\ ?/)) ?\\ ?/))
(aref name (1- (length name))))) (aref name (1- (length name)))))
;;;; Defined in doc.c
(compat-defvar text-quoting-style nil ;; <compat-tests:text-quoting-style>
"Style to use for single quotes in help and messages.
The value of this variable determines substitution of grave accents
and apostrophes in help output (but not for display of Info
manuals) and in functions like `message' and `format-message', but not
in `format'.
The value should be one of these symbols:
`curve': quote with curved single quotes ‘like this’.
`straight': quote with straight apostrophes \\='like this\\='.
`grave': quote with grave accent and apostrophe \\=`like this\\=';
i.e., do not alter the original quote marks.
nil: like `curve' if curved single quotes are displayable,
and like `grave' otherwise. This is the default.
You should never read the value of this variable directly from a Lisp
program. Use the function `text-quoting-style' instead, as that will
compute the correct value for the current terminal in the nil case.")
;;;; Defined in simple.el
;; `save-excursion' behaved like `save-mark-and-excursion' before 25.1.
(compat-defalias save-mark-and-excursion save-excursion) ;; <compat-tests:save-mark-and-excursion>
(declare-function region-bounds nil) ;; Defined in compat-26.el
(compat-defun region-noncontiguous-p () ;; <compat-tests:region-noncontiguous-p>
"Return non-nil if the region contains several pieces.
An example is a rectangular region handled as a list of
separate contiguous regions for each line."
(let ((bounds (region-bounds))) (and (cdr bounds) bounds)))
;;;; Defined in subr.el ;;;; Defined in subr.el
(compat-defun string-greaterp (string1 string2) (compat-defun string-greaterp (string1 string2) ;; <compat-tests:string-greaterp>
"Return non-nil if STRING1 is greater than STRING2 in lexicographic order. "Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
Case is significant. Case is significant.
Symbols are also allowed; their print names are used instead." Symbols are also allowed; their print names are used instead."
(string-lessp string2 string1)) (string-lessp string2 string1))
;;* UNTESTED (compat-defmacro with-file-modes (modes &rest body) ;; <compat-tests:with-file-modes>
(compat-defmacro with-file-modes (modes &rest body)
"Execute BODY with default file permissions temporarily set to MODES. "Execute BODY with default file permissions temporarily set to MODES.
MODES is as for `set-default-file-modes'." MODES is as for `set-default-file-modes'."
(declare (indent 1) (debug t)) (declare (indent 1) (debug t))
@@ -111,28 +124,7 @@ MODES is as for `set-default-file-modes'."
,@body) ,@body)
(set-default-file-modes ,umask))))) (set-default-file-modes ,umask)))))
(compat-defun alist-get (key alist &optional default remove testfn) (compat-defmacro if-let (spec then &rest else) ;; <compat-tests:if-let>
"Find the first element of ALIST whose `car' equals KEY and return its `cdr'.
If KEY is not found in ALIST, return DEFAULT.
Equality with KEY is tested by TESTFN, defaulting to `eq'."
:realname compat--alist-get-full-elisp
(ignore remove)
(let (entry)
(cond
((or (null testfn) (eq testfn 'eq))
(setq entry (assq key alist)))
((eq testfn 'equal)
(setq entry (assoc key alist)))
((catch 'found
(dolist (ent alist)
(when (and (consp ent) (funcall testfn (car ent) key))
(throw 'found (setq entry ent))))
default)))
(if entry (cdr entry) default)))
;;;; Defined in subr-x.el
(compat-defmacro if-let (spec then &rest else)
"Bind variables according to SPEC and evaluate THEN or ELSE. "Bind variables according to SPEC and evaluate THEN or ELSE.
Evaluate each binding in turn, as in `let*', stopping if a Evaluate each binding in turn, as in `let*', stopping if a
binding value is nil. If all are non-nil return the value of binding value is nil. If all are non-nil return the value of
@@ -148,29 +140,40 @@ SYMBOL is checked for nil.
As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING)
like \((SYMBOL SOMETHING)). This exists for backward compatibility like \((SYMBOL SOMETHING)). This exists for backward compatibility
with an old syntax that accepted only one binding." with an old syntax that accepted only one binding."
:realname compat--if-let
:feature 'subr-x
(declare (indent 2) (declare (indent 2)
(debug ([&or (symbolp form) (debug ([&or (symbolp form)
(&rest [&or symbolp (symbolp form) (form)])] (&rest [&or symbolp (symbolp form) (form)])]
body))) body)))
(when (and (<= (length spec) 2) (when (and (<= (length spec) 2) (not (listp (car spec))))
(not (listp (car spec))))
;; Adjust the single binding case ;; Adjust the single binding case
(setq spec (list spec))) (setq spec (list spec)))
`(compat--if-let* ,spec ,then ,(macroexp-progn else))) (let ((empty (make-symbol "s"))
(last t) list)
(dolist (var spec)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(if (cdr var) (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,then ,@else))))
(compat-defmacro when-let (spec &rest body) (compat-defmacro when-let (spec &rest body) ;; <compat-tests:when-let>
"Bind variables according to SPEC and conditionally evaluate BODY. "Bind variables according to SPEC and conditionally evaluate BODY.
Evaluate each binding in turn, stopping if a binding value is nil. Evaluate each binding in turn, stopping if a binding value is nil.
If all are non-nil, return the value of the last form in BODY. If all are non-nil, return the value of the last form in BODY.
The variable list SPEC is the same as in `if-let'." The variable list SPEC is the same as in `if-let'."
:feature 'subr-x
(declare (indent 1) (debug if-let)) (declare (indent 1) (debug if-let))
`(compat--if-let ,spec ,(macroexp-progn body))) (list 'if-let spec (macroexp-progn body)))
(compat-defmacro thread-first (&rest forms) ;;;; Defined in subr-x.el
(compat-defun hash-table-empty-p (hash-table) ;; <compat-tests:hash-table-empty-p>
"Check whether HASH-TABLE is empty (has 0 elements)."
(zerop (hash-table-count hash-table)))
(compat-defmacro thread-first (&rest forms) ;; <compat-tests:thread-first>
"Thread FORMS elements as the first argument of their successor. "Thread FORMS elements as the first argument of their successor.
Example: Example:
(thread-first (thread-first
@@ -183,7 +186,6 @@ Is equivalent to:
(+ (- (/ (+ 5 20) 25)) 40) (+ (- (/ (+ 5 20) 25)) 40)
Note how the single `-' got converted into a list before Note how the single `-' got converted into a list before
threading." threading."
:feature 'subr-x
(declare (indent 1) (declare (indent 1)
(debug (form &rest [&or symbolp (sexp &rest form)]))) (debug (form &rest [&or symbolp (sexp &rest form)])))
(let ((body (car forms))) (let ((body (car forms)))
@@ -195,7 +197,7 @@ threading."
(cdr form)))) (cdr form))))
body)) body))
(compat-defmacro thread-last (&rest forms) (compat-defmacro thread-last (&rest forms) ;; <compat-tests:thread-last>
"Thread FORMS elements as the last argument of their successor. "Thread FORMS elements as the last argument of their successor.
Example: Example:
(thread-last (thread-last
@@ -208,7 +210,6 @@ Is equivalent to:
(+ 40 (- (/ 25 (+ 20 5)))) (+ 40 (- (/ 25 (+ 20 5))))
Note how the single `-' got converted into a list before Note how the single `-' got converted into a list before
threading." threading."
:feature 'subr-x
(declare (indent 1) (debug thread-first)) (declare (indent 1) (debug thread-first))
(let ((body (car forms))) (let ((body (car forms)))
(dolist (form (cdr forms)) (dolist (form (cdr forms))
@@ -219,10 +220,31 @@ threading."
;;;; Defined in macroexp.el ;;;; Defined in macroexp.el
(declare-function macrop nil (object)) (compat-defun macroexp-parse-body (body) ;; <compat-tests:macroexp-parse-body>
(compat-defun macroexpand-1 (form &optional environment) "Parse a function BODY into (DECLARATIONS . EXPS)."
(let ((decls ()))
(while (and (cdr body)
(let ((e (car body)))
(or (stringp e)
(memq (car-safe e)
'(:documentation declare interactive cl-declare)))))
(push (pop body) decls))
(cons (nreverse decls) body)))
(compat-defun macroexp-quote (v) ;; <compat-tests:macroexp-quote>
"Return an expression E such that `(eval E)' is V.
E is either V or (quote V) depending on whether V evaluates to
itself or not."
(if (and (not (consp v))
(or (keywordp v)
(not (symbolp v))
(memq v '(nil t))))
v
(list 'quote v)))
(compat-defun macroexpand-1 (form &optional environment) ;; <compat-tests:macroexpand-1>
"Perform (at most) one step of macro expansion." "Perform (at most) one step of macro expansion."
:feature 'macroexp
(cond (cond
((consp form) ((consp form)
(let* ((head (car form)) (let* ((head (car form))
@@ -245,78 +267,5 @@ threading."
form)))))))) form))))))))
(t form))) (t form)))
;;;; Defined in byte-run.el (provide 'compat-25)
;;* UNTESTED
(compat-defun function-put (func prop value)
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
:version "24.4"
(put func prop value))
;;;; Defined in files.el
;;* UNTESTED
(compat-defun directory-files-recursively
(dir regexp &optional include-directories predicate follow-symlinks)
"Return list of all files under directory DIR whose names match REGEXP.
This function works recursively. Files are returned in \"depth
first\" order, and files from each directory are sorted in
alphabetical order. Each file name appears in the returned list
in its absolute form.
By default, the returned list excludes directories, but if
optional argument INCLUDE-DIRECTORIES is non-nil, they are
included.
PREDICATE can be either nil (which means that all subdirectories
of DIR are descended into), t (which means that subdirectories that
can't be read are ignored), or a function (which is called with
the name of each subdirectory, and should return non-nil if the
subdirectory is to be descended into).
If FOLLOW-SYMLINKS is non-nil, symbolic links that point to
directories are followed. Note that this can lead to infinite
recursion."
:realname compat--directory-files-recursively
(let* ((result nil)
(files nil)
(dir (directory-file-name dir))
;; When DIR is "/", remote file names like "/method:" could
;; also be offered. We shall suppress them.
(tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
(dolist (file (sort (file-name-all-completions "" dir)
'string<))
(unless (member file '("./" "../"))
(if (directory-name-p file)
(let* ((leaf (substring file 0 (1- (length file))))
(full-file (concat dir "/" leaf)))
;; Don't follow symlinks to other directories.
(when (and (or (not (file-symlink-p full-file))
(and (file-symlink-p full-file)
follow-symlinks))
;; Allow filtering subdirectories.
(or (eq predicate nil)
(eq predicate t)
(funcall predicate full-file)))
(let ((sub-files
(if (eq predicate t)
(condition-case nil
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks)
(file-error nil))
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks))))
(setq result (nconc result sub-files))))
(when (and include-directories
(string-match regexp leaf))
(setq result (nconc result (list full-file)))))
(when (string-match regexp file)
(push (concat dir "/" file) files)))))
(nconc result (nreverse files))))
(compat--inhibit-prefixed (provide 'compat-25))
;;; compat-25.el ends here ;;; compat-25.el ends here

565
lisp/compat/compat-26.el
View File

@@ -1,11 +1,6 @@
;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*- ;;; compat-26.el --- Functionality added in Emacs 26.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; 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
@@ -22,154 +17,110 @@
;;; Commentary: ;;; Commentary:
;; Find here the functionality added in Emacs 26.1, needed by older ;; Functionality added in Emacs 26.1, needed by older Emacs versions.
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;; - `line-number-at-pos'
;; - `compat-alist-get'
;; - `string-trim-left'
;; - `string-trim-right'
;; - `string-trim'
;;; Code: ;;; Code:
(require 'compat-macs "compat-macs.el") (eval-when-compile (load "compat-macs.el" nil t t))
(compat-require compat-25 "25.1")
(compat-declare-version "26.1") (compat-version "26.1")
;;;; Defined in eval.c
(compat-defun func-arity (func)
"Return minimum and maximum number of args allowed for FUNC.
FUNC must be a function of some kind.
The returned value is a cons cell (MIN . MAX). MIN is the minimum number
of args. MAX is the maximum number, or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form."
:realname compat--func-arity
(cond
((or (null func) (and (symbolp func) (not (fboundp func))))
(signal 'void-function func))
((and (symbolp func) (not (null func)))
(compat--func-arity (symbol-function func)))
((eq (car-safe func) 'macro)
(compat--func-arity (cdr func)))
((subrp func)
(subr-arity func))
((memq (car-safe func) '(closure lambda))
;; See lambda_arity from eval.c
(when (eq (car func) 'closure)
(setq func (cdr func)))
(let ((syms-left (if (consp func)
(car func)
(signal 'invalid-function func)))
(min-args 0) (max-args 0) optional)
(catch 'many
(dolist (next syms-left)
(cond
((not (symbolp next))
(signal 'invalid-function func))
((eq next '&rest)
(throw 'many (cons min-args 'many)))
((eq next '&optional)
(setq optional t))
(t (unless optional
(setq min-args (1+ min-args)))
(setq max-args (1+ max-args)))))
(cons min-args max-args))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (listp (aref func 0)))
;; Based on `byte-compile-make-args-desc', this is required for
;; old versions of Emacs that don't use a integer for the argument
;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6.
(let ((arglist (aref func 0)) (mandatory 0) nonrest)
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
(setq mandatory (1+ mandatory))
(setq arglist (cdr arglist)))
(setq nonrest mandatory)
(when (eq (car arglist) '&optional)
(setq arglist (cdr arglist))
(while (and arglist (not (eq (car arglist) '&rest)))
(setq nonrest (1+ nonrest))
(setq arglist (cdr arglist))))
(cons mandatory (if arglist 'many nonrest))))
((autoloadp func)
(autoload-do-load func)
(compat--func-arity func))
((signal 'invalid-function func))))
;;;; Defined in fns.c ;;;; Defined in fns.c
(compat-defun assoc (key alist &optional testfn) (compat-defun buffer-hash (&optional buffer-or-name) ;; <compat-tests:buffer-hash>
"Handle the optional argument TESTFN. "Return a hash of the contents of BUFFER-OR-NAME.
Equality is defined by the function TESTFN, defaulting to This hash is performed on the raw internal format of the buffer,
`equal'. TESTFN is called with 2 arguments: a car of an alist disregarding any coding systems. If nil, use the current buffer.
element and KEY. With no optional argument, the function behaves
just like `assoc'."
:prefix t
(if testfn
(catch 'found
(dolist (ent alist)
(when (funcall testfn (car ent) key)
(throw 'found ent))))
(assoc key alist)))
(compat-defun mapcan (func sequence) This function is useful for comparing two buffers running in the same
Emacs, but is not guaranteed to return the same hash between different
Emacs versions. It should be somewhat more efficient on larger
buffers than `secure-hash' is, and should not allocate more memory.
It should not be used for anything security-related. See
`secure-hash' for these applications."
(with-current-buffer (or buffer-or-name (current-buffer))
(save-restriction
(widen)
(sha1 (current-buffer) (point-min) (point-max)))))
(compat-defun mapcan (func sequence) ;; <compat-tests:mapcan>
"Apply FUNC to each element of SEQUENCE. "Apply FUNC to each element of SEQUENCE.
Concatenate the results by altering them (using `nconc'). Concatenate the results by altering them (using `nconc').
SEQUENCE may be a list, a vector, a boolean vector, or a string." SEQUENCE may be a list, a vector, a boolean vector, or a string."
(apply #'nconc (mapcar func sequence))) (apply #'nconc (mapcar func sequence)))
;;* UNTESTED (compat-defun line-number-at-pos (&optional position absolute) ;; <compat-tests:line-number-at-pos>
(compat-defun line-number-at-pos (&optional position absolute) "Handle optional argument ABSOLUTE."
"Handle optional argument ABSOLUTE: :extended t
If the buffer is narrowed, the return value by default counts the lines
from the beginning of the accessible portion of the buffer. But if the
second optional argument ABSOLUTE is non-nil, the value counts the lines
from the absolute start of the buffer, disregarding the narrowing."
:prefix t
(if absolute (if absolute
(save-restriction (save-restriction
(widen) (widen)
(line-number-at-pos position)) (line-number-at-pos position))
(line-number-at-pos position))) (line-number-at-pos position)))
;;;; Defined in simple.el
(compat-defun region-bounds () ;; <compat-tests:region-bounds>
"Return the boundaries of the region.
Value is a list of one or more cons cells of the form (START . END).
It will have more than one cons cell when the region is non-contiguous,
see `region-noncontiguous-p' and `extract-rectangle-bounds'."
(if (eval-when-compile (< emacs-major-version 25))
;; FIXME: The `region-extract-function' of Emacs 24 has no support for the
;; bounds argument.
(list (cons (region-beginning) (region-end)))
(funcall region-extract-function 'bounds)))
;;;; Defined in subr.el ;;;; Defined in subr.el
(declare-function compat--alist-get-full-elisp "compat-25" (compat-defun provided-mode-derived-p (mode &rest modes) ;; <compat-tests:provided-derived-mode-p>
(key alist &optional default remove testfn)) "Non-nil if MODE is derived from one of MODES.
(compat-defun alist-get (key alist &optional default remove testfn) Uses the `derived-mode-parent' property of the symbol to trace backwards.
"Handle TESTFN manually." If you just want to check `major-mode', use `derived-mode-p'."
:realname compat--alist-get-handle-testfn ;; If MODE is an alias, then look up the real mode function first.
:prefix t (let ((alias (symbol-function mode)))
(if testfn (when (and alias (symbolp alias))
(compat--alist-get-full-elisp key alist default remove testfn) (setq mode alias)))
(alist-get key alist default remove))) (while
(and
(not (memq mode modes))
(let* ((parent (get mode 'derived-mode-parent))
(parentfn (symbol-function parent)))
(setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
mode)
(gv-define-expander compat-alist-get (compat-defun assoc (key alist &optional testfn) ;; <compat-tests:assoc>
"Handle the optional TESTFN."
:extended t
(cond
((or (eq testfn #'eq)
(and (not testfn) (or (symbolp key) (integerp key)))) ;; eq_comparable_value
(assq key alist))
((or (eq testfn #'equal) (not testfn))
(assoc key alist))
(t
(catch 'found
(dolist (ent alist)
(when (funcall testfn (car ent) key)
(throw 'found ent)))))))
(compat-defun alist-get (key alist &optional default remove testfn) ;; <compat-tests:alist-get>
"Handle optional argument TESTFN."
:extended "25.1"
(ignore remove)
(let ((x (if (not testfn)
(assq key alist)
(compat--assoc key alist testfn))))
(if x (cdr x) default)))
(compat-guard t ;; <compat-tests:alist-get-gv>
(gv-define-expander compat--alist-get
(lambda (do key alist &optional default remove testfn) (lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key (macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist (gv-letplace (getter setter) alist
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) (macroexp-let2 nil p `(compat--assoc ,k ,getter ,testfn)
(compat-assoc ,k ,getter ,testfn)
(assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p) (funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default)) `(if ,p (cdr ,p) ,default))
(lambda (v) (lambda (v)
@@ -193,166 +144,157 @@ from the absolute start of the buffer, disregarding the narrowing."
(,p ,(funcall setter (,p ,(funcall setter
`(delq ,p ,getter)))))) `(delq ,p ,getter))))))
,v)))))))))) ,v))))))))))
(unless (get 'alist-get 'gv-expander)
(put 'alist-get 'gv-expander (get 'compat--alist-get 'gv-expander))))
(compat-defun string-trim-left (string &optional regexp) (compat-defun string-trim-left (string &optional regexp) ;; <compat-tests:string-trim-left>
"Trim STRING of leading string matching REGEXP. "Handle optional argument REGEXP."
:extended t
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-left
:prefix t
(if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
(substring string (match-end 0)) (substring string (match-end 0))
string)) string))
(compat-defun string-trim-right (string &optional regexp) (compat-defun string-trim-right (string &optional regexp) ;; <compat-tests:string-trim-right>
"Trim STRING of trailing string matching REGEXP. "Handle optional argument REGEXP."
:extended t
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-right
:prefix t
(let ((i (string-match-p (let ((i (string-match-p
(concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
string))) string)))
(if i (substring string 0 i) string))) (if i (substring string 0 i) string)))
(compat-defun string-trim (string &optional trim-left trim-right) (compat-defun string-trim (string &optional trim-left trim-right) ;; <compat-tests:string-trim>
"Trim STRING of leading with and trailing matching TRIM-LEFT and TRIM-RIGHT. "Handle optional arguments TRIM-LEFT and TRIM-RIGHT."
:extended t
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
:prefix t
;; `string-trim-left' and `string-trim-right' were moved from subr-x
;; to subr in Emacs 27, so to avoid loading subr-x we use the
;; compatibility function here:
(compat--string-trim-left (compat--string-trim-left
(compat--string-trim-right (compat--string-trim-right
string string
trim-right) trim-right)
trim-left)) trim-left))
(compat-defun caaar (x) (compat-defun caaar (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `car' of the `car' of X." "Return the `car' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (car (car x)))) (car (car (car x))))
(compat-defun caadr (x) (compat-defun caadr (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `car' of the `cdr' of X." "Return the `car' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (car (cdr x)))) (car (car (cdr x))))
(compat-defun cadar (x) (compat-defun cadar (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `cdr' of the `car' of X." "Return the `car' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (car x)))) (car (cdr (car x))))
(compat-defun caddr (x) (compat-defun caddr (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `cdr' of the `cdr' of X." "Return the `car' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (cdr x)))) (car (cdr (cdr x))))
(compat-defun cdaar (x) (compat-defun cdaar (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `car' of the `car' of X." "Return the `cdr' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (car x)))) (cdr (car (car x))))
(compat-defun cdadr (x) (compat-defun cdadr (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `car' of the `cdr' of X." "Return the `cdr' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (cdr x)))) (cdr (car (cdr x))))
(compat-defun cddar (x) (compat-defun cddar (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `cdr' of the `car' of X." "Return the `cdr' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (car x)))) (cdr (cdr (car x))))
(compat-defun cdddr (x) (compat-defun cdddr (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `cdr' of the `cdr' of X." "Return the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (cdr x)))) (cdr (cdr (cdr x))))
(compat-defun caaaar (x) (compat-defun caaaar (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `car' of the `car' of the `car' of X." "Return the `car' of the `car' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (car (car (car x))))) (car (car (car (car x)))))
(compat-defun caaadr (x) (compat-defun caaadr (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `car' of the `car' of the `cdr' of X." "Return the `car' of the `car' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (car (car (cdr x))))) (car (car (car (cdr x)))))
(compat-defun caadar (x) (compat-defun caadar (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `car' of the `cdr' of the `car' of X." "Return the `car' of the `car' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (car (cdr (car x))))) (car (car (cdr (car x)))))
(compat-defun caaddr (x) (compat-defun caaddr (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `car' of the `cdr' of the `cdr' of X." "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (car (cdr (cdr x))))) (car (car (cdr (cdr x)))))
(compat-defun cadaar (x) (compat-defun cadaar (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `cdr' of the `car' of the `car' of X." "Return the `car' of the `cdr' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (car (car x))))) (car (cdr (car (car x)))))
(compat-defun cadadr (x) (compat-defun cadadr (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `cdr' of the `car' of the `cdr' of X." "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (car (cdr x))))) (car (cdr (car (cdr x)))))
(compat-defun caddar (x) (compat-defun caddar (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `cdr' of the `cdr' of the `car' of X." "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (cdr (car x))))) (car (cdr (cdr (car x)))))
(compat-defun cadddr (x) (compat-defun cadddr (x) ;; <compat-tests:cXXXXr>
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(car (cdr (cdr (cdr x))))) (car (cdr (cdr (cdr x)))))
(compat-defun cdaaar (x) (compat-defun cdaaar (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `car' of the `car' of the `car' of X." "Return the `cdr' of the `car' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (car (car x))))) (cdr (car (car (car x)))))
(compat-defun cdaadr (x) (compat-defun cdaadr (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `car' of the `car' of the `cdr' of X." "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (car (cdr x))))) (cdr (car (car (cdr x)))))
(compat-defun cdadar (x) (compat-defun cdadar (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `car' of the `cdr' of the `car' of X." "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (cdr (car x))))) (cdr (car (cdr (car x)))))
(compat-defun cdaddr (x) (compat-defun cdaddr (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (car (cdr (cdr x))))) (cdr (car (cdr (cdr x)))))
(compat-defun cddaar (x) (compat-defun cddaar (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `cdr' of the `car' of the `car' of X." "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (car (car x))))) (cdr (cdr (car (car x)))))
(compat-defun cddadr (x) (compat-defun cddadr (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (car (cdr x))))) (cdr (cdr (car (cdr x)))))
(compat-defun cdddar (x) (compat-defun cdddar (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (cdr (car x))))) (cdr (cdr (cdr (car x)))))
(compat-defun cddddr (x) (compat-defun cddddr (x) ;; <compat-tests:cXXXXr>
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t)) (declare (pure t))
(cdr (cdr (cdr (cdr x))))) (cdr (cdr (cdr (cdr x)))))
(compat-defvar gensym-counter 0 (compat-defvar gensym-counter 0 ;; <compat-tests:gensym>
"Number used to construct the name of the next symbol created by `gensym'.") "Number used to construct the name of the next symbol created by `gensym'.")
(compat-defun gensym (&optional prefix) (compat-defun gensym (&optional prefix) ;; <compat-tests:gensym>
"Return a new uninterned symbol. "Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX. The name is made by appending `gensym-counter' to PREFIX.
PREFIX is a string, and defaults to \"g\"." PREFIX is a string, and defaults to \"g\"."
@@ -361,27 +303,52 @@ PREFIX is a string, and defaults to \"g\"."
(1+ gensym-counter))))) (1+ gensym-counter)))))
(make-symbol (format "%s%d" (or prefix "g") num)))) (make-symbol (format "%s%d" (or prefix "g") num))))
(compat-defmacro if-let* (varlist then &rest else) ;; <compat-tests:if-let*>
"Bind variables according to VARLIST and evaluate THEN or ELSE.
This is like `if-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(if (cdr var) (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,then ,@else))))
(compat-defmacro when-let* (varlist &rest body) ;; <compat-tests:when-let*>
"Bind variables according to VARLIST and conditionally evaluate BODY.
This is like `when-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
(declare (indent 1) (debug if-let*))
(list 'if-let* varlist (macroexp-progn body)))
(compat-defmacro and-let* (varlist &rest body) ;; <compat-tests:and-let*>
"Bind variables according to VARLIST and conditionally evaluate BODY.
Like `when-let*', except if BODY is empty and all the bindings
are non-nil, then the result is non-nil."
(declare (indent 1)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(if (cdr var) (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
;;;; Defined in files.el ;;;; Defined in files.el
(declare-function temporary-file-directory nil) (compat-defvar mounted-file-systems ;; <compat-tests:mounted-file-systems>
;;* UNTESTED
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file as close as possible to `default-directory'.
If PREFIX is a relative file name, and `default-directory' is a
remote file name or located on a mounted file systems, the
temporary file is created in the directory returned by the
function `temporary-file-directory'. Otherwise, the function
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
same meaning as in `make-temp-file'."
(let ((handler (find-file-name-handler
default-directory 'make-nearby-temp-file)))
(if (and handler (not (file-name-absolute-p default-directory)))
(funcall handler 'make-nearby-temp-file prefix dir-flag suffix)
(let ((temporary-file-directory (temporary-file-directory)))
(make-temp-file prefix dir-flag suffix)))))
(compat-defvar mounted-file-systems
(eval-when-compile (eval-when-compile
(if (memq system-type '(windows-nt cygwin)) (if (memq system-type '(windows-nt cygwin))
"^//[^/]+/" "^//[^/]+/"
@@ -389,35 +356,16 @@ same meaning as in `make-temp-file'."
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/"))))) "^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
"File systems that ought to be mounted.") "File systems that ought to be mounted.")
(compat-defun file-local-name (file) (compat-defun file-local-name (file) ;; <compat-tests:file-local-name>
"Return the local name component of FILE. "Return the local name component of FILE.
This function removes from FILE the specification of the remote host This function removes from FILE the specification of the remote host
and the method of accessing the host, leaving only the part that and the method of accessing the host, leaving only the part that
identifies FILE locally on the remote system. identifies FILE locally on the remote system.
The returned file name can be used directly as argument of The returned file name can be used directly as argument of
`process-file', `start-file-process', or `shell-command'." `process-file', `start-file-process', or `shell-command'."
:realname compat--file-local-name
(or (file-remote-p file 'localname) file)) (or (file-remote-p file 'localname) file))
(compat-defun file-name-quoted-p (name &optional top) (compat-defun temporary-file-directory () ;; <compat-tests:temporary-file-directory>
"Whether NAME is quoted with prefix \"/:\".
If NAME is a remote file name and TOP is nil, check the local part of NAME."
:realname compat--file-name-quoted-p
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(string-prefix-p "/:" (compat--file-local-name name))))
(compat-defun file-name-quote (name &optional top)
"Add the quotation prefix \"/:\" to file NAME.
If NAME is a remote file name and TOP is nil, the local part of
NAME is quoted. If NAME is already a quoted file name, NAME is
returned unchanged."
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(if (compat--file-name-quoted-p name top)
name
(concat (file-remote-p name) "/:" (compat--file-local-name name)))))
;;* UNTESTED
(compat-defun temporary-file-directory ()
"The directory for writing temporary files. "The directory for writing temporary files.
In case of a remote `default-directory', this is a directory for In case of a remote `default-directory', this is a directory for
temporary files on that remote host. If such a directory does temporary files on that remote host. If such a directory does
@@ -426,87 +374,107 @@ mounted file system (see `mounted-file-systems'), the function
returns `default-directory'. returns `default-directory'.
For a non-remote and non-mounted `default-directory', the value of For a non-remote and non-mounted `default-directory', the value of
the variable `temporary-file-directory' is returned." the variable `temporary-file-directory' is returned."
;; NOTE: The handler may fail with an error, since the
;; `temporary-file-directory' handler was introduced in Emacs 26.
(let ((handler (find-file-name-handler (let ((handler (find-file-name-handler
default-directory 'temporary-file-directory))) default-directory 'temporary-file-directory)))
(if handler (or (and handler (ignore-errors (funcall handler 'temporary-file-directory)))
(funcall handler 'temporary-file-directory) (if-let ((remote (file-remote-p default-directory)))
(concat remote "/tmp/") ;; FIXME: Guess /tmp on remote host
(if (string-match mounted-file-systems default-directory) (if (string-match mounted-file-systems default-directory)
default-directory default-directory
temporary-file-directory)))) temporary-file-directory)))))
;;* UNTESTED (compat-defun make-temp-file (prefix &optional dir-flag suffix text) ;; <compat-tests:make-temp-file>
(compat-defun file-attribute-type (attributes) "Handle optional argument TEXT."
:extended t
(let ((file (make-temp-file prefix dir-flag suffix)))
(when text
(with-temp-buffer
(insert text)
(write-region (point-min) (point-max) file)))
file))
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix) ;; <compat-tests:make-nearby-temp-file>
"Create a temporary file as close as possible to `default-directory'.
If PREFIX is a relative file name, and `default-directory' is a
remote file name or located on a mounted file systems, the
temporary file is created in the directory returned by the
function `temporary-file-directory'. Otherwise, the function
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
same meaning as in `make-temp-file'."
;; NOTE: The handler may fail with an error, since the
;; `make-nearby-temp-file' handler was introduced in Emacs 26.
(let ((handler (and (not (file-name-absolute-p default-directory))
(find-file-name-handler
default-directory 'make-nearby-temp-file))))
(or (and handler (ignore-errors (funcall handler 'make-nearby-temp-file
prefix dir-flag suffix)))
(let ((temporary-file-directory (temporary-file-directory)))
(make-temp-file prefix dir-flag suffix)))))
(compat-defun file-attribute-type (attributes) ;; <compat-tests:file-attribute-getters>
"The type field in ATTRIBUTES returned by `file-attributes'. "The type field in ATTRIBUTES returned by `file-attributes'.
The value is either t for directory, string (name linked to) for The value is either t for directory, string (name linked to) for
symbolic link, or nil." symbolic link, or nil."
(nth 0 attributes)) (nth 0 attributes))
;;* UNTESTED (compat-defun file-attribute-link-number (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-link-number (attributes)
"Return the number of links in ATTRIBUTES returned by `file-attributes'." "Return the number of links in ATTRIBUTES returned by `file-attributes'."
(nth 1 attributes)) (nth 1 attributes))
;;* UNTESTED (compat-defun file-attribute-user-id (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-user-id (attributes)
"The UID field in ATTRIBUTES returned by `file-attributes'. "The UID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is looked up, a numeric value, either an integer or a float, is
returned." returned."
(nth 2 attributes)) (nth 2 attributes))
;;* UNTESTED (compat-defun file-attribute-group-id (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-group-id (attributes)
"The GID field in ATTRIBUTES returned by `file-attributes'. "The GID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is looked up, a numeric value, either an integer or a float, is
returned." returned."
(nth 3 attributes)) (nth 3 attributes))
;;* UNTESTED (compat-defun file-attribute-access-time (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-access-time (attributes)
"The last access time in ATTRIBUTES returned by `file-attributes'. "The last access time in ATTRIBUTES returned by `file-attributes'.
This a Lisp timestamp in the style of `current-time'." This a Lisp timestamp in the style of `current-time'."
(nth 4 attributes)) (nth 4 attributes))
;;* UNTESTED (compat-defun file-attribute-modification-time (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'. "The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and This is the time of the last change to the file's contents, and
is a Lisp timestamp in the style of `current-time'." is a Lisp timestamp in the style of `current-time'."
(nth 5 attributes)) (nth 5 attributes))
;;* UNTESTED (compat-defun file-attribute-status-change-time (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-status-change-time (attributes)
"The status modification time in ATTRIBUTES returned by `file-attributes'. "The status modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of last change to the file's attributes: owner This is the time of last change to the file's attributes: owner
and group, access mode bits, etc., and is a Lisp timestamp in the and group, access mode bits, etc., and is a Lisp timestamp in the
style of `current-time'." style of `current-time'."
(nth 6 attributes)) (nth 6 attributes))
;;* UNTESTED (compat-defun file-attribute-size (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-size (attributes)
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'." "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
(nth 7 attributes)) (nth 7 attributes))
;;* UNTESTED (compat-defun file-attribute-modes (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-modes (attributes)
"The file modes in ATTRIBUTES returned by `file-attributes'. "The file modes in ATTRIBUTES returned by `file-attributes'.
This is a string of ten letters or dashes as in ls -l." This is a string of ten letters or dashes as in ls -l."
(nth 8 attributes)) (nth 8 attributes))
;;* UNTESTED (compat-defun file-attribute-inode-number (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-inode-number (attributes)
"The inode number in ATTRIBUTES returned by `file-attributes'. "The inode number in ATTRIBUTES returned by `file-attributes'.
It is a nonnegative integer." It is a nonnegative integer."
(nth 10 attributes)) (nth 10 attributes))
;;* UNTESTED (compat-defun file-attribute-device-number (attributes) ;; <compat-tests:file-attribute-getters>
(compat-defun file-attribute-device-number (attributes)
"The file system device number in ATTRIBUTES returned by `file-attributes'. "The file system device number in ATTRIBUTES returned by `file-attributes'.
It is an integer." It is an integer."
(nth 11 attributes)) (nth 11 attributes))
(compat-defun file-attribute-collect (attributes &rest attr-names) (compat-defun file-attribute-collect (attributes &rest attr-names) ;; <compat-tests:file-attribute-collect>
"Return a sublist of ATTRIBUTES returned by `file-attributes'. "Return a sublist of ATTRIBUTES returned by `file-attributes'.
ATTR-NAMES are symbols with the selected attribute names. ATTR-NAMES are symbols with the selected attribute names.
@@ -534,105 +502,28 @@ inode-number and device-number."
(error "Wrong attribute name '%S'" attr)))) (error "Wrong attribute name '%S'" attr))))
(nreverse result))) (nreverse result)))
;;;; Defined in subr-x.el ;;;; Defined in mouse.el
(compat-defmacro if-let* (varlist then &rest else) (compat-defvar mouse-select-region-move-to-beginning nil ;; <compat-tests:thing-at-mouse>
"Bind variables according to VARLIST and evaluate THEN or ELSE. "Effect of selecting a region extending backward from double click.
This is like `if-let' but doesn't handle a VARLIST of the form Nil means keep point at the position clicked (region end);
\(SYMBOL SOMETHING) specially." non-nil means move point to beginning of region.")
:realname compat--if-let*
:feature 'subr-x
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,then ,@else))))
(compat-defmacro when-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally evaluate BODY.
This is like `when-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
;; :feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(when ,(caar list) ,@body))))
(compat-defmacro and-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally evaluate BODY.
Like `when-let*', except if BODY is empty and all the bindings
are non-nil, then the result is non-nil."
:feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
;;;; Defined in image.el ;;;; Defined in image.el
;;* UNTESTED (compat-defun image-property (image property) ;; <compat-tests:image-property>
(compat-defun image-property (image property)
"Return the value of PROPERTY in IMAGE. "Return the value of PROPERTY in IMAGE.
Properties can be set with Properties can be set with
(setf (image-property IMAGE PROPERTY) VALUE) (setf (image-property IMAGE PROPERTY) VALUE)
If VALUE is nil, PROPERTY is removed from IMAGE." If VALUE is nil, PROPERTY is removed from IMAGE."
:feature image
(plist-get (cdr image) property)) (plist-get (cdr image) property))
;;* UNTESTED
(unless (get 'image-property 'gv-expander)
(gv-define-setter image-property (image property value)
(let ((image* (make-symbol "image"))
(property* (make-symbol "property"))
(value* (make-symbol "value")))
`(let ((,image* ,image)
(,property* ,property)
(,value* ,value))
(if
(null ,value*)
(while
(cdr ,image*)
(if
(eq
(cadr ,image*)
,property*)
(setcdr ,image*
(cdddr ,image*))
(setq ,image*
(cddr ,image*))))
(setcdr ,image*
(plist-put
(cdr ,image*)
,property* ,value*)))))))
;;;; Defined in rmc.el ;;;; Defined in rmc.el
;;*UNTESTED (compat-defun read-multiple-choice (prompt choices) ;; <compat-tests:read-multiple-choice>
(compat-defun read-multiple-choice
(prompt choices &optional _help-string _show-help long-form)
"Ask user to select an entry from CHOICES, promting with PROMPT. "Ask user to select an entry from CHOICES, promting with PROMPT.
This function allows to ask the user a multiple-choice question. This function allows to ask the user a multiple-choice question.
@@ -641,21 +532,9 @@ KEY is a character the user should type to select the entry.
NAME is a short name for the entry to be displayed while prompting NAME is a short name for the entry to be displayed while prompting
\(if there's no room, it might be shortened). \(if there's no room, it might be shortened).
If LONG-FORM, do a `completing-read' over the NAME elements in NOTE: This is a partial implementation of `read-multiple-choice', that
CHOICES instead."
:note "This is a partial implementation of `read-multiple-choice', that
among other things doesn't offer any help and ignores the among other things doesn't offer any help and ignores the
optional DESCRIPTION field." optional DESCRIPTION field."
(if long-form
(let ((options (mapconcat #'cadr choices "/"))
choice)
(setq prompt (concat prompt " (" options "): "))
(setq choice (completing-read prompt (mapcar #'cadr choices) nil t))
(catch 'found
(dolist (option choices)
(when (string= choice (cadr option))
(throw 'found option)))
(error "Invalid choice")))
(let ((options (let ((options
(mapconcat (mapconcat
(lambda (opt) (lambda (opt)
@@ -666,10 +545,10 @@ optional DESCRIPTION field."
choices " ")) choices " "))
choice) choice)
(setq prompt (concat prompt " (" options "): ")) (setq prompt (concat prompt " (" options "): "))
(while (not (setq choice (assq (read-char prompt) choices))) (while (not (setq choice (assq (read-event prompt) choices)))
(message "Invalid choice") (message "Invalid choice")
(sit-for 1)) (sit-for 1))
choice))) choice))
(compat--inhibit-prefixed (provide 'compat-26)) (provide 'compat-26)
;;; compat-26.el ends here ;;; compat-26.el ends here

1051
lisp/compat/compat-27.el
View File

File diff suppressed because it is too large Load Diff

552
lisp/compat/compat-28.el
View File

@@ -1,11 +1,6 @@
;;; compat-28.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*- ;;; compat-28.el --- Functionality added in Emacs 28.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; 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
@@ -22,31 +17,23 @@
;;; Commentary: ;;; Commentary:
;; Find here the functionality added in Emacs 28.1, needed by older ;; Functionality added in Emacs 28.1, needed by older Emacs versions.
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `unlock-buffer'
;; - `string-width'
;; - `directory-files'
;; - `json-serialize'
;; - `json-insert'
;; - `json-parse-string'
;; - `json-parse-buffer'
;; - `count-windows'
;;; Code: ;;; Code:
(require 'compat-macs "compat-macs.el") (eval-when-compile (load "compat-macs.el" nil t t))
(compat-require compat-27 "27.1")
(compat-declare-version "28.1") (compat-version "28.1")
;;;; Defined in comp.c
(compat-defalias native-comp-available-p ignore) ;; <compat-tests:native-comp-available-p>
;;;; Defined in fns.c ;;;; Defined in fns.c
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions ;; FIXME Should handle multibyte regular expressions
(compat-defun string-search (needle haystack &optional start-pos) (compat-defun string-search (needle haystack &optional start-pos) ;; <compat-tests:string-search>
"Search for the string NEEDLE in the strign HAYSTACK. "Search for the string NEEDLE in the strign HAYSTACK.
The return value is the position of the first occurrence of The return value is the position of the first occurrence of
@@ -56,8 +43,9 @@ The optional START-POS argument says where to start searching in
HAYSTACK and defaults to zero (start at the beginning). HAYSTACK and defaults to zero (start at the beginning).
It must be between zero and the length of HAYSTACK, inclusive. It must be between zero and the length of HAYSTACK, inclusive.
Case is always significant and text properties are ignored." Case is always significant and text properties are ignored.
:note "Prior to Emacs 27 `string-match' has issues handling
NOTE: Prior to Emacs 27 `string-match' has issues handling
multibyte regular expressions. As the compatibility function multibyte regular expressions. As the compatibility function
for `string-search' is implemented via `string-match', these for `string-search' is implemented via `string-match', these
issues are inherited." issues are inherited."
@@ -68,7 +56,7 @@ issues are inherited."
(let ((case-fold-search nil)) (let ((case-fold-search nil))
(string-match (regexp-quote needle) haystack start-pos)))) (string-match (regexp-quote needle) haystack start-pos))))
(compat-defun length= (sequence length) (compat-defun length= (sequence length) ;; [[compat-tests:length=]]
"Returns non-nil if SEQUENCE has a length equal to LENGTH." "Returns non-nil if SEQUENCE has a length equal to LENGTH."
(cond (cond
((null sequence) (zerop length)) ((null sequence) (zerop length))
@@ -80,7 +68,7 @@ issues are inherited."
(= (length sequence) length)) (= (length sequence) length))
((signal 'wrong-type-argument sequence)))) ((signal 'wrong-type-argument sequence))))
(compat-defun length< (sequence length) (compat-defun length< (sequence length) ;; [[compat-tests:length<]]
"Returns non-nil if SEQUENCE is shorter than LENGTH." "Returns non-nil if SEQUENCE is shorter than LENGTH."
(cond (cond
((null sequence) (not (zerop length))) ((null sequence) (not (zerop length)))
@@ -90,7 +78,7 @@ issues are inherited."
(< (length sequence) length)) (< (length sequence) length))
((signal 'wrong-type-argument sequence)))) ((signal 'wrong-type-argument sequence))))
(compat-defun length> (sequence length) (compat-defun length> (sequence length) ;; [[compat-tests:length>]]
"Returns non-nil if SEQUENCE is longer than LENGTH." "Returns non-nil if SEQUENCE is longer than LENGTH."
(cond (cond
((listp sequence) ((listp sequence)
@@ -101,62 +89,36 @@ issues are inherited."
;;;; Defined in fileio.c ;;;; Defined in fileio.c
(compat-defun file-name-concat (directory &rest components) (compat-defun file-name-concat (directory &rest components) ;; <compat-tests:file-name-concat>
"Append COMPONENTS to DIRECTORY and return the resulting string. "Append COMPONENTS to DIRECTORY and return the resulting string.
Elements in COMPONENTS must be a string or nil. Elements in COMPONENTS must be a string or nil.
DIRECTORY or the non-final elements in COMPONENTS may or may not end DIRECTORY or the non-final elements in COMPONENTS may or may not end
with a slash -- if they don’t end with a slash, a slash will be with a slash -- if they don’t end with a slash, a slash will be
inserted before contatenating." inserted before contatenating."
(let ((seperator (eval-when-compile (let ((separator (eval-when-compile
(if (memq system-type '(ms-dos windows-nt cygwin)) (if (memq system-type '(ms-dos windows-nt cygwin))
"\\" "/"))) "\\" "/")))
(last (if components (car (last components)) directory))) (components (delq nil
(mapconcat (lambda (part) (mapcar (lambda (x) (and (not (equal "" x)) x))
(if (eq part last) ;the last component is not modified (cons directory components))))
last (result ""))
(replace-regexp-in-string (while components
(concat seperator "+\\'") "" part))) (let ((c (pop components)))
(cons directory components) (setq result (concat result c
seperator))) (and components
(not (string-suffix-p separator c))
separator)))))
result))
;;;; Defined in alloc.c ;;;; Defined in alloc.c
;;* UNTESTED (but also not necessary) (compat-defalias garbage-collect-maybe ignore) ;; <compat-tests:garbage-collect-maybe>
(compat-defun garbage-collect-maybe (_factor)
"Call ‘garbage-collect’ if enough allocation happened.
FACTOR determines what \"enough\" means here: If FACTOR is a
positive number N, it means to run GC if more than 1/Nth of the
allocations needed to trigger automatic allocation took place.
Therefore, as N gets higher, this is more likely to perform a GC.
Returns non-nil if GC happened, and nil otherwise."
:note "For releases of Emacs before version 28, this function will do nothing."
;; Do nothing
nil)
;;;; Defined in filelock.c
(compat-defun unlock-buffer ()
"Handle `file-error' conditions:
Handles file system errors by calling ‘display-warning’ and
continuing as if the error did not occur."
:prefix t
(condition-case error
(unlock-buffer)
(file-error
(display-warning
'(unlock-file)
(message "%s, ignored" (error-message-string error))
:warning))))
;;;; Defined in characters.c ;;;; Defined in characters.c
(compat-defun string-width (string &optional from to) (compat-defun string-width (string &optional from to) ;; <compat-tests:string-width>
"Handle optional arguments FROM and TO: "Handle optional arguments FROM and TO."
:extended t
Optional arguments FROM and TO specify the substring of STRING to
consider, and are interpreted as in `substring'."
:prefix t
(let* ((len (length string)) (let* ((len (length string))
(from (or from 0)) (from (or from 0))
(to (or to len))) (to (or to len)))
@@ -166,80 +128,25 @@ consider, and are interpreted as in `substring'."
;;;; Defined in dired.c ;;;; Defined in dired.c
;;* UNTESTED (compat-defun directory-files (directory &optional full match nosort count) ;; <compat-tests:directory-files>
(compat-defun directory-files (directory &optional full match nosort count) "Handle additional optional argument COUNT."
"Handle additional optional argument COUNT: :extended t
If COUNT is non-nil and a natural number, the function will
return COUNT number of file names (if so many are present)."
:prefix t
(let ((files (directory-files directory full match nosort))) (let ((files (directory-files directory full match nosort)))
(when (natnump count) (when (natnump count)
(setf (nthcdr count files) nil)) (setf (nthcdr count files) nil))
files)) files))
;;;; Defined in json.c (compat-defun directory-files-and-attributes (directory &optional full match nosort id-format count) ;; <compat-tests:directory-files-and-attributes>
"Handle additional optional argument COUNT."
(declare-function json-insert nil (object &rest args)) :extended t
(declare-function json-serialize nil (object &rest args)) (let ((files (directory-files-and-attributes directory full match nosort id-format)))
(declare-function json-parse-string nil (string &rest args)) (when (natnump count)
(declare-function json-parse-buffer nil (&rest args)) (setf (nthcdr count files) nil))
files))
(compat-defun json-serialize (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-serialize object args)
(substring (json-serialize (list object)) 1 -1)))
(compat-defun json-insert (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-insert object args)
;; `compat-json-serialize' is not sharp-quoted as the byte
;; compiled doesn't always know that the function has been
;; defined, but it will only be used in this function if the
;; prefixed definition of `json-serialize' (see above) has also
;; been defined.
(insert (apply 'compat-json-serialize object args))))
(compat-defun json-parse-string (string &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (string-match-p "\\`[[:space:]]*[[{]" string)
(apply #'json-parse-string string args)
;; Wrap the string in an array, and extract the value back using
;; `elt', to ensure that no matter what the value of `:array-type'
;; is we can access the first element.
(elt (apply #'json-parse-string (concat "[" string "]") args) 0)))
(compat-defun json-parse-buffer (&rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (looking-at-p "[[:space:]]*[[{]")
(apply #'json-parse-buffer args)
(catch 'escape
(atomic-change-group
(with-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\" "\"" st)
(modify-syntax-entry ?. "_" st)
st)
(let ((inhibit-read-only t))
(save-excursion
(insert "[")
(forward-sexp 1)
(insert "]"))))
(throw 'escape (elt (apply #'json-parse-buffer args) 0))))))
;;;; xfaces.c ;;;; xfaces.c
(compat-defun color-values-from-color-spec (spec) (compat-defun color-values-from-color-spec (spec) ;; <compat-tests:color-values-from-color-spec>
"Parse color SPEC as a numeric color and return (RED GREEN BLUE). "Parse color SPEC as a numeric color and return (RED GREEN BLUE).
This function recognises the following formats for SPEC: This function recognises the following formats for SPEC:
@@ -313,10 +220,50 @@ and BLUE, is normalized to have its value in [0,65535]."
(<= 0 b) (<= b 65535)) (<= 0 b) (<= b 65535))
(list r g b)))))))) (list r g b))))))))
;;;; Defined in simple.el
(compat-defun make-separator-line (&optional length) ;; <compat-tests:make-separator-line>
"Make a string appropriate for usage as a visual separator line.
If LENGTH is nil, use the window width."
(if (display-graphic-p)
(if length
(concat (propertize (make-string length ?\s) 'face '(:underline t)) "\n")
(propertize "\n" 'face '(:extend t :height 0.1 :inverse-video t)))
(concat (make-string (or length (1- (window-width))) ?-) "\n")))
;;;; Defined in subr.el ;;;; Defined in subr.el
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions (compat-defun process-lines-handling-status (program status-handler &rest args) ;; <compat-tests:process-lines-handling-status>
(compat-defun string-replace (fromstring tostring instring) "Execute PROGRAM with ARGS, returning its output as a list of lines.
If STATUS-HANDLER is non-nil, it must be a function with one
argument, which will be called with the exit status of the
program before the output is collected. If STATUS-HANDLER is
nil, an error is signaled if the program returns with a non-zero
exit status."
(with-temp-buffer
(let ((status (apply #'call-process program nil (current-buffer) nil args)))
(if status-handler
(funcall status-handler status)
(unless (eq status 0)
(error "%s exited with status %s" program status)))
(goto-char (point-min))
(let (lines)
(while (not (eobp))
(setq lines (cons (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))
lines))
(forward-line 1))
(nreverse lines)))))
(compat-defun process-lines-ignore-status (program &rest args) ;; <compat-tests:process-lines-ignore-status>
"Execute PROGRAM with ARGS, returning its output as a list of lines.
The exit status of the program is ignored.
Also see `process-lines'."
(apply 'process-lines-handling-status program #'ignore args))
;; FIXME Should handle multibyte regular expressions
(compat-defun string-replace (fromstring tostring instring) ;; <compat-tests:string-replace>
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
(when (equal fromstring "") (when (equal fromstring "")
(signal 'wrong-length-argument '(0))) (signal 'wrong-length-argument '(0)))
@@ -326,14 +273,13 @@ and BLUE, is normalized to have its value in [0,65535]."
tostring instring tostring instring
t t))) t t)))
(compat-defun always (&rest _arguments) (compat-defun always (&rest _arguments) ;; <compat-tests:always>
"Do nothing and return t. "Do nothing and return t.
This function accepts any number of ARGUMENTS, but ignores them. This function accepts any number of ARGUMENTS, but ignores them.
Also see `ignore'." Also see `ignore'."
t) t)
;;* UNTESTED (compat-defun insert-into-buffer (buffer &optional start end) ;; <compat-tests:insert-into-buffer>
(compat-defun insert-into-buffer (buffer &optional start end)
"Insert the contents of the current buffer into BUFFER. "Insert the contents of the current buffer into BUFFER.
If START/END, only insert that region from the current buffer. If START/END, only insert that region from the current buffer.
Point in BUFFER will be placed after the inserted text." Point in BUFFER will be placed after the inserted text."
@@ -341,8 +287,7 @@ Point in BUFFER will be placed after the inserted text."
(with-current-buffer buffer (with-current-buffer buffer
(insert-buffer-substring current start end)))) (insert-buffer-substring current start end))))
;;* UNTESTED (compat-defun replace-string-in-region (string replacement &optional start end) ;; <compat-tests:replace-string-in-region>
(compat-defun replace-string-in-region (string replacement &optional start end)
"Replace STRING with REPLACEMENT in the region from START to END. "Replace STRING with REPLACEMENT in the region from START to END.
The number of replaced occurrences are returned, or nil if STRING The number of replaced occurrences are returned, or nil if STRING
doesn't exist in the region. doesn't exist in the region.
@@ -359,18 +304,19 @@ Comparisons and replacements are done with fixed case."
(error "End after end of buffer")) (error "End after end of buffer"))
(setq end (point-max))) (setq end (point-max)))
(save-excursion (save-excursion
(goto-char start)
(save-restriction
(narrow-to-region start end)
(let ((matches 0) (let ((matches 0)
(case-fold-search nil)) (case-fold-search nil))
(goto-char start) (while (search-forward string nil t)
(while (search-forward string end t)
(delete-region (match-beginning 0) (match-end 0)) (delete-region (match-beginning 0) (match-end 0))
(insert replacement) (insert replacement)
(setq matches (1+ matches))) (setq matches (1+ matches)))
(and (not (zerop matches)) (and (not (zerop matches))
matches)))) matches)))))
;;* UNTESTED (compat-defun replace-regexp-in-region (regexp replacement &optional start end) ;; <compat-tests:replace-regexp-in-region>
(compat-defun replace-regexp-in-region (regexp replacement &optional start end)
"Replace REGEXP with REPLACEMENT in the region from START to END. "Replace REGEXP with REPLACEMENT in the region from START to END.
The number of replaced occurrences are returned, or nil if REGEXP The number of replaced occurrences are returned, or nil if REGEXP
doesn't exist in the region. doesn't exist in the region.
@@ -395,17 +341,18 @@ REPLACEMENT can use the following special elements:
(error "End after end of buffer")) (error "End after end of buffer"))
(setq end (point-max))) (setq end (point-max)))
(save-excursion (save-excursion
(goto-char start)
(save-restriction
(narrow-to-region start end)
(let ((matches 0) (let ((matches 0)
(case-fold-search nil)) (case-fold-search nil))
(goto-char start) (while (re-search-forward regexp nil t)
(while (re-search-forward regexp end t)
(replace-match replacement t) (replace-match replacement t)
(setq matches (1+ matches))) (setq matches (1+ matches)))
(and (not (zerop matches)) (and (not (zerop matches))
matches)))) matches)))))
;;* UNTESTED (compat-defun buffer-local-boundp (symbol buffer) ;; <compat-tests:buffer-local-boundp>
(compat-defun buffer-local-boundp (symbol buffer)
"Return non-nil if SYMBOL is bound in BUFFER. "Return non-nil if SYMBOL is bound in BUFFER.
Also see `local-variable-p'." Also see `local-variable-p'."
(catch 'fail (catch 'fail
@@ -414,26 +361,23 @@ Also see `local-variable-p'."
(void-variable nil (throw 'fail nil))) (void-variable nil (throw 'fail nil)))
t)) t))
;;* UNTESTED (compat-defmacro with-existing-directory (&rest body) ;; <compat-tests:with-existing-directory>
(compat-defmacro with-existing-directory (&rest body)
"Execute BODY with `default-directory' bound to an existing directory. "Execute BODY with `default-directory' bound to an existing directory.
If `default-directory' is already an existing directory, it's not changed." If `default-directory' is already an existing directory, it's not changed."
(declare (indent 0) (debug t)) (declare (indent 0) (debug t))
(let ((quit (make-symbol "with-existing-directory-quit"))) `(let ((default-directory
`(catch ',quit (or (catch 'quit
(dolist (dir (list default-directory (dolist (dir (list default-directory
(expand-file-name "~/") (expand-file-name "~/")
temporary-file-directory
(getenv "TMPDIR") (getenv "TMPDIR")
"/tmp/" "/tmp/"))
;; XXX: check if "/" works on non-POSIX
;; system.
"/"))
(when (and dir (file-exists-p dir)) (when (and dir (file-exists-p dir))
(throw ',quit (let ((default-directory dir)) (throw 'quit dir))))
,@body))))))) "/")))
,@body))
;;* UNTESTED (compat-defmacro dlet (binders &rest body) ;; <compat-tests:dlet>
(compat-defmacro dlet (binders &rest body)
"Like `let' but using dynamic scoping." "Like `let' but using dynamic scoping."
(declare (indent 1) (debug let)) (declare (indent 1) (debug let))
`(let (_) `(let (_)
@@ -442,7 +386,7 @@ If `default-directory' is already an existing directory, it's not changed."
binders) binders)
(let ,binders ,@body))) (let ,binders ,@body)))
(compat-defun ensure-list (object) (compat-defun ensure-list (object) ;; <compat-tests:ensure-list>
"Return OBJECT as a list. "Return OBJECT as a list.
If OBJECT is already a list, return OBJECT itself. If it's If OBJECT is already a list, return OBJECT itself. If it's
not a list, return a one-element list containing OBJECT." not a list, return a one-element list containing OBJECT."
@@ -450,18 +394,19 @@ not a list, return a one-element list containing OBJECT."
object object
(list object))) (list object)))
(compat-defun subr-primitive-p (object) (compat-defalias subr-primitive-p subrp) ;; <compat-tests:subr-primitive-p>
"Return t if OBJECT is a built-in primitive function."
(subrp object)) ;;;; Defined in data.c
(compat-defalias subr-native-elisp-p ignore) ;; <compat-tests:subr-native-elisp-p>
;;;; Defined in subr-x.el ;;;; Defined in subr-x.el
(compat-defun string-clean-whitespace (string) (compat-defun string-clean-whitespace (string) ;; <compat-tests:string-clean-whitespace>
"Clean up whitespace in STRING. "Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is single space character, and leading/trailing whitespace is
removed." removed."
:feature 'subr-x
(let ((blank "[[:blank:]\r\n]+")) (let ((blank "[[:blank:]\r\n]+"))
(replace-regexp-in-string (replace-regexp-in-string
"^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$" "^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$"
@@ -469,12 +414,11 @@ removed."
(replace-regexp-in-string (replace-regexp-in-string
blank " " string)))) blank " " string))))
(compat-defun string-fill (string length) (compat-defun string-fill (string length) ;; <compat-tests:string-fill>
"Clean up whitespace in STRING. "Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is single space character, and leading/trailing whitespace is
removed." removed."
:feature 'subr-x
(with-temp-buffer (with-temp-buffer
(insert string) (insert string)
(goto-char (point-min)) (goto-char (point-min))
@@ -483,13 +427,7 @@ removed."
(fill-region (point-min) (point-max))) (fill-region (point-min) (point-max)))
(buffer-string))) (buffer-string)))
(compat-defun string-lines (string &optional omit-nulls) (compat-defun string-pad (string length &optional padding start) ;; <compat-tests:string-pad>
"Split STRING into a list of lines.
If OMIT-NULLS, empty lines will be removed from the results."
:feature 'subr-x
(split-string string "\n" omit-nulls))
(compat-defun string-pad (string length &optional padding start)
"Pad STRING to LENGTH using PADDING. "Pad STRING to LENGTH using PADDING.
If PADDING is nil, the space character is used. If not nil, it If PADDING is nil, the space character is used. If not nil, it
should be a character. should be a character.
@@ -500,7 +438,6 @@ is done.
If START is nil (or not present), the padding is done to the end If START is nil (or not present), the padding is done to the end
of the string, and if non-nil, padding is done to the start of of the string, and if non-nil, padding is done to the start of
the string." the string."
:feature 'subr-x
(unless (natnump length) (unless (natnump length)
(signal 'wrong-type-argument (list 'natnump length))) (signal 'wrong-type-argument (list 'natnump length)))
(let ((pad-length (- length (length string)))) (let ((pad-length (- length (length string))))
@@ -512,20 +449,18 @@ the string."
(and (not start) (and (not start)
(make-string pad-length (or padding ?\s))))))) (make-string pad-length (or padding ?\s)))))))
(compat-defun string-chop-newline (string) (compat-defun string-chop-newline (string) ;; <compat-tests:string-chop-newline>
"Remove the final newline (if any) from STRING." "Remove the final newline (if any) from STRING."
:feature 'subr-x
(if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n)) (if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n))
(substring string 0 -1) (substring string 0 -1)
string)) string))
(compat-defmacro named-let (name bindings &rest body) (compat-defmacro named-let (name bindings &rest body) ;; <compat-tests:named-let>
"Looping construct taken from Scheme. "Looping construct taken from Scheme.
Like `let', bind variables in BINDINGS and then evaluate BODY, Like `let', bind variables in BINDINGS and then evaluate BODY,
but with the twist that BODY can evaluate itself recursively by but with the twist that BODY can evaluate itself recursively by
calling NAME, where the arguments passed to NAME are used calling NAME, where the arguments passed to NAME are used
as the new values of the bound variables in the recursive invocation." as the new values of the bound variables in the recursive invocation."
:feature 'subr-x
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
(let ((fargs (mapcar (lambda (b) (let ((fargs (mapcar (lambda (b)
(let ((var (if (consp b) (car b) b))) (let ((var (if (consp b) (car b) b)))
@@ -596,10 +531,9 @@ as the new values of the bound variables in the recursive invocation."
sets)) sets))
(cons 'setq (apply #'nconc (nreverse sets))))) (cons 'setq (apply #'nconc (nreverse sets)))))
(`(throw ',quit ,expr)))))) (`(throw ',quit ,expr))))))
(let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body))))) (when-let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body)))))
(when tco-body
(setq body `((catch ',quit (setq body `((catch ',quit
(while t (let ,rargs ,@(macroexp-unprogn tco-body)))))))) (while t (let ,rargs ,@(macroexp-unprogn tco-body)))))))
(let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro))))) (let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro)))))
(if total-tco (if total-tco
`(let ,bindings ,expand) `(let ,bindings ,expand)
@@ -609,9 +543,7 @@ as the new values of the bound variables in the recursive invocation."
;;;; Defined in files.el ;;;; Defined in files.el
(declare-function compat--string-trim-left "compat-26" (string &optional regexp)) (compat-defun file-name-with-extension (filename extension) ;; <compat-tests:file-name-with-extension>
(declare-function compat--directory-name-p "compat-25" (name))
(compat-defun file-name-with-extension (filename extension)
"Set the EXTENSION of a FILENAME. "Set the EXTENSION of a FILENAME.
The extension (in a file name) is the part that begins with the last \".\". The extension (in a file name) is the part that begins with the last \".\".
@@ -622,19 +554,18 @@ Errors if the FILENAME or EXTENSION are empty, or if the given
FILENAME has the format of a directory. FILENAME has the format of a directory.
See also `file-name-sans-extension'." See also `file-name-sans-extension'."
(let ((extn (compat--string-trim-left extension "[.]"))) (let ((extn (string-remove-prefix "." extension)))
(cond (cond
((string= filename "") ((string= filename "")
(error "Empty filename")) (error "Empty filename"))
((string= extn "") ((string= extn "")
(error "Malformed extension: %s" extension)) (error "Malformed extension: %s" extension))
((compat--directory-name-p filename) ((directory-name-p filename)
(error "Filename is a directory: %s" filename)) (error "Filename is a directory: %s" filename))
(t (t
(concat (file-name-sans-extension filename) "." extn))))) (concat (file-name-sans-extension filename) "." extn)))))
;;* UNTESTED (compat-defun directory-empty-p (dir) ;; <compat-tests:directory-empty-p>
(compat-defun directory-empty-p (dir)
"Return t if DIR names an existing directory containing no other files. "Return t if DIR names an existing directory containing no other files.
Return nil if DIR does not name a directory, or if there was Return nil if DIR does not name a directory, or if there was
trouble determining whether DIR is a directory or empty. trouble determining whether DIR is a directory or empty.
@@ -644,7 +575,7 @@ See `file-symlink-p' to distinguish symlinks."
(and (file-directory-p dir) (and (file-directory-p dir)
(null (directory-files dir nil directory-files-no-dot-files-regexp t)))) (null (directory-files dir nil directory-files-no-dot-files-regexp t))))
(compat-defun file-modes-number-to-symbolic (mode &optional filetype) (compat-defun file-modes-number-to-symbolic (mode &optional filetype) ;; <compat-tests:file-modes-number-to-symbolic>
"Return a string describing a file's MODE. "Return a string describing a file's MODE.
For instance, if MODE is #o700, then it produces `-rwx------'. For instance, if MODE is #o700, then it produces `-rwx------'.
FILETYPE if provided should be a character denoting the type of file, FILETYPE if provided should be a character denoting the type of file,
@@ -652,7 +583,7 @@ such as `?d' for a directory, or `?l' for a symbolic link and will override
the leading `-' char." the leading `-' char."
(string (string
(or filetype (or filetype
(pcase (lsh mode -12) (pcase (ash mode -12)
;; POSIX specifies that the file type is included in st_mode ;; POSIX specifies that the file type is included in st_mode
;; and provides names for the file types but values only for ;; and provides names for the file types but values only for
;; the permissions (e.g., S_IWOTH=2). ;; the permissions (e.g., S_IWOTH=2).
@@ -682,8 +613,7 @@ the leading `-' char."
(if (zerop (logand 1 mode)) ?- ?x) (if (zerop (logand 1 mode)) ?- ?x)
(if (zerop (logand 1 mode)) ?T ?t)))) (if (zerop (logand 1 mode)) ?T ?t))))
;;* UNTESTED (compat-defun file-backup-file-names (filename) ;; <compat-tests:file-backup-file-names>
(compat-defun file-backup-file-names (filename)
"Return a list of backup files for FILENAME. "Return a list of backup files for FILENAME.
The list will be sorted by modification time so that the most The list will be sorted by modification time so that the most
recent files are first." recent files are first."
@@ -702,7 +632,7 @@ recent files are first."
(push candidate files)))) (push candidate files))))
(sort files #'file-newer-than-file-p))) (sort files #'file-newer-than-file-p)))
(compat-defun make-lock-file-name (filename) (compat-defun make-lock-file-name (filename) ;; <compat-tests:make-lock-file-name>
"Make a lock file name for FILENAME. "Make a lock file name for FILENAME.
This prepends \".#\" to the non-directory part of FILENAME, and This prepends \".#\" to the non-directory part of FILENAME, and
doesn't respect `lock-file-name-transforms', as Emacs 28.1 and doesn't respect `lock-file-name-transforms', as Emacs 28.1 and
@@ -712,21 +642,9 @@ onwards does."
".#" (file-name-nondirectory filename)) ".#" (file-name-nondirectory filename))
(file-name-directory filename))) (file-name-directory filename)))
;;;; Defined in files-x.el
(declare-function tramp-tramp-file-p "tramp" (name))
;;* UNTESTED
(compat-defun null-device ()
"Return the best guess for the null device."
(require 'tramp)
(if (tramp-tramp-file-p default-directory)
"/dev/null"
null-device))
;;;; Defined in minibuffer.el ;;;; Defined in minibuffer.el
(compat-defun format-prompt (prompt default &rest format-args) (compat-defun format-prompt (prompt default &rest format-args) ;; <compat-tests:format-prompt>
"Format PROMPT with DEFAULT. "Format PROMPT with DEFAULT.
If FORMAT-ARGS is nil, PROMPT is used as a plain string. If If FORMAT-ARGS is nil, PROMPT is used as a plain string. If
FORMAT-ARGS is non-nil, PROMPT is used as a format control FORMAT-ARGS is non-nil, PROMPT is used as a format control
@@ -751,15 +669,56 @@ is included in the return value."
default))) default)))
": ")) ": "))
;;;; Defined in windows.el ;;;; Defined in faces.el
;;* UNTESTED (compat-defvar color-luminance-dark-limit 0.325 ;; <compat-tests:color-dark-p>
(compat-defun count-windows (&optional minibuf all-frames) "The relative luminance below which a color is considered \"dark\".
"Handle optional argument ALL-FRAMES: A \"dark\" color in this sense provides better contrast with white
than with black; see `color-dark-p'.
This value was determined experimentally."
:constant t)
If ALL-FRAMES is non-nil, count the windows in all frames instead (compat-defun color-dark-p (rgb) ;; <compat-tests:color-dark-p>
just the selected frame." "Whether RGB is more readable against white than black.
:prefix t RGB is a 3-element list (R G B), each component in the range [0,1].
This predicate can be used both for determining a suitable (black or white)
contrast color with RGB as background and as foreground."
(unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
(error "RGB components %S not in [0,1]" rgb))
;; Compute the relative luminance after gamma-correcting (assuming sRGB),
;; and compare to a cut-off value determined experimentally.
;; See https://en.wikipedia.org/wiki/Relative_luminance for details.
(let* ((sr (nth 0 rgb))
(sg (nth 1 rgb))
(sb (nth 2 rgb))
;; Gamma-correct the RGB components to linear values.
;; Use the power 2.2 as an approximation to sRGB gamma;
;; it should be good enough for the purpose of this function.
(r (expt sr 2.2))
(g (expt sg 2.2))
(b (expt sb 2.2))
(y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
(< y color-luminance-dark-limit)))
;;;; Defined in window.el
(compat-defmacro with-window-non-dedicated (window &rest body) ;; <compat-tests:with-window-non-dedicated>
"Evaluate BODY with WINDOW temporarily made non-dedicated.
If WINDOW is nil, use the selected window. Return the value of
the last form in BODY."
(declare (indent 1) (debug t))
(let ((window-dedicated-sym (gensym))
(window-sym (gensym)))
`(let* ((,window-sym (window-normalize-window ,window t))
(,window-dedicated-sym (window-dedicated-p ,window-sym)))
(set-window-dedicated-p ,window-sym nil)
(unwind-protect
(progn ,@body)
(set-window-dedicated-p ,window-sym ,window-dedicated-sym)))))
(compat-defun count-windows (&optional minibuf all-frames) ;; <compat-tests:count-windows>
"Handle optional argument ALL-FRAMES."
:extended t
(if all-frames (if all-frames
(let ((sum 0)) (let ((sum 0))
(dolist (frame (frame-list)) (dolist (frame (frame-list))
@@ -770,37 +729,61 @@ just the selected frame."
;;;; Defined in thingatpt.el ;;;; Defined in thingatpt.el
(declare-function mouse-set-point "mouse" (event &optional promote-to-region)) (compat-defun thing-at-mouse (event thing &optional no-properties) ;; <compat-tests:thing-at-mouse>
;;* UNTESTED
(compat-defun thing-at-mouse (event thing &optional no-properties)
"Return the THING at mouse click. "Return the THING at mouse click.
Like `thing-at-point', but tries to use the event Like `thing-at-point', but tries to use the event
where the mouse button is clicked to find a thing nearby." where the mouse button is clicked to find a thing nearby."
:feature 'thingatpt ;; No :feature specified, since the function is autoloaded.
(save-excursion (save-excursion
(mouse-set-point event) (mouse-set-point event)
(thing-at-point thing no-properties))) (thing-at-point thing no-properties)))
(compat-defun bounds-of-thing-at-mouse (event thing) ;; <compat-tests:thing-at-mouse>
"Determine start and end locations for THING at mouse click given by EVENT.
Like `bounds-of-thing-at-point', but tries to use the position in EVENT
where the mouse button is clicked to find the thing nearby."
;; No :feature specified, since the function is autoloaded.
(save-excursion
(mouse-set-point event)
(bounds-of-thing-at-point thing)))
;;;; Defined in mouse.el
(compat-defun mark-thing-at-mouse (click thing) ;; <compat-tests:thing-at-mouse>
"Activate the region around THING found near the mouse CLICK."
(when-let ((bounds (bounds-of-thing-at-mouse click thing)))
(goto-char (if mouse-select-region-move-to-beginning
(car bounds) (cdr bounds)))
(push-mark (if mouse-select-region-move-to-beginning
(cdr bounds) (car bounds))
t 'activate)))
;;;; Defined in macroexp.el ;;;; Defined in macroexp.el
;;* UNTESTED (compat-defun macroexp-warn-and-return (msg form &optional _category _compile-only _arg) ;; <compat-tests:macroexp-warn-and-return>
(compat-defun macroexp-file-name () "Return code equivalent to FORM labeled with warning MSG.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
COMPILE-ONLY non-nil means no warning should be emitted if the code
is executed without being compiled first.
ARG is a symbol (or a form) giving the source code position for the message.
It should normally be a symbol with position and it defaults to FORM."
(macroexp--warn-and-return msg form))
(compat-defun macroexp-file-name () ;; <compat-tests:macroexp-file-name>
"Return the name of the file from which the code comes. "Return the name of the file from which the code comes.
Returns nil when we do not know. Returns nil when we do not know.
A non-nil result is expected to be reliable when called from a macro in order A non-nil result is expected to be reliable when called from a macro in order
to find the file in which the macro's call was found, and it should be to find the file in which the macro's call was found, and it should be
reliable as well when used at the top-level of a file. reliable as well when used at the top-level of a file.
Other uses risk returning non-nil value that point to the wrong file." Other uses risk returning non-nil value that point to the wrong file."
:feature 'macroexp
(let ((file (car (last current-load-list)))) (let ((file (car (last current-load-list))))
(or (if (stringp file) file) (or (if (stringp file) file)
(bound-and-true-p byte-compile-current-file)))) (bound-and-true-p byte-compile-current-file))))
;;;; Defined in env.el ;;;; Defined in env.el
;;* UNTESTED (compat-defmacro with-environment-variables (variables &rest body) ;; <compat-tests:with-environment-variables>
(compat-defmacro with-environment-variables (variables &rest body)
"Set VARIABLES in the environent and execute BODY. "Set VARIABLES in the environent and execute BODY.
VARIABLES is a list of variable settings of the form (VAR VALUE), VARIABLES is a list of variable settings of the form (VAR VALUE),
where VAR is the name of the variable (a string) and VALUE where VAR is the name of the variable (a string) and VALUE
@@ -816,67 +799,56 @@ The previous values will be be restored upon exit."
variables) variables)
,@body)) ,@body))
;;;; Defined in button.el
;;* UNTESTED
(compat-defun button-buttonize (string callback &optional data)
"Make STRING into a button and return it.
When clicked, CALLBACK will be called with the DATA as the
function argument. If DATA isn't present (or is nil), the button
itself will be used instead as the function argument."
:feature 'button
(propertize string
'face 'button
'button t
'follow-link t
'category t
'button-data data
'keymap button-map
'action callback))
;;;; Defined in autoload.el
(defvar generated-autoload-file)
;;* UNTESTED
(compat-defun make-directory-autoloads (dir output-file)
"Update autoload definitions for Lisp files in the directories DIRS.
DIR can be either a single directory or a list of
directories. (The latter usage is discouraged.)
The autoloads will be written to OUTPUT-FILE. If any Lisp file
binds `generated-autoload-file' as a file-local variable, write
its autoloads into the specified file instead.
The function does NOT recursively descend into subdirectories of the
directory or directories specified."
(let ((generated-autoload-file output-file))
;; We intentionally don't sharp-quote
;; `update-directory-autoloads', because it was deprecated in
;; Emacs 28 and we don't want to trigger the byte compiler for
;; newer versions.
(apply 'update-directory-autoloads
(if (listp dir) dir (list dir)))))
;;;; Defined in time-data.el ;;;; Defined in time-data.el
(compat-defun decoded-time-period (time) (compat-defun decoded-time-period (time) ;; <compat-tests:decoded-time-period>
"Interpret DECODED as a period and return its length in seconds. "Interpret DECODED as a period and return its length in seconds.
For computational purposes, years are 365 days long and months For computational purposes, years are 365 days long and months
are 30 days long." are 30 days long."
:feature 'time-date :feature time-date
:version "28" (+ (if (consp (decoded-time-second time))
;; Inlining the definitions from compat-27 (/ (float (car (decoded-time-second time)))
(+ (if (consp (nth 0 time)) (cdr (decoded-time-second time)))
;; Fractional second. (or (decoded-time-second time) 0))
(/ (float (car (nth 0 time))) (* (or (decoded-time-minute time) 0) 60)
(cdr (nth 0 time))) (* (or (decoded-time-hour time) 0) 60 60)
(or (nth 0 time) 0)) (* (or (decoded-time-day time) 0) 60 60 24)
(* (or (nth 1 time) 0) 60) (* (or (decoded-time-month time) 0) 60 60 24 30)
(* (or (nth 2 time) 0) 60 60) (* (or (decoded-time-year time) 0) 60 60 24 365)))
(* (or (nth 3 time) 0) 60 60 24)
(* (or (nth 4 time) 0) 60 60 24 30)
(* (or (nth 5 time) 0) 60 60 24 365)))
(compat--inhibit-prefixed (provide 'compat-28)) ;;;; Defined in doc.c
(compat-defun text-quoting-style () ;; <compat-tests:text-quoting-style>
"Return the current effective text quoting style.
If the variable `text-quoting-style' is `grave', `straight' or
`curve', just return that value. If it is nil (the default), return
`grave' if curved quotes cannot be displayed (for instance, on a
terminal with no support for these characters), otherwise return
`quote'. Any other value is treated as `grave'.
Note that in contrast to the variable `text-quoting-style', this
function will never return nil."
(cond
((memq text-quoting-style '(grave straight curve))
text-quoting-style)
((not text-quoting-style) 'grave)
(t 'curve)))
;;;; Defined in button.el
;; Obsolete Alias since 29
(compat-defalias button-buttonize buttonize :obsolete t) ;; <compat-tests:button-buttonize>
;;;; Defined in wid-edit.el
(compat-guard t ;; <compat-tests:widget-natnum>
:feature wid-edit
(define-widget 'natnum 'restricted-sexp
"A nonnegative integer."
:tag "Integer (positive)"
:value 0
:type-error "This field should contain a nonnegative integer"
:match-alternatives '(natnump)))
(provide 'compat-28)
;;; compat-28.el ends here ;;; compat-28.el ends here

1585
lisp/compat/compat-29.el Normal file
View File

File diff suppressed because it is too large Load Diff

48
lisp/compat/compat-font-lock.el
View File

@@ -1,48 +0,0 @@
;;; compat-font-lock.el --- -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords:
;; 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:
;; Optional font-locking for `compat' definitions. Every symbol with
;; an active compatibility definition will be highlighted.
;;
;; Load this file to enable the functionality.
;;; Code:
(eval-and-compile
(require 'cl-lib)
(require 'compat-macs))
(defvar compat-generate-common-fn)
(let ((compat-generate-common-fn
(lambda (name _def-fn _install-fn check-fn attr _type)
(unless (and (plist-get attr :no-highlight)
(funcall check-fn))
`(font-lock-add-keywords
'emacs-lisp-mode
',`((,(concat "\\_<\\("
(regexp-quote (symbol-name name))
"\\)\\_>")
1 font-lock-preprocessor-face prepend)))))))
(load "compat"))
(provide 'compat-font-lock)
;;; compat-font-lock.el ends here

57
lisp/compat/compat-help.el
View File

@@ -1,57 +0,0 @@
;;; compat-help.el --- Documentation for compat functions -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Load this file to insert `compat'-relevant documentation next to
;; the regular documentation of a symbol.
;;; Code:
(defun compat---describe (symbol)
"Insert documentation for SYMBOL if it has compatibility code."
(let ((compat (get symbol 'compat-def)))
(when compat
(let ((doc (get compat 'compat-doc))
(start (point)))
(when doc
(insert "There is a ")
(insert-button
"compatibility notice"
'action (let ((type (get compat 'compat-type)))
(cond
((memq type '(func macro advice))
#'find-function)
((memq type '(variable))
#'find-variable)
((error "Unknown type"))))
'button-data compat)
(insert (format " for %s (for versions of Emacs before %s):"
(symbol-name symbol)
(get compat 'compat-version)))
(add-text-properties start (point) '(face bold))
(newline 2)
(insert (substitute-command-keys doc))
(fill-region start (point))
(newline 2))))))
(add-hook 'help-fns-describe-function-functions #'compat---describe)
(provide 'compat-help)
;;; compat-help.el ends here

489
lisp/compat/compat-macs.el
View File

@@ -1,9 +1,6 @@
;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*- ;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; 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
@@ -20,297 +17,249 @@
;;; Commentary: ;;; Commentary:
;; These macros are used to define compatibility functions, macros and ;; This file provides *internal* macros, which are used by Compat to
;; advice. ;; facilitate the definition of compatibility functions, macros and
;; variables. The `compat-macs' feature should never be loaded at
;; runtime in your Emacs and will only be used during byte
;; compilation. Every definition provided here should be considered
;; internal and may change any time between Compat releases.
;;; Code: ;;; Code:
(defmacro compat--ignore (&rest _) ;; We always require subr-x at compile time for the fboundp check
"Ignore all arguments." ;; since definitions have been moved around. The cl-lib macros are
nil) ;; needed by compatibility definitions.
(require 'subr-x)
(require 'cl-lib)
(defvar compat--inhibit-prefixed nil (defvar compat-macs--version nil
"Non-nil means that prefixed definitions are not loaded. "Version of the currently defined compatibility definitions.")
A prefixed function is something like `compat-assoc', that is
only made visible when the respective compatibility version file
is loaded (in this case `compat-26').")
(defmacro compat--inhibit-prefixed (&rest body) (defun compat-macs--strict (cond &rest error)
"Ignore BODY unless `compat--inhibit-prefixed' is true." "Assert strict COND, otherwise fail with ERROR."
`(unless (bound-and-true-p compat--inhibit-prefixed) (when (bound-and-true-p compat-strict)
,@body)) (apply #'compat-macs--assert cond error)))
(defvar compat-current-version nil (defun compat-macs--assert (cond &rest error)
"Default version to use when no explicit version was given.") "Assert COND, otherwise fail with ERROR."
(unless cond (apply #'error error)))
(defmacro compat-declare-version (version) (defun compat-macs--docstring (type name docstring)
"Set the Emacs version that is currently being handled to VERSION." "Format DOCSTRING for NAME of TYPE.
;; FIXME: Avoid setting the version for any definition that might Prepend compatibility notice to the actual documentation string."
;; follow, but try to restrict it to the current file/buffer. (with-temp-buffer
(setq compat-current-version version) (insert
nil)
(defvar compat--generate-function #'compat--generate-default
"Function used to generate compatibility code.
The function must take six arguments: NAME, DEF-FN, INSTALL-FN,
CHECK-FN, ATTR and TYPE. The resulting body is constructed by
invoking the functions DEF-FN (passed the \"realname\" and the
version number, returning the compatibility definition), the
INSTALL-FN (passed the \"realname\" and returning the
installation code), CHECK-FN (passed the \"realname\" and
returning a check to see if the compatibility definition should
be installed). ATTR is a plist used to modify the generated
code. The following attributes are handled, all others are
ignored:
- :min-version :: Prevent the compatibility definition from begin
installed in versions older than indicated (string).
- :max-version :: Prevent the compatibility definition from begin
installed in versions newer than indicated (string).
- :feature :: The library the code is supposed to be loaded
with (via `eval-after-load').
- :cond :: Only install the compatibility code, iff the value
evaluates to non-nil.
For prefixed functions, this can be interpreted as a test to
`defalias' an existing definition or not.
- :no-highlight :: Do not highlight this definition as
compatibility function.
- :version :: Manual specification of the version the compatee
code was defined in (string).
- :realname :: Manual specification of a \"realname\" to use for
the compatibility definition (symbol).
- :notes :: Additional notes that a developer using this
compatibility function should keep in mind.
- :prefix :: Add a `compat-' prefix to the name, and define the
compatibility code unconditionally.
TYPE is used to set the symbol property `compat-type' for NAME.")
(defun compat--generate-default (name def-fn install-fn check-fn attr type)
"Generate a leaner compatibility definition.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(let* ((min-version (plist-get attr :min-version))
(max-version (plist-get attr :max-version))
(feature (plist-get attr :feature))
(cond (plist-get attr :cond))
(version (or (plist-get attr :version)
compat-current-version))
(realname (or (plist-get attr :realname)
(intern (format "compat--%S" name))))
(check (cond
((or (and min-version
(version< emacs-version min-version))
(and max-version
(version< max-version emacs-version)))
'(compat--ignore))
((plist-get attr :prefix)
'(compat--inhibit-prefixed))
((and version (version<= version emacs-version) (not cond))
'(compat--ignore))
(`(when (and ,(if cond cond t)
,(funcall check-fn)))))))
(cond
((and (plist-get attr :prefix) (memq type '(func macro))
(string-match "\\`compat-\\(.+\\)\\'" (symbol-name name))
(let* ((actual-name (intern (match-string 1 (symbol-name name))))
(body (funcall install-fn actual-name version)))
(when (and (version<= version emacs-version)
(fboundp actual-name))
`(,@check
,(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
((plist-get attr :realname)
`(progn
,(funcall def-fn realname version)
(,@check
,(let ((body (funcall install-fn realname version)))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body)))))
((let* ((body (if (eq type 'advice)
`(,@check
,(funcall def-fn realname version)
,(funcall install-fn realname version))
`(,@check ,(funcall def-fn name version)))))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
(defun compat-generate-common (name def-fn install-fn check-fn attr type)
"Common code for generating compatibility definitions.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(when (and (plist-get attr :cond) (plist-get attr :prefix))
(error "A prefixed function %s cannot have a condition" name))
(funcall compat--generate-function
name def-fn install-fn check-fn attr type))
(defun compat-common-fdefine (type name arglist docstring rest)
"Generate compatibility code for a function NAME.
TYPE is one of `func', for functions and `macro' for macros, and
`advice' ARGLIST is passed on directly to the definition, and
DOCSTRING is prepended with a compatibility note. REST contains
the remaining definition, that may begin with a property list of
attributes (see `compat-generate-common')."
(let ((oldname name) (body rest))
(while (keywordp (car body))
(setq body (cddr body)))
;; It might be possible to set these properties otherwise. That
;; should be looked into and implemented if it is the case.
(when (and (listp (car-safe body)) (eq (caar body) 'declare))
(when (version<= emacs-version "25")
(delq (assq 'side-effect-free (car body)) (car body))
(delq (assq 'pure (car body)) (car body))))
;; Check if we want an explicitly prefixed function
(when (plist-get rest :prefix)
(setq name (intern (format "compat-%s" name))))
(compat-generate-common
name
(lambda (realname version)
`(,(cond
((memq type '(func advice)) 'defun)
((eq type 'macro) 'defmacro)
((error "Unknown type")))
,realname ,arglist
;; Prepend compatibility notice to the actual
;; documentation string.
,(let ((type (cond
((eq type 'func) "function")
((eq type 'macro) "macro")
((eq type 'advice) "advice")
((error "Unknown type")))))
(if version
(format (format
"[Compatibility %s for `%S', defined in Emacs %s]\n\n%s" "[Compatibility %s for `%s', defined in Emacs %s. \
type oldname version docstring) See (compat) Emacs %s' for more details.]\n\n%s"
(format type name compat-macs--version compat-macs--version docstring))
"[Compatibility %s for `%S']\n\n%s" (let ((fill-column 80))
type oldname docstring))) (fill-region (point-min) (point-max)))
;; Advice may use the implicit variable `oldfun', but (buffer-string)))
;; to avoid triggering the byte compiler, we make
;; sure the argument is used at least once. (defun compat-macs--check-attributes (attrs preds)
,@(if (eq type 'advice) "Check ATTRS given PREDS predicate plist and return rest."
(cons '(ignore oldfun) body) (while (keywordp (car attrs))
body))) (compat-macs--assert (cdr attrs) "Attribute list length is odd")
(lambda (realname _version) (compat-macs--assert (let ((p (plist-get preds (car attrs))))
(cond (and p (or (eq p t) (funcall p (cadr attrs)))))
((memq type '(func macro)) "Invalid attribute %s" (car attrs))
;; Functions and macros are installed by (setq attrs (cddr attrs)))
;; aliasing the name of the compatible attrs)
;; function to the name of the compatibility
;; function. (defun compat-macs--guard (attrs preds fun)
`(defalias ',name #',realname)) "Guard compatibility definition generation.
((eq type 'advice) The version constraints specified by ATTRS are checked. PREDS is
`(advice-add ',name :around #',realname)))) a plist of predicates for arguments which are passed to FUN."
(lambda () (declare (indent 2))
(cond (compat-macs--assert compat-macs--version "No `compat-version' was declared")
((memq type '(func macro)) (let* ((body (compat-macs--check-attributes
`(not (fboundp ',name))) attrs `(,@preds :feature symbolp)))
((eq type 'advice) t))) (feature (plist-get attrs :feature))
rest type))) (attrs `(:body ,body ,@attrs))
args)
;; Require feature at compile time
(when feature
(compat-macs--assert (not (eq feature 'subr-x)) "Invalid feature subr-x")
(require feature))
;; The current Emacs must be older than the currently declared version.
(when (version< emacs-version compat-macs--version)
(while preds
(push (plist-get attrs (car preds)) args)
(setq preds (cddr preds)))
(setq body (apply fun (nreverse args)))
(if (and feature body)
`(with-eval-after-load ',feature ,@body)
(macroexp-progn body)))))
(defun compat-macs--defun (type name arglist docstring rest)
"Define function NAME of TYPE with ARGLIST and DOCSTRING.
REST are attributes and the function BODY."
(compat-macs--guard
rest (list :extended (lambda (x) (or (booleanp x) (version-to-list x)))
:obsolete (lambda (x) (or (booleanp x) (stringp x)))
:body t)
(lambda (extended obsolete body)
(when (stringp extended)
(compat-macs--assert
(and (version< extended compat-macs--version) (version< "24.4" extended))
"Invalid :extended version %s for %s %s" extended type name)
(setq extended (version<= extended emacs-version)))
(compat-macs--strict (eq extended (fboundp name))
"Wrong :extended flag for %s %s" type name)
;; Remove unsupported declares. It might be possible to set these
;; properties otherwise. That should be looked into and implemented
;; if it is the case.
(when (and (listp (car-safe body)) (eq (caar body) 'declare) (<= emacs-major-version 25))
(setcar body (assq-delete-all 'pure (assq-delete-all
'side-effect-free (car body)))))
;; Use `:extended' name if the function is already defined.
(let* ((defname (if (and extended (fboundp name))
(intern (format "compat--%s" name))
name))
(def `(,(if (memq '&key arglist)
(if (eq type 'macro) 'cl-defmacro 'cl-defun)
(if (eq type 'macro) 'defmacro 'defun))
,defname ,arglist
,(compat-macs--docstring type name docstring)
,@body)))
`(,@(if (eq defname name)
;; An additional fboundp check is performed at runtime to make
;; sure that we never redefine an existing definition if Compat
;; is loaded on a newer Emacs version. Declare the function,
;; such that the byte compiler does not complain about possibly
;; missing functions at runtime. The warnings are generated due
;; to the fboundp check.
`((declare-function ,name nil)
(unless (fboundp ',name) ,def))
(list def))
,@(when obsolete
`((make-obsolete
',defname ,(if (stringp obsolete) obsolete "No substitute")
,compat-macs--version))))))))
(defmacro compat-guard (cond &rest rest)
"Guard definition with a runtime COND and a version check.
The runtime condition must make sure that no definition is
overriden. REST is an attribute plist followed by the definition
body. The attributes specify the conditions under which the
definition is generated.
- :feature :: Wrap the definition with `with-eval-after-load' for
the given feature."
(declare (debug ([&rest keywordp sexp] def-body))
(indent 1))
(compat-macs--guard rest '(:body t)
(lambda (body)
(compat-macs--assert body "The guarded body is empty")
(if (eq cond t)
body
(compat-macs--strict (eval cond t) "Guard %S failed" cond)
`((when ,cond ,@body))))))
(defmacro compat-defalias (name def &rest attrs)
"Define compatibility alias NAME as DEF.
ATTRS is a plist of attributes, which specify the conditions
under which the definition is generated.
- :obsolete :: Mark the alias as obsolete if t.
- :feature :: See `compat-guard'."
(declare (debug (name symbolp [&rest keywordp sexp])))
(compat-macs--guard attrs '(:obsolete booleanp)
(lambda (obsolete)
(compat-macs--strict (not (fboundp name)) "%s already defined" name)
;; The fboundp check is performed at runtime to make sure that we never
;; redefine an existing definition if Compat is loaded on a newer Emacs
;; version.
`((unless (fboundp ',name)
(defalias ',name ',def
,(compat-macs--docstring 'function name
(get name 'function-documentation)))
,@(when obsolete
`((make-obsolete ',name ',def ,compat-macs--version))))))))
(defmacro compat-defun (name arglist docstring &rest rest) (defmacro compat-defun (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility function. "Define compatibility function NAME with arguments ARGLIST.
The function must be documented in DOCSTRING. REST may begin The function must be documented in DOCSTRING. REST is an
with a plist, that is interpreted by the macro but not passed on attribute plist followed by the function body. The attributes
to the actual function. See `compat-generate-common' for a specify the conditions under which the definition is generated.
listing of attributes.
The definition will only be installed, if the version this - :extended :: Mark the function as extended if t. The function
function was defined in, as indicated by the `:version' must be called explicitly via `compat-call'. This attribute
attribute, is greater than the current Emacs version." should be used for functions which extend already existing
functions, e.g., functions which changed their calling
convention or their behavior. The value can also be a version
string, which specifies the Emacs version when the original
version of the function was introduced.
- :obsolete :: Mark the function as obsolete if t, can be a
string describing the obsoletion.
- :feature :: See `compat-guard'."
(declare (debug (&define name (&rest symbolp) (declare (debug (&define name (&rest symbolp)
stringp stringp
[&rest keywordp sexp] [&rest keywordp sexp]
def-body)) def-body))
(doc-string 3) (indent 2)) (doc-string 3) (indent 2))
(compat-common-fdefine 'func name arglist docstring rest)) (compat-macs--defun 'function name arglist docstring rest))
(defmacro compat-defmacro (name arglist docstring &rest rest) (defmacro compat-defmacro (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility macro. "Define compatibility macro NAME with arguments ARGLIST.
The macro must be documented in DOCSTRING. REST may begin The macro must be documented in DOCSTRING. REST is an attribute
with a plist, that is interpreted by this macro but not passed on plist followed by the macro body. See `compat-defun' for
to the actual macro. See `compat-generate-common' for a details."
listing of attributes.
The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2)) (declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'macro name arglist docstring rest)) (compat-macs--defun 'macro name arglist docstring rest))
(defmacro compat-advise (name arglist docstring &rest rest) (defmacro compat-defvar (name initval docstring &rest attrs)
"Define NAME with arguments ARGLIST as a compatibility advice. "Define compatibility variable NAME with initial value INITVAL.
The advice function must be documented in DOCSTRING. REST may The variable must be documented in DOCSTRING. ATTRS is a plist
begin with a plist, that is interpreted by this macro but not of attributes, which specify the conditions under which the
passed on to the actual advice function. See definition is generated.
`compat-generate-common' for a listing of attributes. The advice
wraps the old definition, that is accessible via using the symbol
`oldfun'.
The advice will only be installed, if the version this function - :constant :: Mark the variable as constant if t.
was defined in, as indicated by the `:version' attribute, is
greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest))
(defmacro compat-defvar (name initval docstring &rest attr) - :local :: Make the variable buffer-local if t. If the value is
"Declare compatibility variable NAME with initial value INITVAL. `permanent' make the variable additionally permanently local.
The obligatory documentation string DOCSTRING must be given.
The remaining arguments ATTR form a plist, modifying the - :obsolete :: Mark the variable as obsolete if t, can be a
behaviour of this macro. See `compat-generate-common' for a string describing the obsoletion.
listing of attributes. Furthermore, `compat-defvar' also handles
the attribute `:local' that either makes the variable permanent - :feature :: See `compat-guard'."
local with a value of `permanent' or just buffer local with any
non-nil value."
(declare (debug (name form stringp [&rest keywordp sexp])) (declare (debug (name form stringp [&rest keywordp sexp]))
(doc-string 3) (indent 2)) (doc-string 3) (indent 2))
;; Check if we want an explicitly prefixed function (compat-macs--guard
(let ((oldname name)) attrs (list :constant #'booleanp
(when (plist-get attr :prefix) :local (lambda (x) (memq x '(nil t permanent)))
(setq name (intern (format "compat-%s" name)))) :obsolete (lambda (x) (or (booleanp x) (stringp x))))
(compat-generate-common (lambda (constant local obsolete)
name (compat-macs--strict (not (boundp name)) "%s already defined" name)
(lambda (realname version) (compat-macs--assert (not (and constant local)) "Both :constant and :local")
(let ((localp (plist-get attr :local))) ;; The boundp check is performed at runtime to make sure that we never
`(progn ;; redefine an existing definition if Compat is loaded on a newer Emacs
(,(if (plist-get attr :constant) 'defconst 'defvar) ;; version.
,realname ,initval `((unless (boundp ',name)
;; Prepend compatibility notice to the actual (,(if constant 'defconst 'defvar)
;; documentation string. ,name ,initval
,(if version ,(compat-macs--docstring 'variable name docstring))
(format ,@(when obsolete
"[Compatibility variable for `%S', defined in Emacs %s]\n\n%s" `((make-obsolete-variable
oldname version docstring) ',name ,(if (stringp obsolete) obsolete "No substitute")
(format ,compat-macs--version))))
"[Compatibility variable for `%S']\n\n%s" ,@(and local `((make-variable-buffer-local ',name)))
oldname docstring))) ,@(and (eq local 'permanent) `((put ',name 'permanent-local t)))))))
;; Make variable as local if necessary
,(cond (defmacro compat-version (version)
((eq localp 'permanent) "Set the Emacs version that is currently being handled to VERSION."
`(put ',realname 'permanent-local t)) (setq compat-macs--version version)
(localp nil)
`(make-variable-buffer-local ',realname))))))
(lambda (realname _version) (defmacro compat-require (feature version)
`(defvaralias ',name ',realname)) "Require FEATURE if the Emacs version is less than VERSION."
(lambda () (when (version< emacs-version version)
`(not (boundp ',name))) (require feature)
attr 'variable))) `(require ',feature)))
(provide 'compat-macs) (provide 'compat-macs)
;;; compat-macs.el ends here ;;; compat-macs.el ends here

2
lisp/compat/compat-pkg.el
View File

@@ -1,2 +1,2 @@
;; Generated package description from compat.el -*- no-byte-compile: t -*- ;; Generated package description from compat.el -*- no-byte-compile: t -*-
(define-package "compat" "28.1.2.2" "Emacs Lisp Compatibility Library" '((emacs "24.3") (nadvice "0.3")) :commit "d533692182c084bad623977b69f9dc298255eaab" :authors '(("Philip Kaludercic" . "philipk@posteo.net")) :maintainer '("Compat Development" . "~pkal/compat-devel@lists.sr.ht") :keywords '("lisp") :url "https://sr.ht/~pkal/compat") (define-package "compat" "29.1.4.2" "Emacs Lisp Compatibility Library" '((emacs "24.4") (seq "2.3")) :commit "74300f16a1630a33a86710aa20c1fc26f5f89f75" :authors '(("Philip Kaludercic" . "philipk@posteo.net") ("Daniel Mendler" . "mail@daniel-mendler.de")) :maintainer '(("Daniel Mendler" . "mail@daniel-mendler.de") ("Compat Development" . "~pkal/compat-devel@lists.sr.ht")) :keywords '("lisp" "maint") :url "https://github.com/emacs-compat/compat")

97
lisp/compat/compat.el
View File

@@ -1,13 +1,13 @@
;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*- ;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net> ;; Author: Philip Kaludercic <philipk@posteo.net>, Daniel Mendler <mail@daniel-mendler.de>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht> ;; Maintainer: Daniel Mendler <mail@daniel-mendler.de>, Compat Development <~pkal/compat-devel@lists.sr.ht>
;; Version: 28.1.2.2 ;; Version: 29.1.4.2
;; URL: https://sr.ht/~pkal/compat ;; URL: https://github.com/emacs-compat/compat
;; Package-Requires: ((emacs "24.3") (nadvice "0.3")) ;; Package-Requires: ((emacs "24.4") (seq "2.3"))
;; Keywords: lisp ;; Keywords: lisp, maint
;; 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
@@ -24,35 +24,70 @@
;;; Commentary: ;;; Commentary:
;; To allow for the usage of Emacs functions and macros that are ;; Compat is the Elisp forwards compatibility library, which provides
;; defined in newer versions of Emacs, compat.el provides definitions ;; definitions introduced in newer Emacs versions. The definitions
;; that are installed ONLY if necessary. These reimplementations of ;; are only installed if necessary for your current Emacs version. If
;; functions and macros are at least subsets of the actual ;; Compat is compiled on a recent version of Emacs, all of the
;; implementations. Be sure to read the documentation string to make ;; definitions are disabled at compile time, such that no negative
;; sure. ;; performance impact is incurred. The provided compatibility
;; implementations of functions and macros are at least subsets of the
;; actual implementations. Be sure to read the documentation string
;; and the Compat manual.
;; ;;
;; Not every function provided in newer versions of Emacs is provided ;; Not every function provided in newer versions of Emacs is provided
;; here. Some depend on new features from the core, others cannot be ;; here. Some depend on new features from the C core, others cannot
;; implemented to a meaningful degree. Please consult the Compat ;; be implemented to a meaningful degree. Please consult the Compat
;; manual for details. The main audience for this library are not ;; manual for details regarding the usage of the Compat library and
;; regular users, but package maintainers. Therefore commands and ;; the provided functionality.
;; user options are usually not implemented here.
;; The main audience for this library are not regular users, but
;; package maintainers. Therefore no commands, user-facing modes or
;; user options are implemented here.
;;; Code: ;;; Code:
(defvar compat--inhibit-prefixed) ;; Ensure that the newest compatibility layer is required at compile
(let ((compat--inhibit-prefixed (not (bound-and-true-p compat-testing)))) ;; time and runtime, but only if needed.
;; Instead of using `require', we manually check `features' and call (eval-when-compile
;; `load' to avoid the issue of not using `provide' at the end of (defmacro compat--maybe-require-29 ()
;; the file (which is disabled by `compat--inhibit-prefixed', so (when (version< emacs-version "29.1")
;; that the file can be loaded again at some later point when the (require 'compat-29)
;; prefixed definitions are needed). '(require 'compat-29))))
(dolist (vers '(24 25 26 27 28)) (compat--maybe-require-29)
(unless (memq (intern (format "compat-%d" vers)) features)
(load (format "compat-%d%s" vers ;;;; Macros for extended compatibility function calls
(if (bound-and-true-p compat-testing)
".el" "")) (defmacro compat-function (fun)
nil t)))) "Return compatibility function symbol for FUN.
If the Emacs version provides a sufficiently recent version of
FUN, the symbol FUN is returned itself. Otherwise the macro
returns the symbol of a compatibility function which supports the
behavior and calling convention of the current stable Emacs
version. For example Compat 29.1 will provide compatibility
functions which implement the behavior and calling convention of
Emacs 29.1.
See also `compat-call' to directly call compatibility functions."
(let ((compat (intern (format "compat--%s" fun))))
`#',(if (fboundp compat) compat fun)))
(defmacro compat-call (fun &rest args)
"Call compatibility function or macro FUN with ARGS.
A good example function is `plist-get' which was extended with an
additional predicate argument in Emacs 29.1. The compatibility
function, which supports this additional argument, can be
obtained via (compat-function plist-get) and called
via (compat-call plist-get plist prop predicate). It is not
possible to directly call (plist-get plist prop predicate) on
Emacs older than 29.1, since the original `plist-get' function
does not yet support the predicate argument. Note that the
Compat library never overrides existing functions.
See also `compat-function' to lookup compatibility functions."
(let ((compat (intern (format "compat--%s" fun))))
`(,(if (fboundp compat) compat fun) ,@args)))
(provide 'compat) (provide 'compat)
;;; compat.el ends here ;;; compat.el ends here

2540
lisp/compat/compat.info
View File

File diff suppressed because it is too large Load Diff

16
lisp/counsel/counsel-pkg.el Normal file
View File

@@ -0,0 +1,16 @@
(define-package "counsel" "20231025.2311" "Various completion functions using Ivy"
'((emacs "24.5")
(ivy "0.14.2")
(swiper "0.14.2"))
:commit "8c30f4cab5948aa8d942a3b2bbf5fb6a94d9441d" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainers
'(("Basil L. Contovounesios" . "contovob@tcd.ie"))
:maintainer
'("Basil L. Contovounesios" . "contovob@tcd.ie")
:keywords
'("convenience" "matching" "tools")
:url "https://github.com/abo-abo/swiper")
;; Local Variables:
;; no-byte-compile: t
;; End:

34
lisp/counsel.el → lisp/counsel/counsel.el
View File

@@ -1,13 +1,12 @@
;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*- ;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Copyright (C) 2015-2023 Free Software Foundation, Inc.
;; Author: Oleh Krehel <ohwoeowho@gmail.com> ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; Maintainer: Basil L. Contovounesios <contovob@tcd.ie>
;; URL: https://github.com/abo-abo/swiper ;; URL: https://github.com/abo-abo/swiper
;; Package-Version: 20221015.936 ;; Version: 0.14.2
;; Package-Commit: b8be4913a661b557e0d3275726e36871556569d3 ;; Package-Requires: ((emacs "24.5") (ivy "0.14.2") (swiper "0.14.2"))
;; Version: 0.13.4
;; Package-Requires: ((emacs "24.5") (ivy "0.13.4") (swiper "0.13.4"))
;; Keywords: convenience, matching, tools ;; Keywords: convenience, matching, tools
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
@@ -4355,13 +4354,21 @@ Additional actions:\\<ivy-minibuffer-map>
("h" counsel-package-action-homepage "open package homepage"))) ("h" counsel-package-action-homepage "open package homepage")))
;;** `counsel-tmm' ;;** `counsel-tmm'
(defvar tmm-km-list nil) (declare-function tmm-get-keymap "tmm" (elt &optional in-x-menu))
(declare-function tmm-get-keymap "tmm") (declare-function tmm--completion-table "tmm" (items))
(declare-function tmm--completion-table "tmm")
(declare-function tmm-get-keybind "tmm") (defalias 'counsel--menu-keymap
;; Added in Emacs 28.1.
(if (fboundp 'menu-bar-keymap)
#'menu-bar-keymap
(autoload 'tmm-get-keybind "tmm")
(declare-function tmm-get-keybind "tmm" (keyseq))
(lambda () (tmm-get-keybind [menu-bar])))
"Compatibility shim for `menu-bar-keymap'.")
(defun counsel-tmm-prompt (menu) (defun counsel-tmm-prompt (menu)
"Select and call an item from the MENU keymap." "Select and call an item from the MENU keymap."
(defvar tmm-km-list)
(let (out (let (out
choice choice
chosen-string) chosen-string)
@@ -4379,16 +4386,15 @@ Additional actions:\\<ivy-minibuffer-map>
(setq last-command-event chosen-string) (setq last-command-event chosen-string)
(call-interactively choice))))) (call-interactively choice)))))
(defvar tmm-table-undef)
;;;###autoload ;;;###autoload
(defun counsel-tmm () (defun counsel-tmm ()
"Text-mode emulation of looking and choosing from a menu bar." "Text-mode emulation of looking and choosing from a menu bar."
(interactive) (interactive)
(require 'tmm) (require 'tmm)
(defvar tmm-table-undef)
(run-hooks 'menu-bar-update-hook) (run-hooks 'menu-bar-update-hook)
(setq tmm-table-undef nil) (setq tmm-table-undef nil)
(counsel-tmm-prompt (tmm-get-keybind [menu-bar]))) (counsel-tmm-prompt (counsel--menu-keymap)))
;;** `counsel-yank-pop' ;;** `counsel-yank-pop'
(defcustom counsel-yank-pop-truncate-radius 2 (defcustom counsel-yank-pop-truncate-radius 2
@@ -6120,7 +6126,7 @@ This function always returns its elements in a stable order."
(when (file-exists-p dir) (when (file-exists-p dir)
(let ((dir (file-name-as-directory dir))) (let ((dir (file-name-as-directory dir)))
;; Function `directory-files-recursively' added in Emacs 25.1. ;; Function `directory-files-recursively' added in Emacs 25.1.
(dolist (file (directory-files-recursively dir ".*\\.desktop$")) (dolist (file (directory-files-recursively dir "\\.desktop\\'"))
(let ((id (subst-char-in-string ?/ ?- (file-relative-name file dir)))) (let ((id (subst-char-in-string ?/ ?- (file-relative-name file dir))))
(when (and (not (gethash id hash)) (file-readable-p file)) (when (and (not (gethash id hash)) (file-readable-p file))
(push (cons id file) result) (push (cons id file) result)
@@ -6867,7 +6873,7 @@ Additional actions:\\<ivy-minibuffer-map>
"https://duckduckgo.com/html/?q=" "https://duckduckgo.com/html/?q="
counsel--search-request-data-ddg)) counsel--search-request-data-ddg))
"Search engine parameters for `counsel-search'." "Search engine parameters for `counsel-search'."
:type '(list)) :type '(alist :key-type symbol :value-type (list string string function)))
(defun counsel--search-request-data-google (data) (defun counsel--search-request-data-google (data)
(mapcar #'identity (aref data 1))) (mapcar #'identity (aref data 1)))

15
lisp/ctable/ctable-pkg.el Normal file
View File

@@ -0,0 +1,15 @@
(define-package "ctable" "20210128.629" "Table component for Emacs Lisp"
'((emacs "24.3")
(cl-lib "0.5"))
:commit "48b73742757a3ae5736d825fe49e00034cc453b5" :authors
'(("SAKURAI Masashi" . "m.sakuraiatkiwanami.net"))
:maintainers
'(("SAKURAI Masashi" . "m.sakuraiatkiwanami.net"))
:maintainer
'("SAKURAI Masashi" . "m.sakuraiatkiwanami.net")
:keywords
'("table")
:url "https://github.com/kiwanami/emacs-ctable")
;; Local Variables:
;; no-byte-compile: t
;; End:

2
lisp/ctable.el → lisp/ctable/ctable.el
View File

@@ -4,8 +4,6 @@
;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net> ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
;; URL: https://github.com/kiwanami/emacs-ctable ;; URL: https://github.com/kiwanami/emacs-ctable
;; Package-Version: 20210128.629
;; Package-Commit: 48b73742757a3ae5736d825fe49e00034cc453b5
;; Version: 0.1.3 ;; Version: 0.1.3
;; Package-Requires: ((emacs "24.3") (cl-lib "0.5")) ;; Package-Requires: ((emacs "24.3") (cl-lib "0.5"))
;; Keywords: table ;; Keywords: table

6
lisp/dash/dash-pkg.el
View File

@@ -1,6 +1,8 @@
(define-package "dash" "20221013.836" "A modern list library for Emacs" (define-package "dash" "20230714.723" "A modern list library for Emacs"
'((emacs "24")) '((emacs "24"))
:commit "3df46d7d9fe74f52a661565888e4d31fd760f0df" :authors :commit "f46268c75cb7c18361d3cee942cd4dc14a03aef4" :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")

433
lisp/dash/dash.el
View File

File diff suppressed because it is too large Load Diff

722
lisp/dash/dash.info
View File

@@ -1,8 +1,8 @@
This is dash.info, produced by makeinfo version 7.0.1 from dash.texi. This is dash.info, produced by makeinfo version 6.8 from dash.texi.
This manual is for Dash version 2.19.1. This manual is for Dash version 2.19.1.
Copyright © 2012–2021 Free Software Foundation, Inc. Copyright © 2012–2023 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License, document under the terms of the GNU Free Documentation License,
@@ -24,7 +24,7 @@ Dash
This manual is for Dash version 2.19.1. This manual is for Dash version 2.19.1.
Copyright © 2012–2021 Free Software Foundation, Inc. Copyright © 2012–2023 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License, document under the terms of the GNU Free Documentation License,
@@ -767,31 +767,42 @@ Functions returning a modified copy of the input list.
⇒ ("foo" "bar" 3 "quux") ⇒ ("foo" "bar" 3 "quux")
-- Function: -remove-at (n list) -- Function: -remove-at (n list)
Return a list with element at Nth position in LIST removed. Return LIST with its element at index N removed. That is, remove
any element selected as (nth N LIST) from LIST and return the
result.
This is a non-destructive operation: parts of LIST (but not
necessarily all of it) are copied as needed to avoid destructively
modifying it.
See also: ‘-remove-at-indices’ (*note -remove-at-indices::), See also: ‘-remove-at-indices’ (*note -remove-at-indices::),
‘-remove’ (*note -remove::) ‘-remove’ (*note -remove::).
(-remove-at 0 '("0" "1" "2" "3" "4" "5")) (-remove-at 0 '(a b c))
⇒ ("1" "2" "3" "4" "5") ⇒ (b c)
(-remove-at 1 '("0" "1" "2" "3" "4" "5")) (-remove-at 1 '(a b c))
⇒ ("0" "2" "3" "4" "5") ⇒ (a c)
(-remove-at 2 '("0" "1" "2" "3" "4" "5")) (-remove-at 2 '(a b c))
⇒ ("0" "1" "3" "4" "5") ⇒ (a b)
-- Function: -remove-at-indices (indices list) -- Function: -remove-at-indices (indices list)
Return a list whose elements are elements from LIST without Return LIST with its elements at INDICES removed. That is, for
elements selected as ‘(nth i list)‘ for all i from INDICES. each index I in INDICES, remove any element selected as (nth I
LIST) from LIST.
This is a non-destructive operation: parts of LIST (but not
necessarily all of it) are copied as needed to avoid destructively
modifying it.
See also: ‘-remove-at’ (*note -remove-at::), ‘-remove’ (*note See also: ‘-remove-at’ (*note -remove-at::), ‘-remove’ (*note
-remove::) -remove::).
(-remove-at-indices '(0) '("0" "1" "2" "3" "4" "5")) (-remove-at-indices '(0) '(a b c d e))
⇒ ("1" "2" "3" "4" "5") ⇒ (b c d e)
(-remove-at-indices '(0 2 4) '("0" "1" "2" "3" "4" "5")) (-remove-at-indices '(1 3) '(a b c d e))
⇒ ("1" "3" "5") ⇒ (a c e)
(-remove-at-indices '(0 5) '("0" "1" "2" "3" "4" "5")) (-remove-at-indices '(4 0 2) '(a b c d e))
⇒ ("1" "2" "3" "4") ⇒ (b d)
 
File: dash.info, Node: Reductions, Next: Unfolding, Prev: List to list, Up: Functions File: dash.info, Node: Reductions, Next: Unfolding, Prev: List to list, Up: Functions
@@ -1026,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)
@@ -1185,8 +1196,8 @@ than consuming a list to produce a single value.
⇒ (1 2 3 1 2) ⇒ (1 2 3 1 2)
(-take 7 (-cycle '(1 "and" 3))) (-take 7 (-cycle '(1 "and" 3)))
⇒ (1 "and" 3 1 "and" 3 1) ⇒ (1 "and" 3 1 "and" 3 1)
(-zip (-cycle '(1 2 3)) '(1 2)) (-zip-lists (-cycle '(3)) '(1 2))
⇒ ((1 . 1) (2 . 2)) ⇒ ((3 1) (3 2))
 
File: dash.info, Node: Predicates, Next: Partitioning, Prev: Unfolding, Up: Functions File: dash.info, Node: Predicates, Next: Partitioning, Prev: Unfolding, Up: Functions
@@ -1871,56 +1882,52 @@ Other list functions not fit to be classified elsewhere.
error→ Wrong type argument: natnump, -1 error→ Wrong type argument: natnump, -1
-- Function: -zip-with (fn list1 list2) -- Function: -zip-with (fn list1 list2)
Zip the two lists LIST1 and LIST2 using a function FN. This Zip LIST1 and LIST2 into a new list using the function FN. That
function is applied pairwise taking as first argument element of is, apply FN pairwise taking as first argument the next element of
LIST1 and as second argument element of LIST2 at corresponding LIST1 and as second argument the next element of LIST2 at the
position. corresponding position. The result is as long as the shorter list.
The anaphoric form ‘--zip-with’ binds the elements from LIST1 as This function’s anaphoric counterpart is ‘--zip-with’.
symbol ‘it’, and the elements from LIST2 as symbol ‘other’.
(-zip-with '+ '(1 2 3) '(4 5 6)) For other zips, see also ‘-zip-lists’ (*note -zip-lists::) and
⇒ (5 7 9) ‘-zip-fill’ (*note -zip-fill::).
(-zip-with 'cons '(1 2 3) '(4 5 6))
(-zip-with #'+ '(1 2 3 4) '(5 6 7))
⇒ (6 8 10)
(-zip-with #'cons '(1 2 3) '(4 5 6 7))
⇒ ((1 . 4) (2 . 5) (3 . 6)) ⇒ ((1 . 4) (2 . 5) (3 . 6))
(--zip-with (concat it " and " other) '("Batman" "Jekyll") '("Robin" "Hyde")) (--zip-with (format "%s & %s" it other) '(Batman Jekyll) '(Robin Hyde))
⇒ ("Batman and Robin" "Jekyll and Hyde") ⇒ ("Batman & Robin" "Jekyll & Hyde")
-- Function: -zip (&rest lists) -- Function: -zip-pair (list1 list2)
Zip LISTS together. Group the head of each list, followed by the Zip LIST1 and LIST2 together.
second elements of each list, and so on. The lengths of the
returned groupings are equal to the length of the shortest input
list.
If two lists are provided as arguments, return the groupings as a Make a pair with the head of each list, followed by a pair with the
list of cons cells. Otherwise, return the groupings as a list of second element of each list, and so on. The number of pairs
lists. returned is equal to the length of the shorter input list.
Use ‘-zip-lists’ (*note -zip-lists::) if you need the return value See also: ‘-zip-lists’ (*note -zip-lists::).
to always be a list of lists.
Alias: ‘-zip-pair’ (-zip-pair '(1 2 3 4) '(5 6 7))
⇒ ((1 . 5) (2 . 6) (3 . 7))
See also: ‘-zip-lists’ (*note -zip-lists::) (-zip-pair '(1 2 3) '(4 5 6))
(-zip '(1 2 3) '(4 5 6))
⇒ ((1 . 4) (2 . 5) (3 . 6)) ⇒ ((1 . 4) (2 . 5) (3 . 6))
(-zip '(1 2 3) '(4 5 6 7)) (-zip-pair '(1 2) '(3))
⇒ ((1 . 4) (2 . 5) (3 . 6)) ⇒ ((1 . 3))
(-zip '(1 2) '(3 4 5) '(6))
⇒ ((1 3 6))
-- Function: -zip-lists (&rest lists) -- Function: -zip-lists (&rest lists)
Zip LISTS together. Group the head of each list, followed by the Zip LISTS together.
second elements of each list, and so on. The lengths of the
returned groupings are equal to the length of the shortest input
list.
The return value is always list of lists, which is a difference Group the head of each list, followed by the second element of each
from ‘-zip-pair’ which returns a cons-cell in case two input lists list, and so on. The number of returned groupings is equal to the
are provided. length of the shortest input list, and the length of each grouping
is equal to the number of input LISTS.
See also: ‘-zip’ (*note -zip::) The return value is always a list of proper lists, in contrast to
‘-zip’ (*note -zip::) which returns a list of dotted pairs when
only two input LISTS are provided.
See also: ‘-zip-pair’ (*note -zip-pair::).
(-zip-lists '(1 2 3) '(4 5 6)) (-zip-lists '(1 2 3) '(4 5 6))
⇒ ((1 4) (2 5) (3 6)) ⇒ ((1 4) (2 5) (3 6))
@@ -1929,35 +1936,111 @@ Other list functions not fit to be classified elsewhere.
(-zip-lists '(1 2) '(3 4 5) '(6)) (-zip-lists '(1 2) '(3 4 5) '(6))
⇒ ((1 3 6)) ⇒ ((1 3 6))
-- Function: -zip-fill (fill-value &rest lists) -- Function: -zip-lists-fill (fill-value &rest lists)
Zip LISTS, with FILL-VALUE padded onto the shorter lists. The Zip LISTS together, padding shorter lists with FILL-VALUE. This is
lengths of the returned groupings are equal to the length of the like ‘-zip-lists’ (*note -zip-lists::) (which see), except it
longest input list. retains all elements at positions beyond the end of the shortest
list. The number of returned groupings is equal to the length of
the longest input list, and the length of each grouping is equal to
the number of input LISTS.
(-zip-fill 0 '(1 2 3 4 5) '(6 7 8 9)) (-zip-lists-fill 0 '(1 2) '(3 4 5) '(6))
⇒ ((1 . 6) (2 . 7) (3 . 8) (4 . 9) (5 . 0)) ⇒ ((1 3 6) (2 4 0) (0 5 0))
(-zip-lists-fill 0 '(1 2) '(3 4) '(5 6))
⇒ ((1 3 5) (2 4 6))
(-zip-lists-fill 0 '(1 2 3) nil)
⇒ ((1 0) (2 0) (3 0))
-- Function: -zip (&rest lists)
Zip LISTS together.
Group the head of each list, followed by the second element of each
list, and so on. The number of returned groupings is equal to the
length of the shortest input list, and the number of items in each
grouping is equal to the number of input LISTS.
If only two LISTS are provided as arguments, return the groupings
as a list of dotted pairs. Otherwise, return the groupings as a
list of proper lists.
Since the return value changes form depending on the number of
arguments, it is generally recommended to use ‘-zip-lists’ (*note
-zip-lists::) instead, or ‘-zip-pair’ (*note -zip-pair::) if a list
of dotted pairs is desired.
See also: ‘-unzip’ (*note -unzip::).
(-zip '(1 2 3 4) '(5 6 7) '(8 9))
⇒ ((1 5 8) (2 6 9))
(-zip '(1 2 3) '(4 5 6) '(7 8 9))
⇒ ((1 4 7) (2 5 8) (3 6 9))
(-zip '(1 2 3))
⇒ ((1) (2) (3))
-- Function: -zip-fill (fill-value &rest lists)
Zip LISTS together, padding shorter lists with FILL-VALUE. This is
like ‘-zip’ (*note -zip::) (which see), except it retains all
elements at positions beyond the end of the shortest list. The
number of returned groupings is equal to the length of the longest
input list, and the length of each grouping is equal to the number
of input LISTS.
Since the return value changes form depending on the number of
arguments, it is generally recommended to use ‘-zip-lists-fill’
(*note -zip-lists-fill::) instead, unless a list of dotted pairs is
explicitly desired.
(-zip-fill 0 '(1 2 3) '(4 5))
⇒ ((1 . 4) (2 . 5) (3 . 0))
(-zip-fill 0 () '(1 2 3))
⇒ ((0 . 1) (0 . 2) (0 . 3))
(-zip-fill 0 '(1 2) '(3 4) '(5 6))
⇒ ((1 3 5) (2 4 6))
-- Function: -unzip-lists (lists)
Unzip LISTS.
This works just like ‘-zip-lists’ (*note -zip-lists::) (which see),
but takes a list of lists instead of a variable number of
arguments, such that
(-unzip-lists (-zip-lists ARGS...))
is identity (given that the lists comprising ARGS are of the same
length).
(-unzip-lists (-zip-lists '(1 2) '(3 4) '(5 6)))
⇒ ((1 2) (3 4) (5 6))
(-unzip-lists '((1 2 3) (4 5) (6 7) (8 9)))
⇒ ((1 4 6 8) (2 5 7 9))
(-unzip-lists '((1 2 3) (4 5 6)))
⇒ ((1 4) (2 5) (3 6))
-- Function: -unzip (lists) -- Function: -unzip (lists)
Unzip LISTS. Unzip LISTS.
This works just like ‘-zip’ (*note -zip::) but takes a list of This works just like ‘-zip’ (*note -zip::) (which see), but takes a
lists instead of a variable number of arguments, such that list of lists instead of a variable number of arguments, such that
(-unzip (-zip L1 L2 L3 ...)) (-unzip (-zip L1 L2 L3 ...))
is identity (given that the lists are the same length). is identity (given that the lists are of the same length, and that
‘-zip’ (*note -zip::) is not called with two arguments, because of
the caveat described in its docstring).
Note in particular that calling this on a list of two lists will Note in particular that calling ‘-unzip’ (*note -unzip::) on a list
return a list of cons-cells such that the above identity works. of two lists will return a list of dotted pairs.
See also: ‘-zip’ (*note -zip::) Since the return value changes form depending on the number of
LISTS, it is generally recommended to use ‘-unzip-lists’ (*note
-unzip-lists::) instead.
(-unzip (-zip '(1 2 3) '(a b c) '("e" "f" "g"))) (-unzip (-zip '(1 2) '(3 4) '(5 6)))
⇒ ((1 2 3) (a b c) ("e" "f" "g")) ⇒ ((1 . 2) (3 . 4) (5 . 6))
(-unzip '((1 2) (3 4) (5 6) (7 8) (9 10))) (-unzip '((1 2 3) (4 5 6)))
⇒ ((1 3 5 7 9) (2 4 6 8 10)) ⇒ ((1 . 4) (2 . 5) (3 . 6))
(-unzip '((1 2) (3 4))) (-unzip '((1 2 3) (4 5) (6 7) (8 9)))
⇒ ((1 . 3) (2 . 4)) ⇒ ((1 4 6 8) (2 5 7 9))
-- Function: -pad (fill-value &rest lists) -- Function: -pad (fill-value &rest lists)
Pad each of LISTS with FILL-VALUE until they all have equal Pad each of LISTS with FILL-VALUE until they all have equal
@@ -2139,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)
@@ -2301,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 '(1 2 3)) (b (-clone a))) (nreverse a) b) (let* ((a (list (list 1))) (b (-clone a))) (setcar (car a) 2) b)
⇒ (1 2 3) ⇒ ((1))
 
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
@@ -3111,12 +3194,12 @@ Functions that manipulate and compose other functions.
(-compose (-partial #’nth n) (-prod f1 f2 ...)) = (-compose fn (-compose (-partial #’nth n) (-prod f1 f2 ...)) = (-compose fn
(-partial #’nth n)) (-partial #’nth n))
(funcall (-prodfn '1+ '1- 'number-to-string) '(1 2 3)) (funcall (-prodfn #'1+ #'1- #'number-to-string) '(1 2 3))
⇒ (2 1 "3") ⇒ (2 1 "3")
(-map (-prodfn '1+ '1-) '((1 2) (3 4) (5 6) (7 8))) (-map (-prodfn #'1- #'1+) '((1 2) (3 4) (5 6)))
⇒ ((2 1) (4 3) (6 5) (8 7)) ⇒ ((0 3) (2 5) (4 7))
(apply '+ (funcall (-prodfn 'length 'string-to-number) '((1 2 3) "15"))) (apply #'+ (funcall (-prodfn #'length #'string-to-number) '((t) "5")))
⇒ 18 ⇒ 6
 
File: dash.info, Node: Development, Next: FDL, Prev: Functions, Up: Top File: dash.info, Node: Development, Next: FDL, Prev: Functions, Up: Top
@@ -4424,7 +4507,7 @@ Index
(line 63) (line 63)
* -as->: Threading macros. (line 49) * -as->: Threading macros. (line 49)
* -butlast: Other list operations. * -butlast: Other list operations.
(line 333) (line 405)
* -clone: Tree operations. (line 123) * -clone: Tree operations. (line 123)
* -common-prefix: Reductions. (line 242) * -common-prefix: Reductions. (line 242)
* -common-suffix: Reductions. (line 252) * -common-suffix: Reductions. (line 252)
@@ -4458,17 +4541,17 @@ Index
* -elem-indices: Indexing. (line 23) * -elem-indices: Indexing. (line 23)
* -every: Predicates. (line 23) * -every: Predicates. (line 23)
* -fifth-item: Other list operations. * -fifth-item: Other list operations.
(line 308) (line 380)
* -filter: Sublist selection. (line 8) * -filter: Sublist selection. (line 8)
* -find-index: Indexing. (line 35) * -find-index: Indexing. (line 35)
* -find-indices: Indexing. (line 73) * -find-indices: Indexing. (line 73)
* -find-last-index: Indexing. (line 54) * -find-last-index: Indexing. (line 54)
* -first: Other list operations. * -first: Other list operations.
(line 228) (line 300)
* -first-item: Other list operations. * -first-item: Other list operations.
(line 256) (line 328)
* -fix: Other list operations. * -fix: Other list operations.
(line 373) (line 445)
* -fixfn: Function combinators. * -fixfn: Function combinators.
(line 224) (line 224)
* -flatten: List to list. (line 38) * -flatten: List to list. (line 38)
@@ -4476,7 +4559,7 @@ Index
* -flip: Function combinators. * -flip: Function combinators.
(line 95) (line 95)
* -fourth-item: Other list operations. * -fourth-item: Other list operations.
(line 295) (line 367)
* -frequencies: Reductions. (line 310) * -frequencies: Reductions. (line 310)
* -grade-down: Indexing. (line 103) * -grade-down: Indexing. (line 103)
* -grade-up: Indexing. (line 93) * -grade-up: Indexing. (line 93)
@@ -4503,13 +4586,13 @@ Index
* -keep: List to list. (line 8) * -keep: List to list. (line 8)
* -lambda: Binding. (line 247) * -lambda: Binding. (line 247)
* -last: Other list operations. * -last: Other list operations.
(line 246) (line 318)
* -last-item: Other list operations. * -last-item: Other list operations.
(line 321) (line 393)
* -let: Binding. (line 61) * -let: Binding. (line 61)
* -let*: Binding. (line 227) * -let*: Binding. (line 227)
* -list: Other list operations. * -list: Other list operations.
(line 356) (line 428)
* -map: Maps. (line 10) * -map: Maps. (line 10)
* -map-first: Maps. (line 38) * -map-first: Maps. (line 38)
* -map-indexed: Maps. (line 68) * -map-indexed: Maps. (line 68)
@@ -4530,7 +4613,7 @@ Index
* -orfn: Function combinators. * -orfn: Function combinators.
(line 167) (line 167)
* -pad: Other list operations. * -pad: Other list operations.
(line 169) (line 241)
* -partial: Function combinators. * -partial: Function combinators.
(line 8) (line 8)
* -partition: Partitioning. (line 90) * -partition: Partitioning. (line 90)
@@ -4558,7 +4641,7 @@ Index
* -reductions-r-from: Reductions. (line 118) * -reductions-r-from: Reductions. (line 118)
* -remove: Sublist selection. (line 26) * -remove: Sublist selection. (line 26)
* -remove-at: List to list. (line 151) * -remove-at: List to list. (line 151)
* -remove-at-indices: List to list. (line 164) * -remove-at-indices: List to list. (line 170)
* -remove-first: Sublist selection. (line 44) * -remove-first: Sublist selection. (line 44)
* -remove-item: Sublist selection. (line 84) * -remove-item: Sublist selection. (line 84)
* -remove-last: Sublist selection. (line 65) * -remove-last: Sublist selection. (line 65)
@@ -4577,7 +4660,7 @@ Index
* -running-sum: Reductions. (line 190) * -running-sum: Reductions. (line 190)
* -same-items?: Set operations. (line 88) * -same-items?: Set operations. (line 88)
* -second-item: Other list operations. * -second-item: Other list operations.
(line 269) (line 341)
* -select-by-indices: Sublist selection. (line 211) * -select-by-indices: Sublist selection. (line 211)
* -select-column: Sublist selection. (line 241) * -select-column: Sublist selection. (line 241)
* -select-columns: Sublist selection. (line 222) * -select-columns: Sublist selection. (line 222)
@@ -4591,7 +4674,7 @@ Index
* -some->: Threading macros. (line 62) * -some->: Threading macros. (line 62)
* -some->>: Threading macros. (line 74) * -some->>: Threading macros. (line 74)
* -sort: Other list operations. * -sort: Other list operations.
(line 343) (line 415)
* -splice: Maps. (line 102) * -splice: Maps. (line 102)
* -splice-list: Maps. (line 127) * -splice-list: Maps. (line 127)
* -split-at: Partitioning. (line 8) * -split-at: Partitioning. (line 8)
@@ -4600,15 +4683,15 @@ Index
* -split-with: Partitioning. (line 23) * -split-with: Partitioning. (line 23)
* -sum: Reductions. (line 180) * -sum: Reductions. (line 180)
* -table: Other list operations. * -table: Other list operations.
(line 184) (line 256)
* -table-flat: Other list operations. * -table-flat: Other list operations.
(line 203) (line 275)
* -tails: Reductions. (line 232) * -tails: Reductions. (line 232)
* -take: Sublist selection. (line 121) * -take: Sublist selection. (line 121)
* -take-last: Sublist selection. (line 135) * -take-last: Sublist selection. (line 135)
* -take-while: Sublist selection. (line 177) * -take-while: Sublist selection. (line 177)
* -third-item: Other list operations. * -third-item: Other list operations.
(line 282) (line 354)
* -tree-map: Tree operations. (line 28) * -tree-map: Tree operations. (line 28)
* -tree-map-nodes: Tree operations. (line 39) * -tree-map-nodes: Tree operations. (line 39)
* -tree-mapreduce: Tree operations. (line 85) * -tree-mapreduce: Tree operations. (line 85)
@@ -4619,16 +4702,22 @@ Index
* -unfold: Unfolding. (line 25) * -unfold: Unfolding. (line 25)
* -union: Set operations. (line 8) * -union: Set operations. (line 8)
* -unzip: Other list operations. * -unzip: Other list operations.
(line 147) (line 215)
* -unzip-lists: Other list operations.
(line 196)
* -update-at: List to list. (line 137) * -update-at: List to list. (line 137)
* -when-let: Binding. (line 9) * -when-let: Binding. (line 9)
* -when-let*: Binding. (line 21) * -when-let*: Binding. (line 21)
* -zip: Other list operations. * -zip: Other list operations.
(line 96) (line 150)
* -zip-fill: Other list operations. * -zip-fill: Other list operations.
(line 139) (line 176)
* -zip-lists: Other list operations. * -zip-lists: Other list operations.
(line 120) (line 114)
* -zip-lists-fill: Other list operations.
(line 135)
* -zip-pair: Other list operations.
(line 98)
* -zip-with: Other list operations. * -zip-with: Other list operations.
(line 80) (line 80)
* dash-fontify-mode: Fontification of special variables. * dash-fontify-mode: Fontification of special variables.
@@ -4640,213 +4729,216 @@ Index
 
Tag Table: Tag Table:
Node: Top744 Node: Top742
Node: Installation2399 Node: Installation2397
Node: Using in a package3161 Node: Using in a package3159
Node: Fontification of special variables3506 Node: Fontification of special variables3504
Node: Info symbol lookup4296 Node: Info symbol lookup4294
Node: Functions4879 Node: Functions4877
Node: Maps6363 Node: Maps6361
Ref: -map6660 Ref: -map6658
Ref: -map-when7033 Ref: -map-when7031
Ref: -map-first7607 Ref: -map-first7605
Ref: -map-last8202 Ref: -map-last8200
Ref: -map-indexed8792 Ref: -map-indexed8790
Ref: -annotate9478 Ref: -annotate9476
Ref: -splice10082 Ref: -splice10080
Ref: -splice-list11157 Ref: -splice-list11155
Ref: -mapcat11616 Ref: -mapcat11614
Ref: -copy11989 Ref: -copy11987
Node: Sublist selection12177 Node: Sublist selection12175
Ref: -filter12370 Ref: -filter12368
Ref: -remove12923 Ref: -remove12921
Ref: -remove-first13472 Ref: -remove-first13470
Ref: -remove-last14320 Ref: -remove-last14318
Ref: -remove-item15050 Ref: -remove-item15048
Ref: -non-nil15450 Ref: -non-nil15448
Ref: -slice15732 Ref: -slice15730
Ref: -take16261 Ref: -take16259
Ref: -take-last16679 Ref: -take-last16677
Ref: -drop17116 Ref: -drop17114
Ref: -drop-last17563 Ref: -drop-last17561
Ref: -take-while17995 Ref: -take-while17993
Ref: -drop-while18622 Ref: -drop-while18620
Ref: -select-by-indices19255 Ref: -select-by-indices19253
Ref: -select-columns19766 Ref: -select-columns19764
Ref: -select-column20469 Ref: -select-column20467
Node: List to list20932 Node: List to list20930
Ref: -keep21124 Ref: -keep21122
Ref: -concat21700 Ref: -concat21698
Ref: -flatten22228 Ref: -flatten22226
Ref: -flatten-n22990 Ref: -flatten-n22988
Ref: -replace23374 Ref: -replace23372
Ref: -replace-first23835 Ref: -replace-first23833
Ref: -replace-last24330 Ref: -replace-last24328
Ref: -insert-at24818 Ref: -insert-at24816
Ref: -replace-at25143 Ref: -replace-at25141
Ref: -update-at25530 Ref: -update-at25528
Ref: -remove-at26071 Ref: -remove-at26069
Ref: -remove-at-indices26556 Ref: -remove-at-indices26696
Node: Reductions27135 Node: Reductions27386
Ref: -reduce-from27331 Ref: -reduce-from27582
Ref: -reduce-r-from28055 Ref: -reduce-r-from28306
Ref: -reduce29318 Ref: -reduce29569
Ref: -reduce-r30069 Ref: -reduce-r30320
Ref: -reductions-from31347 Ref: -reductions-from31598
Ref: -reductions-r-from32153 Ref: -reductions-r-from32404
Ref: -reductions32983 Ref: -reductions33234
Ref: -reductions-r33694 Ref: -reductions-r33945
Ref: -count34439 Ref: -count34690
Ref: -sum34669 Ref: -sum34920
Ref: -running-sum34857 Ref: -running-sum35108
Ref: -product35178 Ref: -product35429
Ref: -running-product35386 Ref: -running-product35637
Ref: -inits35727 Ref: -inits35978
Ref: -tails35972 Ref: -tails36223
Ref: -common-prefix36216 Ref: -common-prefix36468
Ref: -common-suffix36510 Ref: -common-suffix36762
Ref: -min36804 Ref: -min37056
Ref: -min-by37030 Ref: -min-by37282
Ref: -max37551 Ref: -max37803
Ref: -max-by37776 Ref: -max-by38028
Ref: -frequencies38302 Ref: -frequencies38554
Node: Unfolding38917 Node: Unfolding39169
Ref: -iterate39158 Ref: -iterate39410
Ref: -unfold39605 Ref: -unfold39857
Ref: -repeat40410 Ref: -repeat40662
Ref: -cycle40694 Ref: -cycle40946
Node: Predicates41093 Node: Predicates41343
Ref: -some41270 Ref: -some41520
Ref: -every41699 Ref: -every41949
Ref: -any?42413 Ref: -any?42663
Ref: -all?42762 Ref: -all?43012
Ref: -none?43504 Ref: -none?43754
Ref: -only-some?43824 Ref: -only-some?44074
Ref: -contains?44369 Ref: -contains?44619
Ref: -is-prefix?44875 Ref: -is-prefix?45125
Ref: -is-suffix?45207 Ref: -is-suffix?45457
Ref: -is-infix?45539 Ref: -is-infix?45789
Ref: -cons-pair?45899 Ref: -cons-pair?46149
Node: Partitioning46230 Node: Partitioning46480
Ref: -split-at46418 Ref: -split-at46668
Ref: -split-with47082 Ref: -split-with47332
Ref: -split-on47722 Ref: -split-on47972
Ref: -split-when48393 Ref: -split-when48643
Ref: -separate49036 Ref: -separate49286
Ref: -partition49570 Ref: -partition49820
Ref: -partition-all50019 Ref: -partition-all50269
Ref: -partition-in-steps50444 Ref: -partition-in-steps50694
Ref: -partition-all-in-steps50990 Ref: -partition-all-in-steps51240
Ref: -partition-by51504 Ref: -partition-by51754
Ref: -partition-by-header51882 Ref: -partition-by-header52132
Ref: -partition-after-pred52483 Ref: -partition-after-pred52733
Ref: -partition-before-pred52936 Ref: -partition-before-pred53186
Ref: -partition-before-item53321 Ref: -partition-before-item53571
Ref: -partition-after-item53628 Ref: -partition-after-item53878
Ref: -group-by53930 Ref: -group-by54180
Node: Indexing54363 Node: Indexing54613
Ref: -elem-index54565 Ref: -elem-index54815
Ref: -elem-indices55052 Ref: -elem-indices55302
Ref: -find-index55511 Ref: -find-index55761
Ref: -find-last-index56180 Ref: -find-last-index56430
Ref: -find-indices56831 Ref: -find-indices57081
Ref: -grade-up57593 Ref: -grade-up57843
Ref: -grade-down58000 Ref: -grade-down58250
Node: Set operations58414 Node: Set operations58664
Ref: -union58597 Ref: -union58847
Ref: -difference59027 Ref: -difference59277
Ref: -intersection59455 Ref: -intersection59705
Ref: -powerset59884 Ref: -powerset60134
Ref: -permutations60161 Ref: -permutations60411
Ref: -distinct60599 Ref: -distinct60849
Ref: -same-items?60993 Ref: -same-items?61243
Node: Other list operations61602 Node: Other list operations61852
Ref: -rotate61827 Ref: -rotate62077
Ref: -cons*62180 Ref: -cons*62430
Ref: -snoc62602 Ref: -snoc62852
Ref: -interpose63014 Ref: -interpose63264
Ref: -interleave63308 Ref: -interleave63558
Ref: -iota63674 Ref: -iota63924
Ref: -zip-with64157 Ref: -zip-with64407
Ref: -zip64871 Ref: -zip-pair65215
Ref: -zip-lists65700 Ref: -zip-lists65781
Ref: -zip-fill66398 Ref: -zip-lists-fill66579
Ref: -unzip66720 Ref: -zip67289
Ref: -pad67462 Ref: -zip-fill68316
Ref: -table67947 Ref: -unzip-lists69230
Ref: -table-flat68733 Ref: -unzip69853
Ref: -first69738 Ref: -pad70846
Ref: -last70271 Ref: -table71331
Ref: -first-item70617 Ref: -table-flat72117
Ref: -second-item71029 Ref: -first73122
Ref: -third-item71446 Ref: -last73655
Ref: -fourth-item71821 Ref: -first-item74001
Ref: -fifth-item72199 Ref: -second-item74413
Ref: -last-item72574 Ref: -third-item74830
Ref: -butlast72935 Ref: -fourth-item75205
Ref: -sort73180 Ref: -fifth-item75583
Ref: -list73672 Ref: -last-item75958
Ref: -fix74241 Ref: -butlast76319
Node: Tree operations74730 Ref: -sort76564
Ref: -tree-seq74926 Ref: -list77058
Ref: -tree-map75787 Ref: -fix77627
Ref: -tree-map-nodes76227 Node: Tree operations78116
Ref: -tree-reduce77091 Ref: -tree-seq78312
Ref: -tree-reduce-from77973 Ref: -tree-map79173
Ref: -tree-mapreduce78573 Ref: -tree-map-nodes79613
Ref: -tree-mapreduce-from79432 Ref: -tree-reduce80477
Ref: -clone80717 Ref: -tree-reduce-from81359
Node: Threading macros81044 Ref: -tree-mapreduce81959
Ref: ->81269 Ref: -tree-mapreduce-from82818
Ref: ->>81757 Ref: -clone84103
Ref: -->82260 Node: Threading macros84441
Ref: -as->82816 Ref: ->84666
Ref: -some->83270 Ref: ->>85154
Ref: -some->>83655 Ref: -->85657
Ref: -some-->84102 Ref: -as->86213
Ref: -doto84669 Ref: -some->86667
Node: Binding85222 Ref: -some->>87052
Ref: -when-let85429 Ref: -some-->87499
Ref: -when-let*85890 Ref: -doto88066
Ref: -if-let86419 Node: Binding88619
Ref: -if-let*86785 Ref: -when-let88826
Ref: -let87408 Ref: -when-let*89287
Ref: -let*93498 Ref: -if-let89816
Ref: -lambda94435 Ref: -if-let*90182
Ref: -setq95241 Ref: -let90805
Node: Side effects96042 Ref: -let*96895
Ref: -each96236 Ref: -lambda97832
Ref: -each-while96763 Ref: -setq98638
Ref: -each-indexed97383 Node: Side effects99439
Ref: -each-r97975 Ref: -each99633
Ref: -each-r-while98417 Ref: -each-while100160
Ref: -dotimes99061 Ref: -each-indexed100780
Node: Destructive operations99614 Ref: -each-r101372
Ref: !cons99832 Ref: -each-r-while101814
Ref: !cdr100036 Ref: -dotimes102458
Node: Function combinators100229 Node: Destructive operations103011
Ref: -partial100433 Ref: !cons103229
Ref: -rpartial100951 Ref: !cdr103433
Ref: -juxt101599 Node: Function combinators103626
Ref: -compose102051 Ref: -partial103830
Ref: -applify102658 Ref: -rpartial104348
Ref: -on103088 Ref: -juxt104996
Ref: -flip103860 Ref: -compose105448
Ref: -rotate-args104384 Ref: -applify106055
Ref: -const105013 Ref: -on106485
Ref: -cut105355 Ref: -flip107257
Ref: -not105835 Ref: -rotate-args107781
Ref: -orfn106379 Ref: -const108410
Ref: -andfn107172 Ref: -cut108752
Ref: -iteratefn107959 Ref: -not109232
Ref: -fixfn108661 Ref: -orfn109776
Ref: -prodfn110235 Ref: -andfn110569
Node: Development111396 Ref: -iteratefn111356
Node: Contribute111685 Ref: -fixfn112058
Node: Contributors112697 Ref: -prodfn113632
Node: FDL114790 Node: Development114783
Node: GPL140110 Node: Contribute115072
Node: Index177859 Node: Contributors116084
Node: FDL118177
Node: GPL143497
Node: Index181246
 
End Tag Table End Tag Table

7
lisp/dashboard/dashboard-pkg.el
View File

@@ -1,7 +1,10 @@
(define-package "dashboard" "20221206.1228" "A startup screen extracted from Spacemacs" (define-package "dashboard" "20231031.359" "A startup screen extracted from Spacemacs"
'((emacs "26.1")) '((emacs "26.1"))
:commit "f4efda4d169cc2eb43c409a3669df5d78dd17ec6" :authors :commit "22786237e16cfeae33f07ae9c5eeaf061408579a" :authors
'(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com")) '(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com"))
:maintainers
'(("Jesús Martínez" . "jesusmartinez93@gmail.com")
("Jen-Chieh" . "jcs090218@gmail.com"))
:maintainer :maintainer
'("Jesús Martínez" . "jesusmartinez93@gmail.com") '("Jesús Martínez" . "jesusmartinez93@gmail.com")
:keywords :keywords

354
lisp/dashboard/dashboard-widgets.el
View File

@@ -1,20 +1,11 @@
;;; dashboard-widgets.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*- ;;; dashboard-widgets.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*-
;; Copyright (c) 2016-2022 emacs-dashboard maintainers ;; 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. ;; This file is not part of GNU Emacs.
;; ;;
;;; License: GPLv3 ;;; License: GPLv3
;; ;;
;; Created: October 05, 2016
;; Package-Version: 1.8.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1"))
;;; Commentary: ;;; Commentary:
;; An extensible Emacs dashboard, with sections for ;; An extensible Emacs dashboard, with sections for
@@ -31,13 +22,17 @@
(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")
(declare-function projectile-cleanup-known-projects "ext:projectile.el") (declare-function projectile-cleanup-known-projects "ext:projectile.el")
(declare-function projectile-load-known-projects "ext:projectile.el") (declare-function projectile-load-known-projects "ext:projectile.el")
(declare-function projectile-mode "ext:projectile.el") (declare-function projectile-mode "ext:projectile.el")
(declare-function projectile-relevant-known-projects "ext:projectile.el")
;;; project.el in Emacs 26 does not contain this function ;;; project.el in Emacs 26 does not contain this function
(declare-function project-known-project-roots "ext:project.el" nil t) (declare-function project-known-project-roots "ext:project.el" nil t)
(declare-function project-forget-zombie-projects "ext:project.el" nil t) (declare-function project-forget-zombie-projects "ext:project.el" nil t)
@@ -69,6 +64,7 @@
(defvar org-todo-keywords-1) (defvar org-todo-keywords-1)
(defvar all-the-icons-dir-icon-alist) (defvar all-the-icons-dir-icon-alist)
(defvar package-activated-list) (defvar package-activated-list)
(defvar elpaca-after-init-time)
(declare-function string-pixel-width "subr-x.el") ; TODO: remove this after 29.1 (declare-function string-pixel-width "subr-x.el") ; TODO: remove this after 29.1
(declare-function shr-string-pixel-width "shr.el") ; TODO: remove this after 29.1 (declare-function shr-string-pixel-width "shr.el") ; TODO: remove this after 29.1
@@ -135,6 +131,70 @@ 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
@@ -157,13 +217,19 @@ preserved."
:type 'string :type 'string
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-banner-ascii "EMACS"
"String to be shown in place of the startup banner
if `dashboard-startup-banner' is set to `ascii'."
:type 'string
:group 'dashboard)
(defcustom dashboard-navigator-buttons nil (defcustom dashboard-navigator-buttons nil
"Specify the navigator buttons. "Specify the navigator buttons.
The format is: 'icon title help action face prefix suffix'. The format is: `icon title help action face prefix suffix`.
Example: Example:
'((\"☆\" \"Star\" \"Show stars\" (lambda (&rest _) `((\"☆\" \"Star\" \"Show stars\" (lambda (&rest _)
(show-stars)) 'warning \"[\" \"]\"))" (show-stars)) warning \"[\" \"]\"))"
:type '(repeat (repeat (list string string string function symbol string string))) :type '(repeat (repeat (list string string string function symbol string string)))
:group 'dashboard) :group 'dashboard)
@@ -175,6 +241,8 @@ Example:
(when (boundp 'straight--profile-cache) (when (boundp 'straight--profile-cache)
(setq package-count (+ (hash-table-count straight--profile-cache) package-count))) (setq package-count (+ (hash-table-count straight--profile-cache) package-count)))
(when (fboundp 'elpaca--queued) (when (fboundp 'elpaca--queued)
(setq time (format "%f seconds" (float-time (time-subtract elpaca-after-init-time
before-init-time))))
(setq package-count (length (elpaca--queued)))) (setq package-count (length (elpaca--queued))))
(if (zerop package-count) (if (zerop package-count)
(format "Emacs started in %s" time) (format "Emacs started in %s" time)
@@ -183,21 +251,75 @@ Example:
:type '(function string) :type '(function string)
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-footer (defcustom dashboard-display-icons-p #'display-graphic-p
(nth (random (1- (1+ (length dashboard-footer-messages)))) dashboard-footer-messages) "Predicate to determine whether dashboard should show icons.
"A footer with some short message." Can be nil to not show icons and any truthy value to show them. When set to a
:type 'string function the result of the function will be interpreted as the predicate value."
:type '(choice (function :tag "Predicate function")
(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 ()
"Assert whether to show icons based on the `dashboard-display-icons-p' variable."
(if (functionp dashboard-display-icons-p)
(funcall 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 by NAME.
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 (and (display-graphic-p) (if (dashboard-display-icons-p)
(or (fboundp 'all-the-icons-fileicon) (pcase dashboard-icon-type
(require 'all-the-icons nil 'noerror))) ('all-the-icons
(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 'dashboard-footer-icon-face))
(propertize ">" 'face 'dashboard-footer)) ('nerd-icons
(nerd-icons-sucicon "nf-custom-emacs"
:height 1.1
:v-adjust -0.05
:face 'dashboard-footer-icon-face)))
(propertize ">" 'face 'dashboard-footer-icon-face))
"Footer's icon." "Footer's icon."
:type 'string :type 'string
:group 'dashboard) :group 'dashboard)
@@ -205,12 +327,14 @@ Example:
(defcustom dashboard-startup-banner 'official (defcustom dashboard-startup-banner 'official
"Specify the startup banner. "Specify the startup banner.
Default value is `official', it displays the Emacs logo. `logo' displays Emacs Default value is `official', it displays the Emacs logo. `logo' displays Emacs
alternative logo. An integer value is the index of text banner. A string alternative logo. If set to `ascii', the value of `dashboard-banner-ascii'
value must be a path to a .PNG or .TXT file. If the value is nil then no banner will be used as the banner. An integer value is the index of text banner.
is displayed." A string value must be a path to a .PNG or .TXT file. If the value is
nil then no banner is displayed."
:type '(choice (const :tag "no banner" nil) :type '(choice (const :tag "no banner" nil)
(const :tag "offical" official) (const :tag "offical" official)
(const :tag "logo" logo) (const :tag "logo" logo)
(const :tag "ascii" ascii)
(integer :tag "index of a text banner") (integer :tag "index of a text banner")
(string :tag "a path to an image or text banner") (string :tag "a path to an image or text banner")
(cons :tag "an image and text banner" (cons :tag "an image and text banner"
@@ -244,6 +368,11 @@ installed."
(const :tag "Use project.el" project-el)) (const :tag "Use project.el" project-el))
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-remove-missing-entry nil
"If non-nil, try to remove missing entries."
:type 'boolean
:group 'dashboard)
(defcustom dashboard-items (defcustom dashboard-items
'((recents . 5) '((recents . 5)
(bookmarks . 5) (bookmarks . 5)
@@ -283,19 +412,6 @@ 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
@@ -352,9 +468,14 @@ If nil it is disabled. Possible values for list-type are:
"Face used for no items." "Face used for no items."
:group 'dashboard) :group 'dashboard)
(defface dashboard-footer (defface dashboard-footer-face
'((t (:inherit font-lock-doc-face))) '((t (:inherit font-lock-doc-face)))
"Face used for widget headings." "Face used for footer text."
:group 'dashboard)
(defface dashboard-footer-icon-face
'((t (:inherit dashboard-footer-face)))
"Face used for icon in footer."
:group 'dashboard) :group 'dashboard)
(define-obsolete-face-alias (define-obsolete-face-alias
@@ -388,7 +509,7 @@ If nil it is disabled. Possible values for list-type are:
(defun dashboard-str-len (str) (defun dashboard-str-len (str)
"Calculate STR in pixel width." "Calculate STR in pixel width."
(let ((width (window-font-width)) (let ((width (frame-char-width))
(len (dashboard-string-pixel-width str))) (len (dashboard-string-pixel-width str)))
(+ (/ len width) (+ (/ len width)
(if (zerop (% len width)) 0 1)))) ; add one if exceeed (if (zerop (% len width)) 0 1)))) ; add one if exceeed
@@ -415,6 +536,9 @@ If nil it is disabled. Possible values for list-type are:
search-label search-label
&optional no-next-line) &optional no-next-line)
"Insert a shortcut SHORTCUT-CHAR for a given SEARCH-LABEL. "Insert a shortcut SHORTCUT-CHAR for a given SEARCH-LABEL.
SHORTCUT-ID is the section identifier.
Optionally, provide NO-NEXT-LINE to move the cursor forward a line." Optionally, provide NO-NEXT-LINE to move the cursor forward a line."
(let* (;; Ensure punctuation and upper case in search string is not (let* (;; Ensure punctuation and upper case in search string is not
;; used to construct the `defun' ;; used to construct the `defun'
@@ -438,7 +562,7 @@ Optionally, provide NO-NEXT-LINE to move the cursor forward a line."
If MESSAGEBUF is not nil then MSG is also written in message buffer." If MESSAGEBUF is not nil then MSG is also written in message buffer."
(with-current-buffer (get-buffer-create dashboard-buffer-name) (with-current-buffer (get-buffer-create dashboard-buffer-name)
(goto-char (point-max)) (goto-char (point-max))
(let (buffer-read-only) (insert msg)))) (let ((inhibit-read-only t)) (insert msg))))
(defun dashboard-modify-heading-icons (alist) (defun dashboard-modify-heading-icons (alist)
"Append ALIST items to `dashboard-heading-icons' to modify icons." "Append ALIST items to `dashboard-heading-icons' to modify icons."
@@ -449,33 +573,32 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
"Insert a page break line in dashboard buffer." "Insert a page break line in dashboard buffer."
(dashboard-append dashboard-page-separator)) (dashboard-append dashboard-page-separator))
(defun dashboard-insert-heading (heading &optional shortcut) (defun dashboard-insert-heading (heading &optional shortcut icon)
"Insert a widget HEADING in dashboard buffer, adding SHORTCUT if provided." "Insert a widget HEADING in dashboard buffer, adding SHORTCUT, ICON if provided."
(when (and (display-graphic-p) dashboard-set-heading-icons) (when (and (dashboard-display-icons-p) dashboard-set-heading-icons)
;; Try loading `all-the-icons' (let ((args `( :height ,dashboard-heading-icon-height
(unless (or (fboundp 'all-the-icons-octicon) :v-adjust ,dashboard-heading-icon-v-adjust
(require 'all-the-icons nil 'noerror)) :face dashboard-heading)))
(error "Package `all-the-icons' isn't installed")) (insert
(pcase heading
(insert (cond ("Recent Files:"
((string-equal heading "Recent Files:") (apply #'dashboard-octicon (cdr (assoc 'recents dashboard-heading-icons)) args))
(all-the-icons-octicon (cdr (assoc 'recents dashboard-heading-icons)) ("Bookmarks:"
:height 1.2 :v-adjust 0.0 :face 'dashboard-heading)) (apply #'dashboard-octicon (cdr (assoc 'bookmarks dashboard-heading-icons)) args))
((string-equal heading "Bookmarks:") ((or "Agenda for today:"
(all-the-icons-octicon (cdr (assoc 'bookmarks dashboard-heading-icons)) "Agenda for the coming week:")
:height 1.2 :v-adjust 0.0 :face 'dashboard-heading)) (apply #'dashboard-octicon (cdr (assoc 'agenda dashboard-heading-icons)) args))
((or (string-equal heading "Agenda for today:") ("Registers:"
(string-equal heading "Agenda for the coming week:")) (apply #'dashboard-octicon (cdr (assoc 'registers dashboard-heading-icons)) args))
(all-the-icons-octicon (cdr (assoc 'agenda dashboard-heading-icons)) ("Projects:"
:height 1.2 :v-adjust 0.0 :face 'dashboard-heading)) (apply #'dashboard-octicon (cdr (assoc 'projects dashboard-heading-icons)) args))
((string-equal heading "Registers:") ("List Directories:"
(all-the-icons-octicon (cdr (assoc 'registers dashboard-heading-icons)) (apply #'dashboard-octicon (cdr (assoc 'ls-directories dashboard-heading-icons)) args))
:height 1.2 :v-adjust 0.0 :face 'dashboard-heading)) ("List Files:"
((string-equal heading "Projects:") (apply #'dashboard-octicon (cdr (assoc 'ls-files dashboard-heading-icons)) args))
(all-the-icons-octicon (cdr (assoc 'projects dashboard-heading-icons)) (_
:height 1.2 :v-adjust 0.0 :face 'dashboard-heading)) (if (null icon) " " icon))))
(t " "))) (insert " ")))
(insert " "))
(insert (propertize heading 'face 'dashboard-heading)) (insert (propertize heading 'face 'dashboard-heading))
@@ -496,7 +619,8 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(goto-char start) (goto-char start)
(let ((width 0)) (let ((width 0))
(while (< (point) end) (while (< (point) end)
(let ((line-length (- (line-end-position) (line-beginning-position)))) (let* ((line-str (buffer-substring (line-beginning-position) (line-end-position)))
(line-length (dashboard-str-len line-str)))
(setq width (max width line-length))) (setq width (max width line-length)))
(forward-line 1)) (forward-line 1))
(let ((prefix (propertize " " 'display `(space . (:align-to (- center ,(/ width 2))))))) (let ((prefix (propertize " " 'display `(space . (:align-to (- center ,(/ width 2)))))))
@@ -535,6 +659,8 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(append (when (image-type-available-p 'png) (append (when (image-type-available-p 'png)
(list :image dashboard-banner-logo-png)) (list :image dashboard-banner-logo-png))
(list :text (dashboard-get-banner-path 1)))) (list :text (dashboard-get-banner-path 1))))
('ascii
(append (list :text dashboard-banner-ascii)))
((pred integerp) ((pred integerp)
(list :text (dashboard-get-banner-path dashboard-startup-banner))) (list :text (dashboard-get-banner-path dashboard-startup-banner)))
((pred stringp) ((pred stringp)
@@ -580,10 +706,12 @@ Argument IMAGE-PATH path to the image."
buffer-read-only buffer-read-only
text-width text-width
image-spec) image-spec)
(insert "\n") (when (display-graphic-p) (insert "\n"))
;; If specified, insert a text banner. ;; If specified, insert a text banner.
(when-let (txt (plist-get banner :text)) (when-let (txt (plist-get banner :text))
(insert-file-contents txt) (if (eq dashboard-startup-banner 'ascii)
(save-excursion (insert txt))
(insert-file-contents txt))
(put-text-property (point) (point-max) 'face 'dashboard-text-banner) (put-text-property (point) (point-max) 'face 'dashboard-text-banner)
(setq text-width 0) (setq text-width 0)
(while (not (eobp)) (while (not (eobp))
@@ -687,6 +815,8 @@ Argument IMAGE-PATH path to the image."
(defmacro dashboard-insert-section (section-name list list-size shortcut-id shortcut-char action &rest widget-params) (defmacro dashboard-insert-section (section-name list list-size shortcut-id shortcut-char action &rest widget-params)
"Add a section with SECTION-NAME and LIST of LIST-SIZE items to the dashboard. "Add a section with SECTION-NAME and LIST of LIST-SIZE items to the dashboard.
SHORTCUT-ID is the section identifier.
SHORTCUT-CHAR is the keyboard shortcut used to access the section. SHORTCUT-CHAR is the keyboard shortcut used to access the section.
ACTION is theaction taken when the user activates the widget button. ACTION is theaction taken when the user activates the widget button.
WIDGET-PARAMS are passed to the \"widget-create\" function." WIDGET-PARAMS are passed to the \"widget-create\" function."
@@ -715,21 +845,19 @@ to widget creation."
(let ((tag ,@rest)) (let ((tag ,@rest))
(insert "\n ") (insert "\n ")
(when (and (display-graphic-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))
(all-the-icons-icon-for-dir path nil "") (dashboard-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:"))
(all-the-icons-octicon "primitive-dot" :height 1.0 :v-adjust 0.01)) dashboard-agenda-item-icon)
((file-remote-p path) ((file-remote-p path)
(all-the-icons-octicon "radio-tower" :height 1.0 :v-adjust 0.01)) dashboard-remote-path-icon)
(t (all-the-icons-icon-for-file (file-name-nondirectory path) (t (dashboard-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))))
@@ -750,12 +878,13 @@ to widget creation."
(defun dashboard-insert-footer () (defun dashboard-insert-footer ()
"Insert footer of dashboard." "Insert footer of dashboard."
(when-let ((footer (and dashboard-set-footer (dashboard-random-footer)))) (when-let ((footer (and dashboard-set-footer (dashboard-random-footer)))
(footer-icon (dashboard-replace-displayable dashboard-footer-icon)))
(insert "\n") (insert "\n")
(dashboard-insert-center (dashboard-insert-center
dashboard-footer-icon (if (string-empty-p footer-icon) footer-icon
" " (concat footer-icon " "))
(propertize footer 'face 'dashboard-footer) (propertize footer 'face 'dashboard-footer-face)
"\n"))) "\n")))
;; ;;
@@ -933,7 +1062,10 @@ to widget creation."
(defun dashboard-insert-recents (list-size) (defun dashboard-insert-recents (list-size)
"Add the list of LIST-SIZE items from recently edited files." "Add the list of LIST-SIZE items from recently edited files."
(setq dashboard--recentf-cache-item-format nil) (setq dashboard--recentf-cache-item-format nil)
(dashboard-mute-apply (recentf-mode 1) (recentf-cleanup)) (dashboard-mute-apply
(recentf-mode 1)
(when dashboard-remove-missing-entry
(ignore-errors (recentf-cleanup))))
(dashboard-insert-section (dashboard-insert-section
"Recent Files:" "Recent Files:"
(dashboard-shorten-paths recentf-list 'dashboard-recentf-alist 'recents) (dashboard-shorten-paths recentf-list 'dashboard-recentf-alist 'recents)
@@ -1064,11 +1196,16 @@ Return function that returns a list of projects."
(cl-case dashboard-projects-backend (cl-case dashboard-projects-backend
(`projectile (`projectile
(require 'projectile) (require 'projectile)
(dashboard-mute-apply (projectile-cleanup-known-projects)) (when dashboard-remove-missing-entry
(dashboard-mute-apply
(ignore-errors (projectile-cleanup-known-projects))))
(projectile-load-known-projects)) (projectile-load-known-projects))
(`project-el (`project-el
(require 'project) (require 'project)
(dashboard-mute-apply (dashboard-funcall-fboundp #'project-forget-zombie-projects)) (when dashboard-remove-missing-entry
(dashboard-mute-apply
(ignore-errors
(dashboard-funcall-fboundp #'project-forget-zombie-projects))))
(project-known-project-roots)) (project-known-project-roots))
(t (t
(display-warning '(dashboard) (display-warning '(dashboard)
@@ -1141,6 +1278,15 @@ each agenda entry."
:type 'string :type 'string
:group 'dashboard) :group 'dashboard)
(defcustom dashboard-agenda-tags-format 'identity
"Function to format the org agenda tags.
Any custom function would receives the tags from `org-get-tags'"
:type '(choice
(const :tag "Show tags" identity)
(const :tag "Hide tags" ignore)
(function :tag "Custom function"))
:group 'dashboard)
(defun dashboard-agenda-entry-format () (defun dashboard-agenda-entry-format ()
"Format agenda entry to show it on dashboard. "Format agenda entry to show it on dashboard.
Also,it set text properties that latter are used to sort entries and perform different actions." Also,it set text properties that latter are used to sort entries and perform different actions."
@@ -1153,7 +1299,7 @@ Also,it set text properties that latter are used to sort entries and perform dif
(dashboard-agenda--formatted-headline) (dashboard-agenda--formatted-headline)
(org-outline-level) (org-outline-level)
(org-get-category) (org-get-category)
(org-get-tags))) (dashboard-agenda--formatted-tags)))
(todo-state (org-get-todo-state)) (todo-state (org-get-todo-state))
(item-priority (org-get-priority (org-get-heading t t t t))) (item-priority (org-get-priority (org-get-heading t t t t)))
(todo-index (and todo-state (todo-index (and todo-state
@@ -1177,18 +1323,27 @@ Also,it set text properties that latter are used to sort entries and perform dif
(todo (or (org-get-todo-state) "")) (todo (or (org-get-todo-state) ""))
(org-level-face (nth (- (org-outline-level) 1) org-level-faces)) (org-level-face (nth (- (org-outline-level) 1) org-level-faces))
(todo-state (format org-agenda-todo-keyword-format todo))) (todo-state (format org-agenda-todo-keyword-format todo)))
(when (null (get-text-property 0 'face headline)) (dashboard-agenda--set-face org-level-face headline)
(add-face-text-property 0 (length headline) org-level-face t headline)) (dashboard-agenda--set-face (org-get-todo-face todo) todo-state)
(when (null (get-text-property 0 'face todo-state))
(add-face-text-property 0 (length todo-state) (org-get-todo-face todo) t todo-state))
(concat todo-state " " headline))) (concat todo-state " " headline)))
(defun dashboard-agenda--set-face (face text)
"Add FACE to TEXT but inherit height from `dashboard-items-face'.
If not height is found on FACE or `dashboard-items-face' use `default'."
(let ((height (face-attribute 'dashboard-items-face :height nil 'default)))
(add-face-text-property 0 (length text) `((:height ,height) ,face) nil text)))
(defun dashboard-agenda--formatted-time () (defun dashboard-agenda--formatted-time ()
"Get the scheduled or dead time of an entry. If no time is found return nil." "Get the scheduled or dead time of an entry. If no time is found return nil."
(when-let ((time (or (org-get-scheduled-time (point)) (org-get-deadline-time (point)) (when-let ((time (or (org-get-scheduled-time (point)) (org-get-deadline-time (point))
(dashboard-agenda--entry-timestamp (point))))) (dashboard-agenda--entry-timestamp (point)))))
(format-time-string dashboard-agenda-time-string-format time))) (format-time-string dashboard-agenda-time-string-format time)))
(defun dashboard-agenda--formatted-tags ()
"Apply `dashboard-agenda-tags-format' to org-element tags."
(when dashboard-agenda-tags-format
(funcall dashboard-agenda-tags-format (org-get-tags))))
(defun dashboard-due-date-for-agenda () (defun dashboard-due-date-for-agenda ()
"Return due-date for agenda period." "Return due-date for agenda period."
(if dashboard-week-agenda (if dashboard-week-agenda
@@ -1202,7 +1357,8 @@ point."
(let ((scheduled-time (org-get-scheduled-time (point))) (let ((scheduled-time (org-get-scheduled-time (point)))
(deadline-time (org-get-deadline-time (point))) (deadline-time (org-get-deadline-time (point)))
(entry-timestamp (dashboard-agenda--entry-timestamp (point))) (entry-timestamp (dashboard-agenda--entry-timestamp (point)))
(due-date (dashboard-due-date-for-agenda))) (due-date (dashboard-due-date-for-agenda))
(now (current-time)))
(unless (and (not (org-entry-is-done-p)) (unless (and (not (org-entry-is-done-p))
(not (org-in-archived-heading-p)) (not (org-in-archived-heading-p))
(or (and scheduled-time (or (and scheduled-time
@@ -1210,6 +1366,7 @@ point."
(and deadline-time (and deadline-time
(org-time-less-p deadline-time due-date)) (org-time-less-p deadline-time due-date))
(and entry-timestamp (and entry-timestamp
(org-time-less-p now entry-timestamp)
(org-time-less-p entry-timestamp due-date)))) (org-time-less-p entry-timestamp due-date))))
(point)))) (point))))
@@ -1247,14 +1404,16 @@ This is what `org-agenda-exit' do."
(defun dashboard-agenda--sorted-agenda () (defun dashboard-agenda--sorted-agenda ()
"Return agenda sorted by time. "Return agenda sorted by time.
For now, it only works when dashboard-agenda has been filter by time
and dashboard-agenda-sort is not nil." For now, it only works when dashboard-agenda has been filter by time and
dashboard-agenda-sort is not nil."
(let ((agenda (dashboard-get-agenda)) (let ((agenda (dashboard-get-agenda))
(sort-function (dashboard-agenda--sort-function))) (sort-function (dashboard-agenda--sort-function)))
(sort agenda sort-function))) (sort agenda sort-function)))
(defun dashboard-agenda--sort-function () (defun dashboard-agenda--sort-function ()
"Get the function use to sorted the agenda. "Get the function use to sorted the agenda.
Depending on the list `dashboard-agenda-sorting-strategy' use this strategies to Depending on the list `dashboard-agenda-sorting-strategy' use this strategies to
build a predicate to compare each enty. build a predicate to compare each enty.
This is similar as `org-entries-lessp' but with a different aproach." This is similar as `org-entries-lessp' but with a different aproach."
@@ -1262,6 +1421,7 @@ This is similar as `org-entries-lessp' but with a different aproach."
(defun dashboard-agenda--build-sort-function (strategies) (defun dashboard-agenda--build-sort-function (strategies)
"Build a predicate to sort the dashboard agenda. "Build a predicate to sort the dashboard agenda.
If `STRATEGIES' is nil then sort using the nil predicate. Look for the strategy If `STRATEGIES' is nil then sort using the nil predicate. Look for the strategy
predicate, the attributes of the entry and compare entries. If no predicate is predicate, the attributes of the entry and compare entries. If no predicate is
found for the strategy it uses nil predicate." found for the strategy it uses nil predicate."

54
lisp/dashboard/dashboard.el
View File

@@ -1,6 +1,6 @@
;;; dashboard.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*- ;;; dashboard.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*-
;; Copyright (c) 2016-2022 emacs-dashboard maintainers ;; Copyright (c) 2016-2023 emacs-dashboard maintainers
;; ;;
;; Author : Rakan Al-Hneiti <rakan.alhneiti@gmail.com> ;; Author : Rakan Al-Hneiti <rakan.alhneiti@gmail.com>
;; Maintainer : Jesús Martínez <jesusmartinez93@gmail.com> ;; Maintainer : Jesús Martínez <jesusmartinez93@gmail.com>
@@ -12,7 +12,7 @@
;;; License: GPLv3 ;;; License: GPLv3
;; ;;
;; Created: October 05, 2016 ;; Created: October 05, 2016
;; Package-Version: 1.8.0-SNAPSHOT ;; Package-Version: 1.9.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard ;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1")) ;; Package-Requires: ((emacs "26.1"))
;;; Commentary: ;;; Commentary:
@@ -34,6 +34,9 @@
(declare-function page-break-lines-mode "ext:page-break-lines.el") (declare-function page-break-lines-mode "ext:page-break-lines.el")
(declare-function projectile-remove-known-project "ext:projectile.el") (declare-function projectile-remove-known-project "ext:projectile.el")
(declare-function project-forget-projects-under "ext:project.el") (declare-function project-forget-projects-under "ext:project.el")
(declare-function linum-mode "linum.el")
(declare-function dashboard-refresh-buffer "dashboard.el")
(defgroup dashboard nil (defgroup dashboard nil
"Extensible startup screen." "Extensible startup screen."
@@ -371,7 +374,7 @@ Optional argument ARGS adviced function arguments."
"Execute BODY in dashboard buffer." "Execute BODY in dashboard buffer."
(declare (indent 0)) (declare (indent 0))
`(with-current-buffer (get-buffer-create dashboard-buffer-name) `(with-current-buffer (get-buffer-create dashboard-buffer-name)
(let (buffer-read-only) ,@body) (let ((inhibit-read-only t)) ,@body)
(current-buffer))) (current-buffer)))
(defun dashboard-maximum-section-length () (defun dashboard-maximum-section-length ()
@@ -400,6 +403,7 @@ Optional argument ARGS adviced function arguments."
(when (or dashboard-force-refresh (not (eq major-mode 'dashboard-mode))) (when (or dashboard-force-refresh (not (eq major-mode 'dashboard-mode)))
(erase-buffer) (erase-buffer)
(dashboard-insert-banner) (dashboard-insert-banner)
(insert "\n")
(setq dashboard--section-starts nil) (setq dashboard--section-starts nil)
(mapc (lambda (els) (mapc (lambda (els)
(let* ((el (or (car-safe els) els)) (let* ((el (or (car-safe els) els))
@@ -425,38 +429,54 @@ Optional argument ARGS adviced function arguments."
(car (last dashboard--section-starts)) (car (last dashboard--section-starts))
(point)) (point))
(point-max))) (point-max)))
(insert dashboard-page-separator)
(save-excursion (save-excursion
(dolist (start dashboard--section-starts) (dolist (start dashboard--section-starts)
(goto-char start) (goto-char start)
(delete-char -1) ; delete the newline we added previously (delete-char -1) ; delete the newline we added previously
(insert dashboard-page-separator))) (insert dashboard-page-separator)))
(progn
(delete-char -1)
(insert dashboard-page-separator))
(dashboard-insert-footer) (dashboard-insert-footer)
(goto-char (point-min)) (goto-char (point-min))
(dashboard-mode))) (dashboard-mode)))
(when recentf-is-on (when recentf-is-on
(setq recentf-list origial-recentf-list)))) (setq recentf-list origial-recentf-list))))
(defun dashboard-refresh-buffer (&rest _)
"Refresh buffer." ;;;###autoload
(defun dashboard-open (&rest _)
"Open (or refresh) the *dashboard* buffer."
(interactive) (interactive)
(let ((dashboard-force-refresh t)) (dashboard-insert-startupify-lists)) (let ((dashboard-force-refresh t)) (dashboard-insert-startupify-lists))
(switch-to-buffer dashboard-buffer-name)) (switch-to-buffer dashboard-buffer-name))
;;;###autoload (defalias #'dashboard-refresh-buffer #'dashboard-open)
(defun dashboard-setup-startup-hook ()
"Setup post initialization hooks. (defun dashboard-resize-on-hook (&optional _)
If a command line argument is provided, assume a filename and skip displaying "Re-render dashboard on window size change."
Dashboard." (let ((space-win (get-buffer-window dashboard-buffer-name))
(when (< (length command-line-args) 2) (frame-win (frame-selected-window)))
(add-hook 'after-init-hook (lambda () (when (and space-win
;; Display useful lists of items (not (window-minibuffer-p frame-win)))
(dashboard-insert-startupify-lists))) (with-selected-window space-win
(add-hook 'emacs-startup-hook (lambda () (dashboard-insert-startupify-lists)))))
(defun dashboard-initialize ()
"Switch to dashboard and run `dashboard-after-initialize-hook'."
(switch-to-buffer dashboard-buffer-name) (switch-to-buffer dashboard-buffer-name)
(goto-char (point-min)) (goto-char (point-min))
(redisplay) (redisplay)
(run-hooks 'dashboard-after-initialize-hook))))) (run-hooks 'dashboard-after-initialize-hook))
;;;###autoload
(defun dashboard-setup-startup-hook ()
"Setup post initialization hooks unless a command line argument is provided."
(when (< (length command-line-args) 2) ;; Assume no file name passed
(add-hook 'window-size-change-functions #'dashboard-resize-on-hook 100)
(add-hook 'window-setup-hook #'dashboard-resize-on-hook)
(add-hook 'after-init-hook #'dashboard-insert-startupify-lists)
(add-hook 'emacs-startup-hook #'dashboard-initialize)))
(provide 'dashboard) (provide 'dashboard)
;;; dashboard.el ends here ;;; dashboard.el ends here

12
lisp/deft/deft-pkg.el Normal file
View File

@@ -0,0 +1,12 @@
(define-package "deft" "20210707.1633" "quickly browse, filter, and edit plain text notes" 'nil :commit "28be94d89bff2e1c7edef7244d7c5ba0636b1296" :authors
'(("Jason R. Blevins" . "jrblevin@xbeta.org"))
:maintainers
'(("Jason R. Blevins" . "jrblevin@xbeta.org"))
:maintainer
'("Jason R. Blevins" . "jrblevin@xbeta.org")
:keywords
'("plain text" "notes" "simplenote" "notational velocity")
:url "https://jblevins.org/projects/deft/")
;; Local Variables:
;; no-byte-compile: t
;; End:

2
lisp/deft.el → lisp/deft/deft.el
View File

@@ -27,8 +27,6 @@
;; POSSIBILITY OF SUCH DAMAGE. ;; POSSIBILITY OF SUCH DAMAGE.
;;; Version: 0.8 ;;; Version: 0.8
;; Package-Version: 20210707.1633
;; Package-Commit: 28be94d89bff2e1c7edef7244d7c5ba0636b1296
;;; Author: Jason R. Blevins <jrblevin@xbeta.org> ;;; Author: Jason R. Blevins <jrblevin@xbeta.org>
;;; Keywords: plain text, notes, Simplenote, Notational Velocity ;;; Keywords: plain text, notes, Simplenote, Notational Velocity
;;; URL: https://jblevins.org/projects/deft/ ;;; URL: https://jblevins.org/projects/deft/

17
lisp/diff-hl/diff-hl-dired.el
View File

@@ -1,6 +1,6 @@
;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*- ;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
;; Copyright (C) 2012-2017 Free Software Foundation, Inc. ;; Copyright (C) 2012-2017, 2023 Free Software Foundation, Inc.
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
@@ -140,19 +140,7 @@ status indicators."
(defun diff-hl-dired-status-files (backend dir files update-function) (defun diff-hl-dired-status-files (backend dir files update-function)
"Using version control BACKEND, return list of (FILE STATE EXTRA) entries "Using version control BACKEND, return list of (FILE STATE EXTRA) entries
for DIR containing FILES. Call UPDATE-FUNCTION as entries are added." for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
(if (version< "25" emacs-version) (vc-call-backend backend 'dir-status-files dir files update-function))
(vc-call-backend backend 'dir-status-files dir files update-function)
(vc-call-backend backend 'dir-status-files dir files nil update-function)))
(when (version< emacs-version "24.4.51.5")
;; Work around http://debbugs.gnu.org/19386
(defadvice vc-git-dir-status-goto-stage (around
diff-hl-dired-skip-up-to-date
(stage files update-function)
activate)
(when (eq stage 'ls-files-up-to-date)
(setq stage 'diff-index))
ad-do-it))
(defun diff-hl-dired-highlight-items (alist) (defun diff-hl-dired-highlight-items (alist)
"Highlight ALIST containing (FILE . TYPE) elements." "Highlight ALIST containing (FILE . TYPE) elements."
@@ -167,6 +155,7 @@ for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
(diff-hl-fringe-face-function 'diff-hl-dired-face-from-type) (diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
(o (diff-hl-add-highlighting type 'single))) (o (diff-hl-add-highlighting type 'single)))
(overlay-put o 'modification-hooks '(diff-hl-overlay-modified)) (overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
(overlay-put o 'diff-hl-dired-type type)
)))))) ))))))
(defun diff-hl-dired-face-from-type (type _pos) (defun diff-hl-dired-face-from-type (type _pos)

8
lisp/diff-hl/diff-hl-flydiff.el
View File

@@ -61,6 +61,9 @@
"Perform highlighting on-the-fly. "Perform highlighting on-the-fly.
This is a global minor mode. It alters how `diff-hl-mode' works." This is a global minor mode. It alters how `diff-hl-mode' works."
:lighter "" :global t :lighter "" :global t
(and diff-hl-flydiff-timer
(cancel-timer diff-hl-flydiff-timer))
(if diff-hl-flydiff-mode (if diff-hl-flydiff-mode
(progn (progn
(advice-add 'diff-hl-overlay-modified :override #'ignore) (advice-add 'diff-hl-overlay-modified :override #'ignore)
@@ -75,9 +78,6 @@ This is a global minor mode. It alters how `diff-hl-mode' works."
(advice-remove 'diff-hl-overlay-modified #'ignore) (advice-remove 'diff-hl-overlay-modified #'ignore)
(advice-remove 'diff-hl-modified-p #'diff-hl-flydiff/modified-p) (advice-remove 'diff-hl-modified-p #'diff-hl-flydiff/modified-p)
(advice-remove 'diff-hl-changes-buffer #'diff-hl-flydiff-changes-buffer) (advice-remove 'diff-hl-changes-buffer #'diff-hl-flydiff-changes-buffer)))
(and diff-hl-flydiff-timer
(cancel-timer diff-hl-flydiff-timer))))
(provide 'diff-hl-flydiff) (provide 'diff-hl-flydiff)

12
lisp/diff-hl/diff-hl-margin.el
View File

@@ -40,6 +40,8 @@
(defvar diff-hl-margin-old-highlight-function nil) (defvar diff-hl-margin-old-highlight-function nil)
(defvar diff-hl-margin-old-width nil)
(defgroup diff-hl-margin nil (defgroup diff-hl-margin nil
"Highlight buffer changes on margin" "Highlight buffer changes on margin"
:group 'diff-hl) :group 'diff-hl)
@@ -108,15 +110,17 @@ You probably shouldn't use this function directly."
(let ((width-var (intern (format "%s-margin-width" diff-hl-side)))) (let ((width-var (intern (format "%s-margin-width" diff-hl-side))))
(if diff-hl-margin-local-mode (if diff-hl-margin-local-mode
(progn (progn
(set (make-local-variable 'diff-hl-margin-old-highlight-function) (setq-local diff-hl-margin-old-highlight-function
diff-hl-highlight-function) diff-hl-highlight-function)
(set (make-local-variable 'diff-hl-highlight-function) (setq-local diff-hl-highlight-function
'diff-hl-highlight-on-margin) #'diff-hl-highlight-on-margin)
(setq-local diff-hl-margin-old-width (symbol-value width-var))
(set width-var 1)) (set width-var 1))
(when diff-hl-margin-old-highlight-function (when diff-hl-margin-old-highlight-function
(setq diff-hl-highlight-function diff-hl-margin-old-highlight-function (setq diff-hl-highlight-function diff-hl-margin-old-highlight-function
diff-hl-margin-old-highlight-function nil)) diff-hl-margin-old-highlight-function nil))
(set width-var 0))) (set width-var diff-hl-margin-old-width)
(kill-local-variable 'diff-hl-margin-old-width)))
(dolist (win (get-buffer-window-list)) (dolist (win (get-buffer-window-list))
(set-window-buffer win (current-buffer)))) (set-window-buffer win (current-buffer))))

6
lisp/diff-hl/diff-hl-pkg.el
View File

@@ -1,7 +1,9 @@
(define-package "diff-hl" "20221007.2147" "Highlight uncommitted changes using VC" (define-package "diff-hl" "20230807.1516" "Highlight uncommitted changes using VC"
'((cl-lib "0.2") '((cl-lib "0.2")
(emacs "25.1")) (emacs "25.1"))
:commit "68fb280b300c5d8460cc7b9183e29fb3ec604136" :authors :commit "b5651f1c57b42e0f38e01a8fc8c7df9bc76d5d38" :authors
'(("Dmitry Gutov" . "dgutov@yandex.ru"))
:maintainers
'(("Dmitry Gutov" . "dgutov@yandex.ru")) '(("Dmitry Gutov" . "dgutov@yandex.ru"))
:maintainer :maintainer
'("Dmitry Gutov" . "dgutov@yandex.ru") '("Dmitry Gutov" . "dgutov@yandex.ru")

2
lisp/diff-hl/diff-hl-show-hunk-posframe.el
View File

@@ -230,7 +230,7 @@ The button calls an ACTION."
;; Make cursor visible (mainly for selecting text in posframe) ;; Make cursor visible (mainly for selecting text in posframe)
(setq cursor-type 'box) (setq cursor-type 'box)
;; Recenter arround point ;; Recenter around point
(recenter))) (recenter)))
(select-frame-set-input-focus diff-hl-show-hunk--frame)) (select-frame-set-input-focus diff-hl-show-hunk--frame))

2
lisp/diff-hl/diff-hl-show-hunk.el
View File

@@ -372,7 +372,7 @@ The backend is determined by `diff-hl-show-hunk-function'."
(setq diff-hl-show-hunk--original-overlay nil) (setq diff-hl-show-hunk--original-overlay nil)
;; Store begining and end of hunk overlay ;; Store beginning and end of hunk overlay
(let ((overlay (diff-hl-hunk-overlay-at (point)))) (let ((overlay (diff-hl-hunk-overlay-at (point))))
(when overlay (when overlay
(let ((start (overlay-start overlay)) (let ((start (overlay-start overlay))

21
lisp/diff-hl/diff-hl.el
View File

@@ -1,11 +1,11 @@
;;; diff-hl.el --- Highlight uncommitted changes using VC -*- lexical-binding: t -*- ;;; diff-hl.el --- Highlight uncommitted changes using VC -*- lexical-binding: t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc. ;; Copyright (C) 2012-2023 Free Software Foundation, Inc.
;; Author: Dmitry Gutov <dgutov@yandex.ru> ;; Author: Dmitry Gutov <dgutov@yandex.ru>
;; URL: https://github.com/dgutov/diff-hl ;; URL: https://github.com/dgutov/diff-hl
;; Keywords: vc, diff ;; Keywords: vc, diff
;; Version: 1.9.0 ;; Version: 1.9.2
;; Package-Requires: ((cl-lib "0.2") (emacs "25.1")) ;; Package-Requires: ((cl-lib "0.2") (emacs "25.1"))
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
@@ -290,7 +290,7 @@ the current version of the file)."
(listp vc-git-diff-switches) (listp vc-git-diff-switches)
(cl-remove-if-not (cl-remove-if-not
(lambda (arg) (lambda (arg)
(member arg '("--histogram" "--patience" "--minimal"))) (member arg '("--histogram" "--patience" "--minimal" "--textconv")))
vc-git-diff-switches)))) vc-git-diff-switches))))
(vc-hg-diff-switches nil) (vc-hg-diff-switches nil)
(vc-svn-diff-switches nil) (vc-svn-diff-switches nil)
@@ -541,7 +541,7 @@ in the source file, or the last line of the hunk above it."
(let ((to-go (1+ (- line hunk-line)))) (let ((to-go (1+ (- line hunk-line))))
(while (cl-plusp to-go) (while (cl-plusp to-go)
(forward-line 1) (forward-line 1)
(unless (looking-at "^-") (unless (looking-at "^[-\\]")
(cl-decf to-go)))))))))) (cl-decf to-go))))))))))
(defface diff-hl-reverted-hunk-highlight (defface diff-hl-reverted-hunk-highlight
@@ -609,6 +609,7 @@ in the source file, or the last line of the hunk above it."
(unless (yes-or-no-p (format "Revert current hunk in %s? " (unless (yes-or-no-p (format "Revert current hunk in %s? "
file)) file))
(user-error "Revert canceled"))) (user-error "Revert canceled")))
(widen)
(let ((diff-advance-after-apply-hunk nil)) (let ((diff-advance-after-apply-hunk nil))
(save-window-excursion (save-window-excursion
(diff-apply-hunk t))) (diff-apply-hunk t)))
@@ -628,7 +629,7 @@ Move point to the beginning of the delineated hunk and return
its end position." its end position."
(let (end-marker) (let (end-marker)
(save-excursion (save-excursion
(while (looking-at "[-+]") (forward-line 1)) (while (looking-at "[-+\\]") (forward-line 1))
(dotimes (_i max-context) (dotimes (_i max-context)
(unless (looking-at "@\\|[-+]") (unless (looking-at "@\\|[-+]")
(forward-line 1))) (forward-line 1)))
@@ -637,13 +638,14 @@ its end position."
(looking-at "@")) (looking-at "@"))
(diff-split-hunk))) (diff-split-hunk)))
(unless (looking-at "[-+]") (forward-line -1)) (unless (looking-at "[-+]") (forward-line -1))
(while (looking-at "[-+]") (forward-line -1)) (while (looking-at "[-+\\]") (forward-line -1))
(dotimes (_i max-context) (dotimes (_i max-context)
(unless (looking-at "@\\|[-+]") (unless (looking-at "@\\|[-+]")
(forward-line -1))) (forward-line -1)))
(unless (looking-at "@") (unless (looking-at "@")
(forward-line 1) (forward-line 1)
(diff-split-hunk)) (diff-split-hunk)
(forward-line -1))
end-marker)) end-marker))
(defun diff-hl-revert-hunk () (defun diff-hl-revert-hunk ()
@@ -717,7 +719,8 @@ Only supported with Git."
(file buffer-file-name) (file buffer-file-name)
(dest-buffer (get-buffer-create " *diff-hl-stage*")) (dest-buffer (get-buffer-create " *diff-hl-stage*"))
(orig-buffer (current-buffer)) (orig-buffer (current-buffer))
(file-base (shell-quote-argument (file-name-nondirectory file))) ;; FIXME: If the file name has double quotes, these need to be quoted.
(file-base (file-name-nondirectory file))
success) success)
(with-current-buffer dest-buffer (with-current-buffer dest-buffer
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
@@ -752,7 +755,7 @@ Only supported with Git."
(when success (when success
(if diff-hl-show-staged-changes (if diff-hl-show-staged-changes
(message (concat "Hunk staged; customize `diff-hl-show-staged-changes'" (message (concat "Hunk staged; customize `diff-hl-show-staged-changes'"
" to highlight only unstages changes")) " to highlight only unstaged changes"))
(message "Hunk staged")) (message "Hunk staged"))
(unless diff-hl-show-staged-changes (unless diff-hl-show-staged-changes
(diff-hl-update))))) (diff-hl-update)))))

14
lisp/dim/dim-pkg.el Normal file
View File

@@ -0,0 +1,14 @@
(define-package "dim" "20160818.949" "Change mode-line names of major/minor modes"
'((emacs "24.4"))
:commit "110624657fec0c8a7b3589108230e6a635302ae0" :authors
'(("Alex Kost" . "alezost@gmail.com"))
:maintainers
'(("Alex Kost" . "alezost@gmail.com"))
:maintainer
'("Alex Kost" . "alezost@gmail.com")
:keywords
'("convenience")
:url "https://github.com/alezost/dim.el")
;; Local Variables:
;; no-byte-compile: t
;; End:

2
lisp/dim.el → lisp/dim/dim.el
View File

@@ -5,8 +5,6 @@
;; Author: Alex Kost <alezost@gmail.com> ;; Author: Alex Kost <alezost@gmail.com>
;; Created: 24 Dec 2015 ;; Created: 24 Dec 2015
;; Version: 0.1 ;; Version: 0.1
;; Package-Version: 20160818.949
;; Package-Commit: 110624657fec0c8a7b3589108230e6a635302ae0
;; URL: https://github.com/alezost/dim.el ;; URL: https://github.com/alezost/dim.el
;; Keywords: convenience ;; Keywords: convenience
;; Package-Requires: ((emacs "24.4")) ;; Package-Requires: ((emacs "24.4"))

14
lisp/elisp-refs/elisp-refs-pkg.el Normal file
View File

@@ -0,0 +1,14 @@
(define-package "elisp-refs" "20230920.201" "find callers of elisp functions or macros"
'((dash "2.12.0")
(s "1.11.0"))
:commit "541a064c3ce27867872cf708354a65d83baf2a6d" :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:

80
lisp/elisp-refs.el → lisp/elisp-refs/elisp-refs.el
View File

@@ -3,9 +3,7 @@
;; 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.5 ;; Version: 1.6
;; 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"))
@@ -39,6 +37,10 @@
(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)
@@ -67,7 +69,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 f. report the position of the symbol foo.
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))
@@ -89,18 +91,25 @@ 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 () (defun elisp-refs--read-buffer-form (symbols-with-pos)
"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)
SYMBOL-POSITIONS are 0-indexed, relative to READ-START-POS." In Emacs 28 and earlier, SYMBOL-POSITIONS is a list of 0-indexed
symbol positions relative to READ-START-POS, according to
`read-symbol-positions-list'.
In Emacs 29+, SYMBOL-POSITIONS is nil. If SYMBOLS-WITH-POS is
non-nil, forms are read with `read-positioning-symbols'."
(let* ((read-with-symbol-positions t) (let* ((read-with-symbol-positions t)
(read-start-pos (point)) (read-start-pos (point))
(form (read (current-buffer))) (form (if (and symbols-with-pos (fboundp 'read-positioning-symbols))
(read-positioning-symbols (current-buffer))
(read (current-buffer))))
(symbols (if (boundp 'read-symbol-positions-list) (symbols (if (boundp 'read-symbol-positions-list)
read-symbol-positions-list read-symbol-positions-list
(read-positioning-symbols (current-buffer)))) nil))
(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)))
@@ -109,14 +118,14 @@ SYMBOL-POSITIONS are 0-indexed, relative to READ-START-POS."
"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) (defun elisp-refs--read-all-buffer-forms (buffer symbols-with-pos)
"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) forms)) (push (elisp-refs--read-buffer-form symbols-with-pos) 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,
@@ -130,12 +139,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 'format-proper-list-p) (if (fboundp 'proper-list-p)
;; Emacs stable. ;; `proper-list-p' was added in Emacs 27.1.
(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
@@ -171,7 +180,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 form subforms-positions) (--each (-zip-pair 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))
@@ -308,15 +317,41 @@ 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: don't bother walking a form if contains no ;; Optimisation: if we have a list of positions for the current
;; references to the symbol we're looking for. ;; form (Emacs 28 and earlier), and it doesn't contain the
(when (assq symbol symbol-positions) ;; symbol we're looking for, don't bother walking the form.
(when (or (null symbol-positions) (assq symbol symbol-positions))
(elisp-refs--walk buffer form start-pos end-pos symbol match-p))) (elisp-refs--walk buffer form start-pos end-pos symbol match-p)))
(elisp-refs--read-all-buffer-forms buffer)))) (elisp-refs--read-all-buffer-forms buffer nil))))
(defun elisp-refs--walk-positioned-symbols (forms symbol)
"Given a nested list of FORMS, return a list of all positions of SYMBOL.
Assumes `symbol-with-pos-pos' is defined (Emacs 29+)."
(cond
((symbol-with-pos-p forms)
(let ((symbols-with-pos-enabled t))
(if (eq forms symbol)
(list (list symbol
(symbol-with-pos-pos forms)
(+ (symbol-with-pos-pos forms) (length (symbol-name symbol))))))))
((elisp-refs--proper-list-p forms)
;; Proper list, use `--mapcat` to reduce how much we recurse.
(--mapcat (elisp-refs--walk-positioned-symbols it symbol) forms))
((consp forms)
;; Improper list, we have to recurse on head and tail.
(append (elisp-refs--walk-positioned-symbols (car forms) symbol)
(elisp-refs--walk-positioned-symbols (cdr forms) symbol)))
((vectorp forms)
(--mapcat (elisp-refs--walk-positioned-symbols it symbol) forms))))
(defun elisp-refs--read-and-find-symbol (buffer symbol) (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]
@@ -327,8 +362,7 @@ 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."
@@ -364,6 +398,7 @@ visiting the same file."
(file-name-handler-alist (file-name-handler-alist
'(("\\(?:\\.dz\\|\\.txz\\|\\.xz\\|\\.lzma\\|\\.lz\\|\\.g?z\\|\\.\\(?:tgz\\|svgz\\|sifz\\)\\|\\.tbz2?\\|\\.bz2\\|\\.Z\\)\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)?\\'" . '(("\\(?:\\.dz\\|\\.txz\\|\\.xz\\|\\.lzma\\|\\.lz\\|\\.g?z\\|\\.\\(?:tgz\\|svgz\\|sifz\\)\\|\\.tbz2?\\|\\.bz2\\|\\.Z\\)\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)?\\'" .
jka-compr-handler) jka-compr-handler)
("\\(?:^/\\)\\(\\(?:\\(?:\\(-\\|[[:alnum:]]\\{2,\\}\\)\\(?::\\)\\(?:\\([^/:|[:blank:]]+\\)\\(?:@\\)\\)?\\(\\(?:[%._[:alnum:]-]+\\|\\(?:\\[\\)\\(?:\\(?:[[:alnum:]]*:\\)+[.[:alnum:]]*\\)?\\(?:]\\)\\)\\(?:\\(?:#\\)\\(?:[[:digit:]]+\\)\\)?\\)?\\)\\(?:|\\)\\)+\\)?\\(?:\\(-\\|[[:alnum:]]\\{2,\\}\\)\\(?::\\)\\(?:\\([^/:|[:blank:]]+\\)\\(?:@\\)\\)?\\(\\(?:[%._[:alnum:]-]+\\|\\(?:\\[\\)\\(?:\\(?:[[:alnum:]]*:\\)+[.[:alnum:]]*\\)?\\(?:]\\)\\)\\(?:\\(?:#\\)\\(?:[[:digit:]]+\\)\\)?\\)?\\)\\(?::\\)\\([^\n ]*\\'\\)" . tramp-file-name-handler)
("\\`/:" . file-name-non-special)))) ("\\`/:" . file-name-non-special))))
(with-current-buffer fresh-buffer (with-current-buffer fresh-buffer
(setq-local elisp-refs--path path) (setq-local elisp-refs--path path)
@@ -779,7 +814,6 @@ search."
(define-key map (kbd "<backtab>") #'elisp-refs-prev-match) (define-key map (kbd "<backtab>") #'elisp-refs-prev-match)
(define-key map (kbd "n") #'elisp-refs-next-match) (define-key map (kbd "n") #'elisp-refs-next-match)
(define-key map (kbd "p") #'elisp-refs-prev-match) (define-key map (kbd "p") #'elisp-refs-prev-match)
(define-key map (kbd "q") #'kill-this-buffer)
(define-key map (kbd "RET") #'elisp-refs-visit-match) (define-key map (kbd "RET") #'elisp-refs-visit-match)
map) map)
"Keymap for `elisp-refs-mode'.") "Keymap for `elisp-refs-mode'.")

13
lisp/emacsql-sqlite-builtin/emacsql-sqlite-builtin-pkg.el Normal file
View File

@@ -0,0 +1,13 @@
(define-package "emacsql-sqlite-builtin" "20230409.1847" "EmacSQL back-end for SQLite using builtin support"
'((emacs "29")
(emacsql "20230220"))
:commit "f25de357fee74aae7a538e8eae3d9be5eb55c20e" :authors
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
:maintainers
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
:maintainer
'("Jonas Bernoulli" . "jonas@bernoul.li")
:url "https://github.com/magit/emacsql")
;; Local Variables:
;; no-byte-compile: t
;; End:

39
lisp/emacsql-sqlite-builtin.el → lisp/emacsql-sqlite-builtin/emacsql-sqlite-builtin.el
View File

@@ -5,39 +5,34 @@
;; Author: Jonas Bernoulli <jonas@bernoul.li> ;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql ;; Homepage: https://github.com/magit/emacsql
;; Package-Version: 20221127.2146 ;; Package-Version: 3.1.1.50-git
;; Package-X-Original-Version: 3.1.1.50-git ;; Package-Requires: ((emacs "29") (emacsql "20230220"))
;; Package-Requires: ((emacs "29") (emacsql "3.1.1"))
;; Package-Commit: 6b2e65bdf785364cf7c34c31fea5812e1e58c657
;; SPDX-License-Identifier: Unlicense ;; SPDX-License-Identifier: Unlicense
;;; Commentary: ;;; Commentary:
;; This package provides an EmacSQL back-end for SQLite, which uses ;; This library provides an EmacSQL back-end for SQLite, which uses
;; the built-in SQLite support in Emacs 29 an later. ;; the built-in SQLite support in Emacs 29 an later.
;;; Code: ;;; Code:
(require 'sqlite)
(require 'emacsql) (require 'emacsql)
(require 'emacsql-sqlite-common)
(require 'sqlite nil t)
(declare-function sqlite-open "sqlite")
(declare-function sqlite-select "sqlite")
(declare-function sqlite-close "sqlite")
(emacsql-register-reserved emacsql-sqlite-reserved) (emacsql-register-reserved emacsql-sqlite-reserved)
(defclass emacsql-sqlite-builtin-connection (emacsql-connection) (defclass emacsql-sqlite-builtin-connection (emacsql--sqlite-base) ()
((file :initarg :file "A connection to a SQLite database using builtin support.")
:type (or null string)
:documentation "Database file name.")
(types :allocation :class
:reader emacsql-types
:initform '((integer "INTEGER")
(float "REAL")
(object "TEXT")
(nil nil))))
(:documentation "A connection to a SQLite database using builtin support."))
(cl-defmethod initialize-instance :after (cl-defmethod initialize-instance :after
((connection emacsql-sqlite-builtin-connection) &rest _) ((connection emacsql-sqlite-builtin-connection) &rest _)
(setf (emacsql-process connection) (require (quote sqlite))
(oset connection handle
(sqlite-open (slot-value connection 'file))) (sqlite-open (slot-value connection 'file)))
(when emacsql-global-timeout (when emacsql-global-timeout
(emacsql connection [:pragma (= busy-timeout $s1)] (emacsql connection [:pragma (= busy-timeout $s1)]
@@ -58,11 +53,11 @@ buffer. This is for debugging purposes."
connection)) connection))
(cl-defmethod emacsql-live-p ((connection emacsql-sqlite-builtin-connection)) (cl-defmethod emacsql-live-p ((connection emacsql-sqlite-builtin-connection))
(and (emacsql-process connection) t)) (and (oref connection handle) t))
(cl-defmethod emacsql-close ((connection emacsql-sqlite-builtin-connection)) (cl-defmethod emacsql-close ((connection emacsql-sqlite-builtin-connection))
(sqlite-close (emacsql-process connection)) (sqlite-close (oref connection handle))
(setf (emacsql-process connection) nil)) (oset connection handle nil))
(cl-defmethod emacsql-send-message (cl-defmethod emacsql-send-message
((connection emacsql-sqlite-builtin-connection) message) ((connection emacsql-sqlite-builtin-connection) message)
@@ -74,7 +69,7 @@ buffer. This is for debugging purposes."
((numberp col) col) ((numberp col) col)
(t (read col)))) (t (read col))))
row)) row))
(sqlite-select (emacsql-process connection) message nil nil)) (sqlite-select (oref connection handle) message nil nil))
((sqlite-error sqlite-locked-error) ((sqlite-error sqlite-locked-error)
(if (stringp (cdr err)) (if (stringp (cdr err))
(signal 'emacsql-error (list (cdr err))) (signal 'emacsql-error (list (cdr err)))

8
lisp/emacsql-sqlite/emacsql-sqlite-pkg.el
View File

@@ -1,8 +1,10 @@
(define-package "emacsql-sqlite" "20221127.2146" "EmacSQL back-end for SQLite" (define-package "emacsql-sqlite" "20230225.2205" "EmacSQL back-end for SQLite"
'((emacs "25.1") '((emacs "25.1")
(emacsql "3.1.1")) (emacsql "20230220"))
:commit "6b2e65bdf785364cf7c34c31fea5812e1e58c657" :authors :commit "b436adf09ebe058c28e0f473bed90ccd7084f6aa" :authors
'(("Christopher Wellons" . "wellons@nullprogram.com")) '(("Christopher Wellons" . "wellons@nullprogram.com"))
:maintainers
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
:maintainer :maintainer
'("Jonas Bernoulli" . "jonas@bernoul.li") '("Jonas Bernoulli" . "jonas@bernoul.li")
:url "https://github.com/magit/emacsql") :url "https://github.com/magit/emacsql")

76
lisp/emacsql-sqlite/emacsql-sqlite.el
View File

@@ -7,22 +7,20 @@
;; Homepage: https://github.com/magit/emacsql ;; Homepage: https://github.com/magit/emacsql
;; Package-Version: 3.1.1.50-git ;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "3.1.1")) ;; Package-Requires: ((emacs "25.1") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense ;; SPDX-License-Identifier: Unlicense
;;; Commentary: ;;; Commentary:
;; This package provides the original EmacSQL back-end for SQLite, ;; This library provides the original EmacSQL back-end for SQLite,
;; which uses a custom binary for communicating with a SQLite database. ;; which uses a custom binary for communicating with a SQLite database.
;; During package installation an attempt is made to compile the binary. ;; During package installation an attempt is made to compile the binary.
;;; Code: ;;; Code:
(require 'cl-lib)
(require 'cl-generic)
(require 'eieio)
(require 'emacsql) (require 'emacsql)
(require 'emacsql-sqlite-common)
(emacsql-register-reserved emacsql-sqlite-reserved) (emacsql-register-reserved emacsql-sqlite-reserved)
@@ -57,32 +55,27 @@ Each is queried using `executable-find', so full paths are
allowed. Only the first compiler which is successfully found will allowed. Only the first compiler which is successfully found will
used.") used.")
(defclass emacsql-sqlite-connection (emacsql-connection emacsql-protocol-mixin) (defclass emacsql-sqlite-connection
((file :initarg :file (emacsql--sqlite-base emacsql-protocol-mixin) ()
:type (or null string) "A connection to a SQLite database.")
:documentation "Database file name.")
(types :allocation :class
:reader emacsql-types
:initform '((integer "INTEGER")
(float "REAL")
(object "TEXT")
(nil nil))))
(:documentation "A connection to a SQLite database."))
(cl-defmethod initialize-instance :after (cl-defmethod initialize-instance :after
((connection emacsql-sqlite-connection) &rest _rest) ((connection emacsql-sqlite-connection) &rest _rest)
(emacsql-sqlite-ensure-binary) (emacsql-sqlite-ensure-binary)
(let* ((process-connection-type nil) ; use a pipe (let* ((process-connection-type nil) ; use a pipe
(coding-system-for-write 'utf-8-auto) ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=60872#11.
(coding-system-for-read 'utf-8-auto) (coding-system-for-write 'utf-8)
(coding-system-for-read 'utf-8)
(file (slot-value connection 'file)) (file (slot-value connection 'file))
(buffer (generate-new-buffer " *emacsql-sqlite*")) (buffer (generate-new-buffer " *emacsql-sqlite*"))
(fullfile (if file (expand-file-name file) ":memory:")) (fullfile (if file (expand-file-name file) ":memory:"))
(process (start-process (process (start-process
"emacsql-sqlite" buffer emacsql-sqlite-executable fullfile))) "emacsql-sqlite" buffer emacsql-sqlite-executable fullfile)))
(setf (slot-value connection 'process) process) (oset connection handle process)
(setf (process-sentinel process) (set-process-sentinel process
(lambda (proc _) (kill-buffer (process-buffer proc)))) (lambda (proc _) (kill-buffer (process-buffer proc))))
(when (memq (process-status process) '(exit signal))
(error "%s has failed immediately" emacsql-sqlite-executable))
(emacsql-wait connection) (emacsql-wait connection)
(emacsql connection [:pragma (= busy-timeout $s1)] (emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2)) (/ (* emacsql-global-timeout 1000) 2))
@@ -95,18 +88,19 @@ If FILE is nil use an in-memory database.
:debug LOG -- When non-nil, log all SQLite commands to a log :debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes." buffer. This is for debugging purposes."
(let ((connection (make-instance 'emacsql-sqlite-connection :file file))) (let ((connection (make-instance 'emacsql-sqlite-connection :file file)))
(set-process-query-on-exit-flag (oref connection handle) nil)
(when debug (when debug
(emacsql-enable-debugging connection)) (emacsql-enable-debugging connection))
connection)) connection))
(cl-defmethod emacsql-close ((connection emacsql-sqlite-connection)) (cl-defmethod emacsql-close ((connection emacsql-sqlite-connection))
"Gracefully exits the SQLite subprocess." "Gracefully exits the SQLite subprocess."
(let ((process (emacsql-process connection))) (let ((process (oref connection handle)))
(when (process-live-p process) (when (process-live-p process)
(process-send-eof process)))) (process-send-eof process))))
(cl-defmethod emacsql-send-message ((connection emacsql-sqlite-connection) message) (cl-defmethod emacsql-send-message ((connection emacsql-sqlite-connection) message)
(let ((process (emacsql-process connection))) (let ((process (oref connection handle)))
(process-send-string process (format "%d " (string-bytes message))) (process-send-string process (format "%d " (string-bytes message)))
(process-send-string process message) (process-send-string process message)
(process-send-string process "\n"))) (process-send-string process "\n")))
@@ -130,9 +124,10 @@ buffer. This is for debugging purposes."
(cl-loop while (re-search-forward "-D[A-Z0-9_=]+" nil :no-error) (cl-loop while (re-search-forward "-D[A-Z0-9_=]+" nil :no-error)
collect (match-string 0))))) collect (match-string 0)))))
(defun emacsql-sqlite-compile (&optional o-level async) (defun emacsql-sqlite-compile (&optional o-level async error)
"Compile the SQLite back-end for EmacSQL, returning non-nil on success. "Compile the SQLite back-end for EmacSQL, returning non-nil on success.
If called with non-nil ASYNC the return value is meaningless." If called with non-nil ASYNC, the return value is meaningless.
If called with non-nil ERROR, signal an error on failure."
(let* ((cc (cl-loop for option in emacsql-sqlite-c-compilers (let* ((cc (cl-loop for option in emacsql-sqlite-c-compilers
for path = (executable-find option) for path = (executable-find option)
if path return it)) if path return it))
@@ -147,26 +142,41 @@ If called with non-nil ASYNC the return value is meaningless."
(options (emacsql-sqlite-compile-switches)) (options (emacsql-sqlite-compile-switches))
(output (list "-o" emacsql-sqlite-executable)) (output (list "-o" emacsql-sqlite-executable))
(arguments (nconc cflags options files ldlibs output))) (arguments (nconc cflags options files ldlibs output)))
(cond ((not cc) (cond
(prog1 nil ((not cc)
(message "Could not find C compiler, skipping SQLite build"))) (funcall (if error #'error #'message)
(t (message "Compiling EmacSQL SQLite binary ...") "Could not find C compiler, skipping SQLite build")
nil)
(t
(message "Compiling EmacSQL SQLite binary...")
(mkdir (file-name-directory emacsql-sqlite-executable) t) (mkdir (file-name-directory emacsql-sqlite-executable) t)
(let ((log (get-buffer-create byte-compile-log-buffer))) (let ((log (get-buffer-create byte-compile-log-buffer)))
(with-current-buffer log (with-current-buffer log
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(insert (mapconcat #'identity (cons cc arguments) " ") "\n") (insert (mapconcat #'identity (cons cc arguments) " ") "\n")
(eql 0 (apply #'call-process cc nil (if async 0 t) t (let ((pos (point))
arguments))))))))) (ret (apply #'call-process cc nil (if async 0 t) t
arguments)))
(cond
((zerop ret)
(message "Compiling EmacSQL SQLite binary...done")
t)
((and error (not async))
(error "Cannot compile EmacSQL SQLite binary: %S"
(replace-regexp-in-string
"\n" " "
(buffer-substring-no-properties
pos (point-max))))))))))))))
;;; Ensure the SQLite binary is available ;;; Ensure the SQLite binary is available
(defun emacsql-sqlite-ensure-binary () (defun emacsql-sqlite-ensure-binary ()
"Ensure the EmacSQL SQLite binary is available, signaling an error if not." "Ensure the EmacSQL SQLite binary is available, signaling an error if not."
(unless (file-exists-p emacsql-sqlite-executable) (unless (file-exists-p emacsql-sqlite-executable)
;; try compiling at the last minute ;; Try compiling at the last minute.
(unless (ignore-errors (emacsql-sqlite-compile 2)) (condition-case err
(error "No EmacSQL SQLite binary available, aborting")))) (emacsql-sqlite-compile 2 nil t)
(error (error "No EmacSQL SQLite binary available: %s" (cdr err))))))
(provide 'emacsql-sqlite) (provide 'emacsql-sqlite)

BIN
lisp/emacsql-sqlite/sqlite/emacsql-sqlite
View File

Binary file not shown.

435
lisp/emacsql/README.md
View File

@@ -1,435 +0,0 @@
# EmacSQL
EmacSQL is a high-level Emacs Lisp front-end for SQLite (primarily),
PostgreSQL, MySQL, and potentially other SQL databases.
Any [readable lisp value][readable] can be stored as a value in
EmacSQL, including numbers, strings, symbols, lists, vectors, and
closures. EmacSQL has no concept of "TEXT" values; it's all just lisp
objects. The lisp object `nil` corresponds 1:1 with `NULL` in the
database.
On MELPA, each back-end is provided as a separate package, suffixed with
the database name. In the case of `emacsql-sqlite`, on first use EmacSQL
will attempt to find a C compiler and use it to compile a custom native
binary for communicating with a SQLite database.
Requires Emacs 25 or later.
### FAQ
#### Why are all values stored as strings?
EmacSQL is not intended to interact with arbitrary databases, but to
be an ACID-compliant database for Emacs extensions. This means that
EmacSQL cannot be used with a regular SQL database used by other
non-Emacs clients.
All database values must be s-expressions. When EmacSQL stores a
value — string, symbol, cons, etc. — it is printed and written to
the database in its printed form. Strings are wrapped in quotes
and escaped as necessary. That means "bare" symbols in the database
generally look like strings. The only exception is `nil`, which is
stored as `NULL`.
#### Will EmacSQL ever support arbitrary databases?
The author of EmacSQL [thinks][mistake] that it was probably a
design mistake to restrict it to Emacs by storing only printed values,
and that it would be a lot more useful if it just handled primitive
database types.
However, EmacSQL is in maintenance mode and there are no plans to
make any fundamental changes, not least because they would break all
existing packages and databases that rely on the current EmacSQL
behavior.
### Windows Issues
Emacs `start-process-shell-command` function is not supported on
Windows. Since both `emacsql-mysql` and `emacsql-psql` rely on this
function, neither of these connection types are supported on Windows.
## Example Usage
```el
(defvar db (emacsql-sqlite "~/company.db"))
;; Create a table. Table and column identifiers are symbols.
(emacsql db [:create-table people ([name id salary])])
;; Or optionally provide column constraints.
(emacsql db [:create-table people
([name (id integer :primary-key) (salary float)])])
;; Insert some data:
(emacsql db [:insert :into people
:values (["Jeff" 1000 60000.0] ["Susan" 1001 64000.0])])
;; Query the database for results:
(emacsql db [:select [name id]
:from people
:where (> salary 62000)])
;; => (("Susan" 1001))
;; Queries can be templates, using $1, $2, etc.:
(emacsql db [:select [name id]
:from people
:where (> salary $s1)]
50000)
;; => (("Jeff" 1000) ("Susan" 1001))
```
When editing these prepared SQL s-expression statements, the `M-x
emacsql-show-last-sql` command (think `eval-last-sexp`) is useful for
seeing what the actual SQL expression will become when compiled.
## Schema
A table schema is a list whose first element is a vector of column
specifications. The rest of the list specifies table constraints. A
column identifier is a symbol and a column's specification can either
be just this symbol or it can include constraints as a list. Because
EmacSQL stores entire lisp objects as values, the only relevant (and
allowed) types are `integer`, `float`, and `object` (default).
([(<column>) ...] (<table-constraint> ...) ...])
Dashes in identifiers are converted into underscores when compiled
into SQL. This allows for lisp-style identifiers to be used in SQL.
Constraints follow the compilation rules below.
```el
;; No constraints schema with four columns:
([name id building room])
;; Add some column constraints:
([(name :unique) (id integer :primary-key) building room])
;; Add some table constraints:
([(name :unique) (id integer :primary-key) building room]
(:unique [building room])
(:check (> id 0)))
```
Here's an example using foreign keys.
```el
;; "subjects" table schema
([(id integer :primary-key) subject])
;; "tag" table references subjects
([(subject-id integer) tag]
(:foreign-key [subject-id] :references subjects [id]
:on-delete :cascade))
```
Foreign key constraints are enabled by default in EmacSQL.
## Operators
Expressions are written lisp-style, with the operator first. If it
looks like an operator EmacSQL treats it like an operator. However,
several operators are special.
<= >= funcall quote
The `<=` and `>=` operators accept 2 or 3 operands, transforming into
a SQL `_ BETWEEN _ AND _` operator as appropriate.
For function-like "operators" like `count` and `max` use the `funcall`
"operator."
```el
[:select (funcall max age) :from people]
```
Inside expressions, EmacSQL cannot tell the difference between symbol
literals and column references. If you're talking about the symbol
itself, just quote it as you would in normal Elisp. Note that this
does not "escape" `$tn` parameter symbols.
```el
(emacsql db [... :where (= category 'hiking)])
```
Quoting a string makes EmacSQL handle it as a "raw string." These raw
strings are not printed when being assembled into a query. These are
intended for use in special circumstances like filenames (`ATTACH`) or
pattern matching (`LIKE`). It is vital that raw strings are not
returned as results.
```el
(emacsql db [... :where (like name '"%foo%")])
(emacsql db [:attach '"/path/to/foo.db" :as foo])
```
Since template parameters include their type they never need to be
quoted.
With `glob` and `like` SQL operators keep in mind that they're
matching the *printed* representations of these values, even if the
value is a string.
The `||` concatenation operator is unsupported because concatenating
printed representations breaks an important constraint: all values must
remain readable within SQLite.
## Prepared Statements
The database is interacted with via prepared SQL s-expression
statements. You shouldn't normally be concatenating strings on your
own. (And it leaves out any possibility of a SQL injection!) See the
"Usage" section above for examples. A statement is a vector of
keywords and other lisp object.
Prepared EmacSQL s-expression statements are compiled into SQL
statements. The statement compiler is memorized so that using the same
statement multiple times is fast. To assist in this, the statement can
act as a template -- using `$i1`, `$s2`, etc. -- working like the
Elisp `format` function.
### Compilation Rules
Rather than the typical uppercase SQL keywords, keywords in a prepared
EmacSQL statement are literally just that: lisp keywords. EmacSQL only
understands a very small amount of SQL's syntax. The compiler follows
some simple rules to convert an s-expression into SQL.
#### All prepared statements are vectors.
A prepared s-expression statement is a vector beginning with a keyword
followed by a series of keywords and special values. This includes
most kinds of sub-queries.
```el
[:select ... :from ...]
[:select tag :from tags
:where (in tag [:select ...])]
```
#### Keywords are split and capitalized.
Dashes are converted into spaces and the keyword gets capitalized. For
example, `:if-not-exists` becomes `IF NOT EXISTS`. How you choose to
combine keywords is up to your personal taste (e.g. `:drop :table` vs.
`:drop-table`).
#### Standalone symbols are identifiers.
EmacSQL doesn't know what symbols refer to identifiers and what
symbols should be treated as values. Use quotes to mark a symbol as a
value. For example, `people` here will be treated as an identifier.
```el
[:insert-into people :values ...]
```
#### Row-oriented information is always represented as vectors.
This includes rows being inserted, and sets of columns in a query. If
you're talking about a row-like thing then put it in a vector.
```el
[:select [id name] :from people]
```
Note that `*` is actually a SQL keyword, so don't put it in a vector.
```el
[:select * :from ...]
```
#### Lists are treated as expressions.
This is true even within row-oriented vectors.
```el
[... :where (= name "Bob")]
[:select [(/ seconds 60) count] :from ...]
```
Some things that are traditionally keywords -- particularly those that
are mixed in with expressions -- have been converted into operators
(`AS`, `ASC`, `DESC`).
```el
[... :order-by [(asc b), (desc a)]] ; "ORDER BY b ASC, a DESC"
[:select p:name :from (as people p)] ; "SELECT p.name FROM people AS p"
```
#### The `:values` keyword is special.
What follows `:values` is always treated like a vector or list of
vectors. Normally this sort of thing would appear to be a column
reference.
```el
[... :values [1 2 3]]
[... :values ([1 2 3] [4 5 6])] ; insert multiple rows
```
#### A list whose first element is a vector is a table schema.
This is to distinguish schemata from everything else. With the
exception of what follows `:values`, nothing else is shaped like this.
```el
[:create-table people ([(id :primary-key) name])]
```
### Templates
To make statement compilation faster, and to avoid making you build up
statements dynamically, you can insert `$tn` parameters in place of
identifiers and values. These refer to the argument's type and its
argument position after the statement in the `emacsql` function,
one-indexed.
```el
(emacsql db [:select * :from $i1 :where (> salary $s2)] 'employees 50000)
(emacsql db [:select * :from employees :where (like name $r1)] "%Smith%")
```
The letter before the number is the type.
* `i` : identifier
* `s` : scalar
* `v` : vector (or multiple vectors)
* `r` : raw, unprinted strings
* `S` : schema
When combined with `:values`, the vector type can refer to lists of
rows.
```el
(emacsql db [:insert-into favorite-characters :values $v1]
'([0 "Calvin"] [1 "Hobbes"] [3 "Susie"]))
```
This is why rows must be vectors and not lists.
## SQLite Support
The custom EmacSQL SQLite binary is compiled with [Soundex][soundex] and
[full-text search][fts] (FTS3, FTS4, and FTS5) enabled -- features
disabled by the default SQLite build. This back-end should work on any
system with a conforming ANSI C compiler installed under a command name
listed in `emacsql-sqlite-c-compilers`.
### Ignored Features
EmacSQL doesn't cover all of SQLite's features. Here are a list of
things that aren't supported, and probably will never be.
* Collating. SQLite has three built-in collation functions: BINARY
(default), NOCASE, and RTRIM. EmacSQL values never have right-hand
whitespace, so RTRIM won't be of any use. NOCASE is broken
(ASCII-only) and there's little reason to use it.
* Text manipulation functions. Like collating this is incompatible
with EmacSQL s-expression storage.
* Date and time. These are incompatible with the printed values
stored by EmacSQL and therefore have little use.
## Limitations
EmacSQL is *not* intended to play well with other programs accessing
the SQLite database. Non-numeric values are stored encoded as
s-expressions TEXT values. This avoids ambiguities in parsing output
from the command line and allows for storage of Emacs richer data
types. This is an efficient, ACID-compliant database specifically for
Emacs.
## Emacs Lisp Indentation Annoyance
By default, `emacs-lisp-mode` indents vectors as if they were regular
function calls.
```el
;; Ugly indentation!
(emacsql db [:select *
:from people
:where (> age 60)])
```
Calling the function `emacsql-fix-vector-indentation` (interactive)
advises the major mode to fix this annoyance.
```el
;; Such indent!
(emacsql db [:select *
:from people
:where (> age 60)])
```
## Contributing and Extending
To run the test suite, clone the `pg` and `finalize` packages into
sibling directories. The Makefile will automatically put these paths on
the Emacs load path (override `LDFLAGS` if your situation is different).
$ cd ..
$ git clone https://github.com/cbbrowne/pg.el pg
$ git clone https://github.com/skeeto/elisp-finalize finalize
$ cd -
Then invoke make:
$ make test
If the environment variable `PGDATABASE` is present then the unit
tests will also be run with PostgreSQL (emacsql-psql). Provide
`PGHOST`, `PGPORT`, and `PGUSER` if needed. If `PGUSER` is provided,
the pg.el back-end (emacsql-pg) will also be tested.
If the environment variable `MYSQL_DBNAME` is present then the unit
tests will also be run with MySQL in the named database. Note that
this is not an official MySQL variable, just something made up for
EmacSQL.
### Creating a New Front-end
EmacSQL uses EIEIO so that interactions with a connection occur
through generic functions. You need to define a new class that
inherits from `emacsql-connection`.
* Implement `emacsql-send-message`, `emacsql-waiting-p`,
`emacsql-parse`, and `emacsql-close`.
* Provide a constructor that initializes the connection and calls
`emacsql-register` (for automatic connection cleanup).
* Provide `emacsql-types` if needed (hint: use a class-allocated slot).
* Ensure that you properly read NULL as nil (hint: ask your back-end
to print it that way).
* Register all reserved words with `emacsql-register-reserved`.
* Preferably provide `emacsql-reconnect` if possible.
* Set the default isolation level to *serializable*.
* Enable autocommit mode by default.
* Prefer ANSI syntax (value escapes, identifier escapes, etc.).
* Enable foreign key constraints by default.
The goal of the autocommit, isolation, parsing, and foreign key
configuration settings is to normalize the interface as much as
possible. The connection's user should have the option to be agnostic
about which back-end is actually in use.
The provided implementations should serve as useful examples. If your
back-end outputs data in a clean, standard way you may be able to use
the emacsql-protocol-mixin class to do most of the work.
## See Also
* [SQLite Documentation](https://www.sqlite.org/docs.html)
[readable]: http://nullprogram.com/blog/2013/12/30/#almost_everything_prints_readably
[stderr]: http://thread.gmane.org/gmane.comp.db.sqlite.general/85824
[foreign]: http://www.sqlite.org/foreignkeys.html
[batch]: http://lists.gnu.org/archive/html/emacs-pretest-bug/2005-11/msg00320.html
[fts]: http://www.sqlite.org/fts3.html
[soundex]: http://www.sqlite.org/compile.html#soundex
[mistake]: https://github.com/magit/emacsql/issues/35#issuecomment-346352439
<!-- LocalWords: EIEIO Elisp EmacSQL FTS MELPA Makefile NOCASE RTRIM SQL's Soundex -->
<!-- LocalWords: autocommit el emacsql mixin psql schemas unprinted whitespace -->

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