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

210
lisp/treemacs/treemacs-icons.el
View File

@@ -1,6 +1,6 @@
;;; treemacs.el --- A tree style file viewer package -*- lexical-binding: t -*-
;; Copyright (C) 2022 Alexander Miller
;; Copyright (C) 2023 Alexander Miller
;; 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
@@ -29,48 +29,13 @@
(require 'ht)
(require 'treemacs-themes)
(require 'treemacs-logging)
(require 'treemacs-scope)
(eval-when-compile
(require 'cl-lib)
(require 'inline)
(require 'treemacs-macros))
;; An explanation for the what and why of the icon highlighting code below:
;; Using png images in treemacs has one annoying visual flaw: they overwrite the overlay
;; used by hl-line, such that the line marked by hl-line will always show a 22x22 pixel
;; gap wherever treemacs places an icon, regardess of transparency.
;; Using xpm instead of png images is one way to work around this, but it degrades icon
;; quality to an unacceptable degree. Another way is to directly change images' :background
;; property. The backgrounds colours are derived from the current theme with `treemacs--setup-icon-highlight'
;; and saved in `treemacs--selected-icon-background' and `treemacs--not-selected-icon-background'.
;; Every icon string stores two images with the proper :background values in its properties
;; 'img-selected and 'img-unselected. The 'display property of the icon in the current line
;; is then highlighted, and the previously highlighted icon unhighlighted, by advising
;; `hl-line-highlight'. The last displayed icon is saved as a button marker in `treemacs--last-highlight'.
;; Since it is a marker in the treemacs buffer it is important for it to be reset whenever it might
;; become invalid.
(eval-and-compile
(defvar treemacs--not-selected-icon-background
(pcase (face-attribute 'default :background nil t)
((or 'unspecified 'unspecified-bg "unspecified" "unspecified-bg")
(unless (or noninteractive (boundp 'treemacs-no-load-time-warnings))
(message "[Treemacs] Warning: coudn't find default background colour for icons, falling back on #2d2d31."))
"#2d2d31" )
(other other)))
"Background for non-selected icons.")
(eval-and-compile
(defvar treemacs--selected-icon-background
(-let [bg (face-attribute 'hl-line :background nil t)]
(if (member bg '(unspecified unspecified-b "unspecified" "unspecified-bg"))
(prog1 treemacs--not-selected-icon-background
(unless (or noninteractive (boundp 'treemacs-no-load-time-warnings))
(message "[Treemacs] Warning: couldn't find hl-line-mode's background color for icons, falling back on %s."
treemacs--not-selected-icon-background)))
bg)))
"Background for selected icons.")
(define-inline treemacs--set-img-property (image property value)
"Set IMAGE's PROPERTY to VALUE."
;; the emacs26 code where this is copied from says it's for internal
@@ -115,33 +80,6 @@ account."
(plist-get it :background)
(face-attribute ,face :background nil t)))))
(defun treemacs--setup-icon-background-colors (&rest _)
"Align icon backgrounds with current Emacs theme.
Fetch the current Emacs theme's background & hl-line colours and inject them
into the gui icons of every theme in `treemacs--themes'.
Also called as advice after `load-theme', hence the ignored argument."
(let* ((default-background (treemacs--get-local-face-background 'default))
(hl-line-background (treemacs--get-local-face-background 'hl-line))
(test-icon (treemacs-get-icon-value 'dir-open))
(icon-background (treemacs--get-img-property (get-text-property 0 'img-unselected test-icon) :background))
(icon-hl-background (treemacs--get-img-property (get-text-property 0 'img-selected test-icon) :background)))
(when (memq default-background '(unspecified-bg unspecified))
(treemacs-log-failure "Current theme fails to specify default background color, falling back on #2d2d31")
(setq default-background "#2d2d31"))
;; make sure we only change all the icons' colors when we have to
(unless (and (string= default-background icon-background)
(string= hl-line-background icon-hl-background))
(setf treemacs--selected-icon-background hl-line-background
treemacs--not-selected-icon-background default-background)
(dolist (theme treemacs--themes)
(treemacs--maphash (treemacs-theme->gui-icons theme) (_ icon)
(treemacs--set-img-property
(get-text-property 0 'img-selected icon)
:background treemacs--selected-icon-background)
(treemacs--set-img-property
(get-text-property 0 'img-unselected icon)
:background treemacs--not-selected-icon-background))))))
(define-inline treemacs--is-image-creation-impossible? ()
"Will return non-nil when Emacs is unable to create images.
In this scenario (usually caused by running Emacs without a graphical
@@ -183,37 +121,40 @@ Necessary since root icons are not rectangular."
(h (round (* ,height 1.1818))))
(setq ,width w ,height h)))
(define-inline treemacs--create-image (file-path)
(defun treemacs--create-image (file-path)
"Load image from FILE-PATH and size it based on `treemacs--icon-size'."
(inline-letevals (file-path)
(inline-quote
(let ((height treemacs--icon-size)
(width treemacs--icon-size))
(when (and (integerp treemacs--icon-size)
(s-starts-with? "root-" ,file-path))
(treemacs--root-icon-size-adjust width height))
(if (and (integerp treemacs--icon-size) (image-type-available-p 'imagemagick))
(create-image ,file-path 'imagemagick nil :ascent 'center :width width :height height)
(create-image ,file-path 'png nil :ascent 'center :width width :height height))))))
(let ((height treemacs--icon-size)
(width treemacs--icon-size))
(when (and (integerp treemacs--icon-size)
(s-starts-with? "root-" file-path))
(treemacs--root-icon-size-adjust width height))
(if (and (integerp treemacs--icon-size) (image-type-available-p 'imagemagick))
(create-image
file-path 'imagemagick nil
:ascent 'center
:width width
:height height
:mask 'heuristic)
(create-image
file-path
(intern (treemacs--file-extension (treemacs--filename file-path)))
nil
:ascent 'center
:width width
:height height
:mask 'heuristic))))
(define-inline treemacs--create-icon-strings (file fallback)
(defun treemacs--create-icon-strings (file fallback)
"Create propertized icon strings for a given FILE image and TUI FALLBACK."
(inline-letevals (file fallback)
(inline-quote
(let ((tui-icon ,fallback)
(gui-icon
(if (treemacs--is-image-creation-impossible?)
,fallback
(let* ((img-selected (treemacs--create-image ,file))
(img-unselected (copy-sequence img-selected)))
(nconc img-selected `(:background ,treemacs--selected-icon-background))
(nconc img-unselected `(:background ,treemacs--not-selected-icon-background))
(concat (propertize " "
'display img-unselected
'img-selected img-selected
'img-unselected img-unselected)
" ")))))
(cons gui-icon tui-icon)))))
(let ((tui-icon fallback)
(gui-icon
(if (treemacs--is-image-creation-impossible?)
fallback
(concat (propertize
" "
'display (treemacs--create-image file))
" "))))
(cons gui-icon tui-icon)))
(defmacro treemacs--splice-icon (icon)
"Splice the given ICON data depending on whether it is a value or an sexp."
@@ -242,7 +183,6 @@ Necessary since root icons are not rectangular."
(when (and (consp extensions) (or (symbolp (car extensions))
(stringp (car extensions))))
(setf extensions `(quote (,@extensions))))
;; (setf extensions (--map (if (stringp it) (downcase it) it) extensions))
`(let* ((xs (--map (if (stringp it) (downcase it) it) ,extensions))
(fallback ,(if (equal fallback (quote 'same-as-icon))
icon
@@ -269,7 +209,13 @@ Necessary since root icons are not rectangular."
(add-to-list 'treemacs--icon-symbols ext)
(set symbol nil))))
(--each xs
(ht-set! gui-icons it gui-icon)
;; NOTE: Disable creation of GUI svg icons without getting in the way of the rest
;; of the icon creation process. This is good enough a workaround for Emacs versions
;; that don't support svg images for as long as svg icons are a minority.
(unless (and ,file
(not (image-type-available-p 'svg))
(string= (treemacs--file-extension ,file) "svg"))
(ht-set! gui-icons it gui-icon))
(ht-set! tui-icons it tui-icon))))
(treemacs-create-theme "Default"
@@ -299,10 +245,46 @@ Necessary since root icons are not rectangular."
(treemacs-create-icon :file "svgrepo/mail.png" :extensions (mail) :fallback " ")
(treemacs-create-icon :file "svgrepo/mail-plus.png" :extensions (mail-plus) :fallback " ")
;; custom dir icons
(treemacs-create-icon :file "svgrepo/dir-src-closed.png" :extensions ("src-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "svgrepo/dir-src-open.png" :extensions ("src-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "svgrepo/dir-test-closed.png" :extensions ("test-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "svgrepo/dir-test-open.png" :extensions ("test-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-binary-closed.png" :extensions ("bin-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-binary-open.png" :extensions ("bin-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-services-closed.png" :extensions ("build-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-services-open.png" :extensions ("build-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "svgrepo/dir-git-closed.png" :extensions ("git-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "svgrepo/dir-git-open.png" :extensions ("git-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-github-closed.png" :extensions ("github-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-github-open.png" :extensions ("github-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-public-closed.png" :extensions ("public-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-public-open.png" :extensions ("public-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-private-closed.png" :extensions ("private-closed") :fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon :file "vsc/dir-private-open.png" :extensions ("private-open") :fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-temp-closed.png" :extensions ("temp-closed" "tmp-closed")
:fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-temp-open.png" :extensions ("temp-open" "tmp-open")
:fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-docs-closed.png" :extensions ("readme-closed" "docs-closed")
:fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-docs-open.png" :extensions ("readme-open" "docs-open")
:fallback (propertize "- " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-images-closed.png" :extensions ("screenshots-closed" "icons-closed")
:fallback (propertize "+ " 'face 'treemacs-term-node-face))
(treemacs-create-icon
:file "vsc/dir-images-open.png" :extensions ("screenshots-open" "icons-open")
:fallback (propertize "- " 'face 'treemacs-term-node-face))
;; file icons
(treemacs-create-icon :file "txt.png" :extensions (fallback))
(treemacs-create-icon :file "emacs.png" :extensions ("el" "elc" "eln"))
(treemacs-create-icon :file "ledger.png" :extensions ("ledger"))
(treemacs-create-icon :file "ledger.png" :extensions ("ledger" "beancount"))
(treemacs-create-icon :file "yaml.png" :extensions ("yml" "yaml" "travis.yml"))
(treemacs-create-icon
:file "shell.png"
@@ -452,6 +434,7 @@ Necessary since root icons are not rectangular."
(define-inline treemacs-icon-for-file (file)
"Retrieve an icon for FILE from `treemacs-icons' based on its extension.
Works only with files, not directories.
Uses `treemacs-icon-fallback' as fallback."
(declare (side-effect-free t))
(inline-letevals (file)
@@ -462,6 +445,28 @@ Uses `treemacs-icon-fallback' as fallback."
(treemacs--file-extension file-downcased)
(with-no-warnings treemacs-icon-fallback)))))))
(define-inline treemacs-icon-for-dir (dir state)
"Retrieve an icon for DIR from `treemacs-icons' in given STATE.
STATE must be either `open' or `closed'.
Works only with directories, not files.
Uses the `dir-open' and `dir-closed' icons as fallback."
(declare (side-effect-free t))
(inline-letevals (dir state)
(inline-quote
(let ((name-downcased (-> ,dir (treemacs--filename) (downcase))))
(when (eq ?. (aref name-downcased 0))
(setf name-downcased (substring name-downcased 1)))
(pcase-exhaustive ,state
(`open
(let ((name (format "%s-%s" name-downcased "open")))
(or (ht-get treemacs-icons name)
(ht-get treemacs-icons 'dir-open))))
(`closed
(let ((name (format "%s-%s" name-downcased "closed")))
(or (ht-get treemacs-icons name)
(ht-get treemacs-icons 'dir-closed)))))))))
;;;###autoload
(defun treemacs-resize-icons (size)
"Resize the current theme's icons to the given SIZE.
@@ -484,17 +489,14 @@ png are changed."
(treemacs-log-failure "Icons cannot be resized without image transforms or imagemagick support.")
(setq treemacs--icon-size size)
(treemacs--maphash (treemacs-theme->gui-icons treemacs--current-theme) (_ icon)
(let ((display (get-text-property 0 'display icon))
(img-selected (get-text-property 0 'img-selected icon))
(img-unselected (get-text-property 0 'img-unselected icon))
(width treemacs--icon-size)
(height treemacs--icon-size))
(let ((display (get-text-property 0 'display icon))
(width treemacs--icon-size)
(height treemacs--icon-size))
(when (eq 'image (car-safe display))
(when (s-ends-with? "root.png" (plist-get (cdr display) :file))
(treemacs--root-icon-size-adjust width height))
(dolist (property (list display img-selected img-unselected))
(plist-put (cdr property) :height height)
(plist-put (cdr property) :width width)))))))
(plist-put (cdr display) :height height)
(plist-put (cdr display) :width width))))))
(defun treemacs--select-icon-set ()
"Select the right set of icons for the current buffer.
@@ -529,7 +531,7 @@ Return the fallback icons if TUI is non-nil."
Note that treemacs has a very loose definition of what constitutes a file
extension - it's either everything past the last period, or just the file's full
name if there is no period. This makes it possible to match file names like
'.gitignore' and 'Makefile'.
\\='.gitignore' and \\='Makefile'.
Additionally FILE-EXTENSIONS are also not case sensitive and will be stored in a
down-cased state."