bug#35476: font-lock-{append, prepend}-text-property and anonymous faces

["Kévin Le Gouguec" <kevin.legouguec@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1068 bytes --]

Noam Postavsky <npostavs@gmail.com> writes:

> It's best to avoid using hashes in commit messages, as they're
> translated to ChangeLog files which might read from the tarball (i.e.,
> without a git repo to hand).  CONTRIBUTE talks about using "action
> stamps" but I think date+title is more readable.  Which would be:
> 2019-04-29 "Refrain from splicing anonymous faces in text properties".

Ah, right, didn't think of the children^WChangeLog.  I went for
date+title.
  
Can e.g. git-show(1) understand action stamps?  I glanced at
gitrevisions(7) but nothing suggests Git knows anything about this
format.  It sure would make a hypothetical vc-revision-at-point command
easier to implement…

(Or, going the opposite route, maybe the git-log-to-ChangeLog machinery
could translate hashes to action stamps?)

>> +(provide 'font-lock-tests)
>
> I don't think there is any reason to `provide' a feature in a test file
> (I know some other test files do that, but I don't see why), test files
> are generally not loaded via require.

Done.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Stop-splicing-anonymous-faces-in-font-lock-append-te.patch --]
[-- Type: text/x-patch, Size: 3587 bytes --]

From 6a0a431fb0ed7ccfe27daf853eed48ac73017e1a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
Date: Sun, 12 May 2019 18:36:09 +0200
Subject: [PATCH 1/2] Stop splicing anonymous faces in
 font-lock-append-text-property

This is the same fix as 2019-04-29 "Refrain from splicing anonymous
faces in text properties", which was only applied to
font-lock-prepend-text-property.

* lisp/font-lock.el (font-lock-append-text-property): Distinguish list
of faces from property list.
* test/lisp/font-lock-tests.el: New test suite.

(Bug#35476)
---
 lisp/font-lock.el            |  7 +++++-
 test/lisp/font-lock-tests.el | 41 ++++++++++++++++++++++++++++++++++++
 2 files changed, 47 insertions(+), 1 deletion(-)
 create mode 100644 test/lisp/font-lock-tests.el

diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 7ff4e606fa..95ca2f99c2 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1417,7 +1417,12 @@ font-lock-append-text-property
 Arguments PROP and VALUE specify the property and value to append to the value
 already in place.  The resulting property values are always lists.
 Optional argument OBJECT is the string or buffer containing the text."
-  (let ((val (if (listp value) value (list value))) next prev)
+  (let ((val (if (and (listp value) (not (keywordp (car value))))
+                 ;; Already a list of faces.
+                 value
+               ;; A single face (e.g. a plist of face properties).
+               (list value)))
+        next prev)
     (while (/= start end)
       (setq next (next-single-property-change start prop object end)
 	    prev (get-text-property start prop object))
diff --git a/test/lisp/font-lock-tests.el b/test/lisp/font-lock-tests.el
new file mode 100644
index 0000000000..5d127039ff
--- /dev/null
+++ b/test/lisp/font-lock-tests.el
@@ -0,0 +1,41 @@
+;;; font-lock-tests.el --- Test suite for font-lock. -*- lexical-binding: t -*-
+
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+(require 'ert)
+
+(ert-deftest font-lock-test-append-anonymous-face ()
+  "Ensure `font-lock-append-text-property' does not splice anonymous faces."
+  (with-temp-buffer
+    (insert "foo")
+    (add-text-properties 1 3 '(face italic))
+    (font-lock-append-text-property 1 3 'face '(:strike-through t))
+    (should (equal (get-text-property 1 'face (current-buffer))
+                   '(italic (:strike-through t))))))
+
+(ert-deftest font-lock-test-prepend-anonymous-face ()
+  "Ensure `font-lock-prepend-text-property' does not splice anonymous faces."
+  (with-temp-buffer
+    (insert "foo")
+    (add-text-properties 1 3 '(face italic))
+    (font-lock-prepend-text-property 1 3 'face '(:strike-through t))
+    (should (equal (get-text-property 1 'face (current-buffer))
+                   '((:strike-through t) italic)))))
+
+;; font-lock-tests.el ends here
-- 
2.21.0


[-- Attachment #3: Type: text/plain, Size: 382 bytes --]


>> Subject: [PATCH 2/2] Extract common code for adding text properties
>
>> +      (let ((new-value (if append
>> +                           (append (if (listp prev) prev (list prev)) val)
>> +                         (append val (if (listp prev) prev (list prev))))))
>
> I would suggest to factor out the (if (listp prev) prev (list prev))
> from these expressions.

And done.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0002-Extract-common-code-for-adding-text-properties.patch --]
[-- Type: text/x-patch, Size: 4138 bytes --]

From bd45ee71a3880e681f637ea6a2b11fd9e06e51ce Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
Date: Sun, 12 May 2019 18:55:01 +0200
Subject: [PATCH 2/2] Extract common code for adding text properties

* lisp/font-lock.el (font-lock--add-text-property):
New function.
(font-lock-prepend-text-property)
(font-lock-append-text-property): Use it.

(Bug#35476)
---
 lisp/font-lock.el | 47 ++++++++++++++++++++---------------------------
 1 file changed, 20 insertions(+), 27 deletions(-)

diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 95ca2f99c2..3991a4ee8e 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1387,11 +1387,13 @@ font-lock-fontify-block
 ;; below and given a `font-lock-' prefix.  Those that are not used are defined
 ;; in Lisp below and commented out.  sm.
 
-(defun font-lock-prepend-text-property (start end prop value &optional object)
-  "Prepend to one property of the text from START to END.
-Arguments PROP and VALUE specify the property and value to prepend to the value
-already in place.  The resulting property values are always lists.
-Optional argument OBJECT is the string or buffer containing the text."
+(defun font-lock--add-text-property (start end prop value object append)
+  "Add an element to a property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to add to
+the value already in place.  The resulting property values are
+always lists.  Argument OBJECT is the string or buffer containing
+the text.  If argument APPEND is non-nil, VALUE will be appended,
+otherwise it will be prepended."
   (let ((val (if (and (listp value) (not (keywordp (car value))))
                  ;; Already a list of faces.
                  value
@@ -1407,35 +1409,26 @@ font-lock-prepend-text-property
 	   (or (keywordp (car prev))
 	       (memq (car prev) '(foreground-color background-color)))
 	   (setq prev (list prev)))
-      (put-text-property start next prop
-			 (append val (if (listp prev) prev (list prev)))
-			 object)
+      (let* ((list-prev (if (listp prev) prev (list prev)))
+             (new-value (if append
+                           (append list-prev val)
+                         (append val list-prev))))
+        (put-text-property start next prop new-value object))
       (setq start next))))
 
+(defun font-lock-prepend-text-property (start end prop value &optional object)
+  "Prepend to one property of the text from START to END.
+Arguments PROP and VALUE specify the property and value to prepend to the value
+already in place.  The resulting property values are always lists.
+Optional argument OBJECT is the string or buffer containing the text."
+  (font-lock--add-text-property start end prop value object nil))
+
 (defun font-lock-append-text-property (start end prop value &optional object)
   "Append to one property of the text from START to END.
 Arguments PROP and VALUE specify the property and value to append to the value
 already in place.  The resulting property values are always lists.
 Optional argument OBJECT is the string or buffer containing the text."
-  (let ((val (if (and (listp value) (not (keywordp (car value))))
-                 ;; Already a list of faces.
-                 value
-               ;; A single face (e.g. a plist of face properties).
-               (list value)))
-        next prev)
-    (while (/= start end)
-      (setq next (next-single-property-change start prop object end)
-	    prev (get-text-property start prop object))
-      ;; Canonicalize old forms of face property.
-      (and (memq prop '(face font-lock-face))
-	   (listp prev)
-	   (or (keywordp (car prev))
-	       (memq (car prev) '(foreground-color background-color)))
-	   (setq prev (list prev)))
-      (put-text-property start next prop
-			 (append (if (listp prev) prev (list prev)) val)
-			 object)
-      (setq start next))))
+  (font-lock--add-text-property start end prop value object t))
 
 (defun font-lock-fillin-text-property (start end prop value &optional object)
   "Fill in one property of the text from START to END.
-- 
2.21.0


[-- Attachment #5: Type: text/plain, Size: 75 bytes --]


Thank you for the review!  Let me know if there are further nits to
pick.