branch: externals/svg-tag-mode
commit 29ca63cdbb82fed55830b40f8866de123a5bef5e
Author: Nicolas P. Rougier <nicolas.roug...@inria.fr>
Commit: Nicolas P. Rougier <nicolas.roug...@inria.fr>
Rewrote the mode using svg-lib
---
README.md | 95 ++++++++
README.org | 23 --
svg-tag-on.png => images/svg-minor-mode.png | Bin
svg-tag-mode.el | 338 ++++++++++++++++------------
svg-tag-off.png | Bin 289428 -> 0 bytes
5 files changed, 291 insertions(+), 165 deletions(-)
diff --git a/README.md b/README.md
new file mode 100644
index 0000000000..487a39cf5b
--- /dev/null
+++ b/README.md
@@ -0,0 +1,95 @@
+
+## svg-tag-mode
+
+A minor mode to replace keywords or regular expression with SVG tags.
+
+
+
+
+### Usage example
+
+You need first to set `svg-tag-tags` that is a list of item here each
+item has the form `(KEYWORD (TAG COMMAND HELP))` where:
+
+- **KEYWORD** is a regular expression including a matched group of
+ the form "\\(xxx\\)". If this is not the case the whole
+ string will be used a the matched group.
+- **TAG** is either a SVG image that will be displayed using the
+ 'display property or a function that accepts a unique string
+ argument (match-string 1) and returns an SVG image.
+- **COMMAND** is a command to be executed when user clicks on the tag.
+ It can be nil if no command is associated with the tag.
+- **HELP** is a string to be displayed when mouse pointer is over
+ the tag. It can be nil if no command is associated with the tag.
+
+then you can invoke mode with `M-x svg-tag-mode`. Here are some examples:
+
+
+1. Replace any occurence of `:TODO:` with a static SVG tag displaying `TODO`
+
+```lisp
+(setq svg-tag-tags
+ '((":TODO:" . ((svg-tag-make "TODO")))))
+```
+
+2. Replace any occurence of `:HELLO:` with a static SVG tag displaying
+ `HELLO` that can be clicked to execute the specified command. Help
+ message is displayed when the tag is hovered with the pointer.
+
+```lisp
+(setq svg-tag-tags
+ '((":HELLO:" . ((svg-tag-make "HELLO")
+ (lambda () (interactive) (message "Hello world!"))
+ "Print a greeting message"))))
+```
+
+
+3. Replace any occurence of `:TODO:` with a static SVG tag displaying
+ `:TODO:`
+
+```lisp
+(setq svg-tag-tags
+ '((":TODO:" . (svg-tag-make))))
+```
+
+4. Replace any occurence of `:TODO:` with a dynamic SVG tag displaying `TODO`
+
+```lisp
+(setq svg-tag-tags
+ '((":TODO:" . ((lambda (tag)
+ (svg-tag-make tag :beg 1 :end -1))))))
+```
+
+5. Replaces any occurence of `:XXX:` with a dynamic SVG tag displaying `XXX`
+
+```lisp
+(setq svg-tag-tags
+ '(("\\(:[A-Z]+:\\)" . ((lambda (tag)
+ (svg-tag-make tag :beg 1 :end -1))))))
+```
+
+6. Replaces any occurence of `:XXX|YYY:` with two adjacent dynamic SVG
+ tags displaying `XXX` and `YYY`
+
+```lisp
+(setq svg-tag-tags
+ '(("\\(:[A-Z]+\\)\|[a-zA-Z#0-9]+:" . ((lambda (tag)
+ (svg-tag-make tag :beg 1 :inverse t
+ :margin 0
:crop-right t))))
+ (":[A-Z]+\\(\|[a-zA-Z#0-9]+:\\)" . ((lambda (tag)
+ (svg-tag-make tag :beg 1 :end -1
+ :margin 0 :crop-left
t))))))
+```
+
+7. This replaces any occurence of `:#TAG1:#TAG2:…:$` (`$` means end of
+ line) with a dynamic collection of SVG tags. Note the `#` symbol in
+ front of tags. This is mandatory because Emacs cannot do regex look
+ ahead.
+
+```lisp
+(setq svg-tag-tags
+ '(("\\(:#[A-Za-z0-9]+\\)" . ((lambda (tag)
+ (svg-tag-make tag :beg 2))))
+ ("\\(:#[A-Za-z0-9]+:\\)$" . ((lambda (tag)
+ (svg-tag-make tag :beg 2 :end -1))))))
+```
diff --git a/README.org b/README.org
deleted file mode 100644
index ff7e449e7d..0000000000
--- a/README.org
+++ /dev/null
@@ -1,23 +0,0 @@
-** SVG tag minor mode (Emacs)
-
-A small minor mode to replace keywords or regular expression with SVG rounded
-box labels. See [[file:examples/example-1.el][example-1.el]] and
[[file:examples/example-2.el][example-2.el]] for example usage.
-
-*** Installation
-
-#+begin_src elisp
-(quelpa '(svg-tag-mode :repo "rougier/svg-tag-mode"
- :fetcher github
- :files ("svg-tag-mode.el")))
-#+end_src
-
-*** Demonstration
-
-Open [[file:examples/example-1.el][example-1.el]] and evaluate buffer (*M-x
evaluate-buffer*)
-
-*SVG tag mode on*
-[[./svg-tag-on.png]]
-
-*SVG tag mode off*
-[[./svg-tag-off.png]]
-
diff --git a/svg-tag-on.png b/images/svg-minor-mode.png
similarity index 100%
rename from svg-tag-on.png
rename to images/svg-minor-mode.png
diff --git a/svg-tag-mode.el b/svg-tag-mode.el
index ee839d944e..06324c8dc3 100644
--- a/svg-tag-mode.el
+++ b/svg-tag-mode.el
@@ -1,13 +1,13 @@
;;; svg-tag-mode.el --- Replace keywords with SVG tags -*- lexical-binding: t
-*-
-;; Copyright (C) 2020 Nicolas P. Rougier
+;; Copyright (C) 2020,2021 Nicolas P. Rougier
;; Author: Nicolas P. Rougier <nicolas.roug...@inria.fr>
;; Homepage: https://github.com/rougier/svg-tag-mode
;; Keywords: convenience
-;; Version: 0.1
+;; Version: 0.2
-;; Package-Requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1" svg-lib "0.3"))
;; This file is not part of GNU Emacs.
@@ -26,83 +26,104 @@
;;; Commentary:
-;; This minor mode replaces keywords or expressions with SVG rounded
-;; box labels that are fully customizable.
+;; This minor mode replaces keywords or expressions with SVG tags
+;; that are fully customizable and clickable.
;;
;; Usage example:
;; --------------
;;
-;; 1. Replace :TODO: keyword with default face/padding/radius
+;; (setq svg-tag-tags '((":TODO:" ((svg-tag-make "TODO") nil nil))))
;;
-;; (setq svg-tag-tags '((":TODO:" (svg-tag-make "TODO")))
-;; (svg-tag-mode)
+;; Each item has the form '(KEYWORD (TAG COMMAND HELP)) where:
+;; - KEYWORD is a regular expression including a matched group of
+;; the form "\\(xxx\\)". If this is not the case the whole
+;; string will be used a the matched group.
+;; - TAG is either a SVG image that will be displayed using the
+;; 'display property or a function that accepts a unique string
+;; argument (match-string 1) and returns an SVG image.
+;; - COMMAND is a command to be executed when user clicks on the tag.
+;; It can be nil if no command is associated with the tag.
+;; - HELP is a string to be displayed when mouse pointer is over
+;; the tag. It can be nil if no command is associated with the tag.
;;
;;
-;; 2. Replace any letter between () with a circle
+;; Examples:
+;; ---------
;;
-;; (defun svg-tag-round (text)
-;; (svg-tag-make (substring text 1 -1) nil 1 1 12))
-;; (setq svg-tag-tags '(("([0-9])" svg-tag-round)))
-;; (svg-tag-mode)
+;; ;; This replaces any occurence of ":TODO:" with a static SVG tag
+;; ;; displaying "TODO"
+;; (setq svg-tag-tags
+;; '((":TODO:" . ((svg-tag-make "TODO")))))
+;;
+;; ;; This replaces any occurence of ":HELLO:" with a static SVG tag that
+;; ;; can be clicked to execute the specified command. Help message is
+;; ;; displayed when the tag is hovered with the pointer.
+;; (setq svg-tag-tags
+;; '((":HELLO:" . ((svg-tag-make "HELLO")
+;; (lambda () (interactive) (message "Hello world!"))
+;; "Print a greeting message"))))
+;;
+;; ;; This replaces any occurence of ":TODO:" with a static SVG tag
+;; ;; displaying ":TODO:"
+;; (setq svg-tag-tags
+;; '((":TODO:" . (svg-tag-make))))
+;;
+;; ;; This replaces any occurence of ":TODO:" with a dynamic SVG tag
+;; ;; displaying "TODO"
+;; (setq svg-tag-tags
+;; '((":TODO:" . ((lambda (tag)
+;; (svg-tag-make tag :beg 1 :end -1))))))
+;;
+;; ;; This replaces any occurence of ":XXX:" with a dynamic SVG tag
+;; ;; displaying "XXX"
+;; (setq svg-tag-tags
+;; '(("\\(:[A-Z]+:\\)" . ((lambda (tag)
+;; (svg-tag-make tag :beg 1 :end -1))))))
+;;
+;; ;; This replaces any occurence of ":XXX|YYY:" with two adjacent
+;; ;; dynamic SVG tags displaying "XXX" and "YYY"
+;; (setq svg-tag-tags
+;; '(("\\(:[A-Z]+\\)\|[a-zA-Z#0-9]+:" . ((lambda (tag)
+;; (svg-tag-make tag :beg 1
:inverse t
+;; :margin 0
:crop-right t))))
+;; (":[A-Z]+\\(\|[a-zA-Z#0-9]+:\\)" . ((lambda (tag)
+;; (svg-tag-make tag :beg 1 :end -1
+;; :margin 0
:crop-left t))))))
+;;
+;; ;; This replaces any occurence of ":#TAG1:#TAG2:…:$" ($ means end of
+;; ;; line) with a dynamic collection of SVG tags. Note the # symbol in
+;; ;; front of tags. This is mandatory because Emacs cannot do regex look
+;; ;; ahead.
+;; (setq svg-tag-tags
+;; '(("\\(:#[A-Za-z0-9]+\\)" . ((lambda (tag)
+;; (svg-tag-make tag :beg 2))))
+;; ("\\(:#[A-Za-z0-9]+:\\)$" . ((lambda (tag)
+;; (svg-tag-make tag :beg 2 :end
-1))))))
+;;
+;;; NEWS:
+;;
+;; Version 0.2:
+;; - Added activable tags
+;; - svg-lib dependency
+;;
+;; Version 0.1:
+;; - Proof of concept
;;
;;; Code:
-(require 'svg)
-(eval-when-compile (require 'subr-x))
+(require 'svg-lib)
-;; (defvar svg-tag-tags nil)
-(defvar svg-tag-tags--active nil)
+(defvar svg-tag--active-tags nil
+ "Set of currently active tags")
(defgroup svg-tag nil
"Replace keywords with SVG rounded box labels"
:group 'convenience
:prefix "svg-tag-")
-(defcustom svg-tag-default-outer-padding 1
- "Default outer padding (in characters, null or positive)."
- :type 'integer
- :group 'svg-tag)
-
-(defcustom svg-tag-default-inner-padding 1
- "Default inner padding (in characters, null or positive)."
- :type 'integer
- :group 'svg-tag)
-
-(defcustom svg-tag-default-radius 3
- "Default radius (in pixels, null or positive)."
- :type 'integer
- :group 'svg-tag)
-
-(defcustom svg-tag-default-line-width 1
- "Default border line width (in pixels, null or positive)."
- :type 'integer
- :group 'svg-tag)
-
-(defcustom svg-tag-vertical-offset 0
- "Vertical offset for text (in pixels).
-This should be zero for most fonts but some fonts may need this."
- :type 'integer
- :group 'svg-tag)
-
-(defcustom svg-tag-horizontal-offset 0
- "Horizontal offset for text (in pixels).
-This should be zero for most fonts but some fonts may need this."
- :type 'integer
- :group 'svg-tag)
-
-(defface svg-tag-default-face
- `((t :foreground "white"
- :background "#FFAB91"
- :box (:line-width 1 :color "#FFAB91" :style nil)
- :family ,(face-attribute 'default :family)
- :weight ,(face-attribute 'default :weight)
- :height ,(if (display-graphic-p)
- (- (face-attribute 'default :height) 20)
- 1)))
- "Default face for tag"
- :group 'svg-tag)
+(setq svg-tag-tags `((" TODO " . ((svg-tag-make "TODO") nil nil))))
(defcustom svg-tag-tags
- '((" TODO " . (svg-tag-make "TODO")))
+ `((" TODO " . ((svg-tag-make "TODO") nil nil)))
"An alist mapping keywords to tags used to display them.
Each entry has the form (keyword . tag). Keyword is used as part
@@ -112,109 +133,142 @@ string as argument and returns a tag. When tag is a
function, this
allows to create dynamic tags."
:group 'svg-tag
:type '(repeat (cons (string :tag "Keyword")
- (sexp :tag "Tag"))))
-
-;; SVG font weights translation
-(defvar svg-tag--font-weights '((thin . 100)
- (ultralight . 200)
- (light . 300)
- (regular . 400)
- (medium . 500)
- (semibold . 600)
- (bold . 700)
- (extrabold . 800)
- (black . 900)))
-
-(defun svg-tag-make (text &optional face inner-padding outer-padding radius)
- "Create a SVG image displaying TEXT in a rounded box using FACE style.
-INNER-PADDING, OUTER-PADDING and RADIUS controls the visual aspect of the box."
- (let* ((face (or face 'svg-tag-default-face))
- (foreground (face-attribute face :foreground))
- (background (face-attribute face :background))
- (stroke (or (plist-get (face-attribute face :box) :color)
- foreground))
- ;; This does not seem to get the actual box line-width
- (line-width (or (plist-get (face-attribute face :box) :line-width)
- svg-tag-default-line-width))
- (family (face-attribute face :family))
-;; (weight (face-attribute face :weight))
- (weight (cdr (assoc (face-attribute face :weight)
- svg-tag--font-weights)))
- (size (/ (face-attribute face :height) 10))
-
- (tag-char-width (window-font-width nil face))
- (tag-char-height (window-font-height nil face))
- (txt-char-width (window-font-width))
- (txt-char-height (window-font-height))
- (inner-padding (or inner-padding svg-tag-default-inner-padding))
- (outer-padding (or outer-padding svg-tag-default-outer-padding))
-
- (text (string-trim text))
- (tag-width (* (+ (length text) inner-padding) txt-char-width))
- (tag-height (* txt-char-height 0.9))
-
- (svg-width (+ tag-width (* outer-padding txt-char-width)))
- (svg-height tag-height)
-
- (tag-x (/ (- svg-width tag-width) 2))
- (text-x (+ tag-x (/ (- tag-width (* (length text) tag-char-width))
2)))
- (text-y (- tag-char-height (- txt-char-height tag-char-height)))
-
- (radius (or radius svg-tag-default-radius))
- (svg (svg-create svg-width svg-height)))
-
- (svg-rectangle svg tag-x 0 tag-width tag-height
- :fill stroke
- :rx radius)
- (svg-rectangle svg (+ tag-x (/ line-width 2.0)) (/ line-width 2.0)
- (- tag-width line-width) (- tag-height line-width)
- :fill background
- :rx (- radius (/ line-width 2.0)))
- (svg-text svg text
- :font-family family
- :font-weight weight
- :font-size size
- :fill foreground
- :x (+ text-x svg-tag-horizontal-offset)
- :y (+ text-y svg-tag-vertical-offset))
- (svg-image svg :scale 1 :ascent 'center)))
-
+ (list (sexp :tag "Tag")
+ (sexp :tag "Command")
+ (sexp :tag "Help")))))
+
+(defun svg-tag-make (tag &optional &rest args)
+ "Return a svg tag displaying TAG and using specified ARGS.
+
+ ARGS are passed to the `svg-lib-tag' function but there are
+ supplementary arguments:
+
+ :beg (integer) specifies the first index of the tag substring to
+ take into account (default 0)
+
+ :end (integer) specifies the last index of the tag substring to
+ take into account (default nil)
+
+ :face (face) indicates the face to use to compute foreground &
+ background color (default 'default)
+
+ :inverse (bool) indicates whether to inverse foreground &
+ background color (default nil)
+
+ Note that :foreground, :background, :stroke and :font-weight
+ cannot be specified because thay are overwritten by the
+ function. If you need full control of tag appearance, best is
+ to call svg-lib-tag directly."
+
+ (let* ((face (or (plist-get args :face) 'default))
+ (inverse (or (plist-get args :inverse) nil))
+ (beg (or (plist-get args :beg) 0))
+ (end (or (plist-get args :end) nil))
+ (args (org-plist-delete args 'stroke))
+ (args (org-plist-delete args 'foreground))
+ (args (org-plist-delete args 'background))
+ (args (org-plist-delete args 'font-weight)))
+ (if inverse
+ (apply #'svg-lib-tag (substring tag beg end) nil
+ :stroke 0
+ :font-weight 'semibold
+ :foreground (face-background face nil 'default)
+ :background (face-foreground face nil 'default)
+ args)
+ (apply #'svg-lib-tag (substring tag beg end) nil
+ :stroke 2
+ :font-weight 'regular
+ :foreground (face-foreground face nil 'default)
+ :background (face-background face nil 'default)
+ args))))
(defun svg-tag--build-keywords (item)
- "Internal. Build the list of keyword from ITEM."
- (let ((pattern (format "\\(%s\\)" (car item)))
- (tag (cdr item)))
- (when (and (symbolp tag) (fboundp tag))
- (setq tag `(,tag (match-string 0))))
- (setq tag ``(face nil display ,,tag))
+ "Process an item in order to install it as a new keyword."
+
+ (let* ((pattern (if (string-match "\\\\(.+\\\\)" (car item))
+ (car item)
+ (format "\\(%s\\)" (car item))))
+ (tag (nth 0 (cdr item)))
+ (callback (nth 1 (cdr item)))
+ (help (nth 2 (cdr item))))
+ (when (or (functionp tag) (and (symbolp tag) (fboundp tag)))
+ (setq tag `(,tag (match-string 1))))
+ (setq tag ``(face nil
+ display ,,tag
+ ,@(if ,callback '(pointer hand))
+ ,@(if ,help `(help-echo ,,help))
+ ,@(if ,callback `(keymap (keymap (mouse-1 . ,,callback))))))
`(,pattern 1 ,tag)))
+(defun svg-tag--remove-text-properties (oldfun start end props &rest args)
+ "This applies remove-text-properties with 'display removed from props"
+ (apply oldfun start end (org-plist-delete props 'display) args))
+
+(defun svg-tag--remove-text-properties-on (args)
+ "This installs an advice around remove-text-properties"
+ (advice-add 'remove-text-properties
+ :around #'svg-tag--remove-text-properties))
+
+(defun svg-tag--remove-text-properties-off (args)
+ "This removes the advice around remove-text-properties"
+ (advice-remove 'remove-text-properties
+ #'svg-tag--remove-text-properties))
+
(defun svg-tag-mode-on ()
"Activate SVG tag mode."
(add-to-list 'font-lock-extra-managed-props 'display)
- (when svg-tag-tags--active
+
+ ;; Remove currently active tags
+ (when svg-tag--active-tags
(font-lock-remove-keywords nil
- (mapcar #'svg-tag--build-keywords svg-tag-tags--active)))
+ (mapcar #'svg-tag--build-keywords svg-tag--active-tags)))
+
+ ;; Install tags
(when svg-tag-tags
(font-lock-add-keywords nil
- (mapcar #'svg-tag--build-keywords svg-tag-tags)))
- (setq svg-tag-tags--active (copy-sequence svg-tag-tags))
+ (mapcar #'svg-tag--build-keywords svg-tag-tags)))
+
+ ;; Make a copy of newly installed tags
+ (setq svg-tag--active-tags (copy-sequence svg-tag-tags))
+
+ ;; Install advices on remove-text-properties (before & after). This
+ ;; is a hack to prevent org mode from removing SVG tags that use the
+ ;; 'display property
+ (advice-add 'org-fontify-meta-lines-and-blocks
+ :before #'notebook--remove-text-properties-on)
+ (advice-add 'org-fontify-meta-lines-and-blocks
+ :after #'notebook--remove-text-properties-off)
+
+ ;; Redisplay everything to show tags
(message "SVG tag mode on")
(font-lock-flush))
(defun svg-tag-mode-off ()
"Deactivate SVG tag mode."
- (when svg-tag-tags--active
+
+ ;; Remove currently active tags
+ (when svg-tag--active-tags
(font-lock-remove-keywords nil
- (mapcar #'svg-tag--build-keywords svg-tag-tags--active)))
- (setq svg-tag-tags--active nil)
+ (mapcar #'svg-tag--build-keywords svg-tag--active-tags)))
+ (setq svg-tag--active-tags nil)
+
+ ;; Remove advices on remove-text-properties (before & after)
+ (advice-remove 'org-fontify-meta-lines-and-blocks
+ #'svg-tag--remove-text-properties-on)
+ (advice-remove 'org-fontify-meta-lines-and-blocks
+ #'svg-tag--remove-text-properties-off)
+ (remove-hook 'org-babel-after-execute-hook 'org-redisplay-inline-images)
+
+ ;; Redisplay everything to hide tags
(message "SVG tag mode off")
(font-lock-flush))
(define-minor-mode svg-tag-mode
"Minor mode for graphical tag as rounded box."
:group 'svg-tag
- (if svg-tag-mode (svg-tag-mode-on) (svg-tag-mode-off)))
+ (if svg-tag-mode
+ (svg-tag-mode-on)
+ (svg-tag-mode-off)))
(define-globalized-minor-mode
global-svg-tag-mode svg-tag-mode svg-tag-mode-on)
diff --git a/svg-tag-off.png b/svg-tag-off.png
deleted file mode 100644
index 4a907b128d..0000000000
Binary files a/svg-tag-off.png and /dev/null differ
