Change font-lock-keywords to use our own hacked `unicode-tokens-prepend-text-property'

instead of `font-lock-prepend-text-property' which gave ill formed
property values for 'face.  Still not clear if that function is faulty or
usage was not as intended.  Anyway, this repairs outstanding merge properties
problem so that <bold><italic>foo</italic></bold> works as expected.
Also: fix key binding for unicode-tokens-show-controls so is usable.

1 files changed, 62 insertions, 11 deletions

diff --git a/lib/unicode-tokens.el b/lib/unicode-tokens.el
index 34ab466b..e6e75d37 100644
--- a/lib/unicode-tokens.el
+++ b/lib/unicode-tokens.el
@@ -30,10 +30,11 @@
 ;; for programs that do not understand a Unicode encoding.
 ;; 
 
-;; Possible enhancements
+;; Desirable improvements/enhancements
 ;;
 ;; -- insert tokens via numeric code (extra format string), cf HTML
-;; -- unify region and control settings?
+;; -- simplify: unify region and control settings?
+;; -- simplify/optimise property handling 
 
 (require 'cl)
 
@@ -308,10 +309,10 @@ This function also initialises the important tables for the mode."
 				   toks) 'words)))
        (cons
 	`(,unicode-tokens-token-match-regexp
-	  (0 (unicode-tokens-help-echo) 'prepend)
+	  (0 (unicode-tokens-help-echo) prepend)
 	  (0 (unicode-tokens-font-lock-compose-symbol
 	      ,(- (regexp-opt-depth unicode-tokens-token-match-regexp) 1))
-	      'prepend))
+	      prepend))
 	(unicode-tokens-control-font-lock-keywords)))))
 
 (defun unicode-tokens-usable-composition (comp)
@@ -335,10 +336,11 @@ The check is with `char-displayable-p'."
   "Non-nil to reveal symbol (composed) tokens instead of compositions.")
 
 (defun unicode-tokens-font-lock-compose-symbol (match)
-  "Compose a sequence of chars into a symbol, maybe returning a face property.
+  "Compose a sequence of chars into a symbol.
 Regexp match data number MATCH selects the token name, while 0 matches the
 whole expression.
-Token name from MATCH is searched for in `unicode-tokens-hash-table'."
+Token name from MATCH is searched for in `unicode-tokens-hash-table'.
+The face property is set to the :family of `unicode-tokens-default-font-face'."
   (let* ((start     (match-beginning 0))
          (end       (match-end 0))
 	 (compps    (gethash (match-string match)
@@ -354,11 +356,51 @@ Token name from MATCH is searched for in `unicode-tokens-hash-table'."
 	    (setq props (cddr props)))))
     (font-lock-append-text-property
      start end 'face
-     ;; (list :inherit 'unicode-tokens-default-font-face)
+     ;; just use family so merging with other faces (keywords) works
      (list :family
 	   (face-attribute 'unicode-tokens-default-font-face :family)))
+    ;; returning face property here seems to have no effect
     nil))
 
+(defun unicode-tokens-prepend-text-properties-in-match (props matchno)
+  (let ((start     (match-beginning matchno))
+	(end       (match-end matchno)))
+    (while props
+      (unicode-tokens-prepend-text-property start end
+					    (car props) (cadr props))
+      (setq props (cddr props)))
+    nil))
+
+;; this is adapted from font-lock-prepend-text-property, which 
+;; currently fails to merge property values for 'face property properly.
+;; e.g., it makes (:slant italic (:weight bold font-lock-string-face))
+;; rather than  (:slant italic :weight bold font-lock-string-face)
+;;
+(defun unicode-tokens-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 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)
+    (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)))
+      (setq prev (if (listp prev) prev (list prev)))
+      ;; hack to flatten erroneously nested face property lists
+      (if (and (memq prop '(face font-lock-face))
+	       (listp (car prev)) (null (cdr prev)))
+	  (setq prev (car prev)))
+      (put-text-property start next prop
+			 (append prev val)
+			 object)
+      (setq start next))))
+
 (defun unicode-tokens-show-symbols (&optional arg)
   "Toggle variable `unicode-tokens-show-symbols'.  With ARG, turn on iff positive."
   (interactive "P")
@@ -405,13 +447,20 @@ Optional argument FACENIL means set the face property to nil, unless 'face is in
 (defun unicode-tokens-control-char (name s &rest props)
   `(,(format unicode-tokens-control-char-format-regexp (regexp-quote s))
     (1 '(face nil invisible unicode-tokens-show-controls) prepend)
-    (2 ',(unicode-tokens-symbs-to-props props t) prepend)))
+    ;; simpler but buggy with font-lock-prepend-text-property:
+    ;; (2 ',(unicode-tokens-symbs-to-props props t) prepend)
+    (2 (unicode-tokens-prepend-text-properties-in-match
+	',(unicode-tokens-symbs-to-props props t) 2) prepend)
+    ))
 
 (defun unicode-tokens-control-region (name start end &rest props)
   `(,(format unicode-tokens-control-region-format-regexp
 	     (regexp-quote start) (regexp-quote end))
     (1 '(face nil invisible unicode-tokens-show-controls) prepend)
-    (2 ',(unicode-tokens-symbs-to-props props t) prepend)
+    ;; simpler but buggy with font-lock-prepend-text-property:
+    ;; (2 ',(unicode-tokens-symbs-to-props props t) prepend)
+    (2 (unicode-tokens-prepend-text-properties-in-match
+	',(unicode-tokens-symbs-to-props props t) 2) prepend)
     (3 '(face nil invisible unicode-tokens-show-controls) prepend)))
 
 (defun unicode-tokens-control-font-lock-keywords ()
@@ -719,7 +768,9 @@ tokenised symbols."
 ;;
 
 (defun unicode-tokens-initialise ()
-  "Perform initialisation of minor mode."
+  "Perform initialisation of minor mode.
+Invoke this function to recalculate `font-lock-keywords' and other configuration
+variables."
   (interactive)
   (unicode-tokens-copy-configuration-variables)
   (let ((flks (unicode-tokens-font-lock-keywords)))
@@ -887,7 +938,7 @@ Commands available are:
 (define-key unicode-tokens-mode-map
   [(control c) (control t) (control z)] 'unicode-tokens-show-symbols)
 (define-key unicode-tokens-mode-map
-  [(control c) (control t) (control x)] 'unicode-tokens-show-controls)
+  [(control c) (control t) (control t)] 'unicode-tokens-show-controls)
 
     
 ;;