nXML: Use font lock

lisp/nxml/nxml-mode.el

@@ -24,11 +24,6 @@
 
 ;; See nxml-rap.el for description of parsing strategy.
 
-;; The font locking here is independent of font-lock.el.  We want to
-;; do more sophisticated handling of changes and we want to use the
-;; same xmltok rather than regexps for parsing so that we parse
-;; consistently and correctly.
-
 ;;; Code:
 
 (when (featurep 'mucs)
@@ -56,11 +51,6 @@
   :group 'nxml
   :group 'font-lock-faces)
 
-(defcustom nxml-syntax-highlight-flag t
-  "*Non-nil means nxml-mode should perform syntax highlighting."
-  :group 'nxml
-  :type 'boolean)
-
 (defcustom nxml-char-ref-display-glyph-flag t
   "*Non-nil means display glyph following character reference.
 The glyph is displayed in face `nxml-glyph'.  The hook
@@ -100,8 +90,6 @@ attribute on the previous line."
   :group 'nxml
   :type 'integer)
 
-(defvar nxml-fontify-chunk-size 500)
-
 (defcustom nxml-bind-meta-tab-to-complete-flag (not window-system)
   "*Non-nil means bind M-TAB in `nxml-mode-map' to `nxml-complete'.
 C-return will be bound to `nxml-complete' in any case.
@@ -432,19 +420,13 @@ reference.")
     map)
   "Keymap for nxml-mode.")
 
+(defvar nxml-font-lock-keywords
+  '(nxml-fontify-matcher)
+  "Default font lock keywords for nxml-mode.")
+
 (defsubst nxml-set-face (start end face)
   (when (and face (< start end))
-    (put-text-property start end 'face face)))
+    (font-lock-append-text-property start end 'face face)))
-
-(defun nxml-clear-face (start end)
-  (remove-text-properties start end '(face nil))
-  (nxml-clear-char-ref-extra-display start end))
-
-(defsubst nxml-set-fontified (start end)
-  (put-text-property start end 'fontified t))
-
-(defsubst nxml-clear-fontified (start end)
-  (remove-text-properties start end '(fontified nil)))
 
 ;;;###autoload
 (defun nxml-mode ()
@@ -453,9 +435,6 @@ reference.")
   ;; not mnemonic.
   "Major mode for editing XML.
 
-Syntax highlighting is performed unless the variable
-`nxml-syntax-highlight-flag' is nil.
-
 \\[nxml-finish-element] finishes the current element by inserting an end-tag.
 C-c C-i closes a start-tag with `>' and then inserts a balancing end-tag
 leaving point between the start-tag and end-tag. 
@@ -540,13 +519,9 @@ Many aspects this mode can be customized using
       (nxml-clear-dependent-regions (point-min) (point-max))
       (setq nxml-scan-end (copy-marker (point-min) nil))
       (nxml-with-unmodifying-text-property-changes
-	(when nxml-syntax-highlight-flag
+        (nxml-clear-inside (point-min) (point-max))
-	  (nxml-clear-fontified (point-min) (point-max)))
-	(nxml-clear-inside (point-min) (point-max))
 	(nxml-with-invisible-motion
 	  (nxml-scan-prolog)))))
-  (when nxml-syntax-highlight-flag
-    (add-hook 'fontification-functions 'nxml-fontify nil t))
   (add-hook 'after-change-functions 'nxml-after-change nil t)
   (add-hook 'change-major-mode-hook 'nxml-cleanup nil t)
 
@@ -561,6 +536,19 @@ Many aspects this mode can be customized using
       (setq buffer-file-coding-system nxml-default-buffer-file-coding-system))
     (when nxml-auto-insert-xml-declaration-flag
       (nxml-insert-xml-declaration)))
+
+  (setq font-lock-defaults
+        '(nxml-font-lock-keywords
+          t    ; keywords-only; we highlight comments and strings here
+          nil  ; font-lock-keywords-case-fold-search. XML is case sensitive
+          nil  ; no special syntax table
+          nil  ; no automatic syntactic fontification
+          (font-lock-extend-after-change-region-function
+           . nxml-extend-after-change-region)
+          (font-lock-extend-region-functions . (nxml-extend-region))
+          (jit-lock-contextually . t)
+          (font-lock-unfontify-region-function . nxml-unfontify-region)))
+
   (rng-nxml-mode-init)
   (nxml-enable-unicode-char-name-sets)
   (run-hooks 'nxml-mode-hook))
@@ -591,84 +579,73 @@ Many aspects this mode can be customized using
     (save-restriction
       (widen)
       (nxml-with-unmodifying-text-property-changes
-	(nxml-clear-face (point-min) (point-max))
-	(nxml-set-fontified (point-min) (point-max))
 	(nxml-clear-inside (point-min) (point-max))))))
 
 ;;; Change management
 
+(defun nxml-debug-region (start end)
+  (interactive "r")
+  (let ((font-lock-beg start)
+        (font-lock-end end))
+    (nxml-extend-region)
+    (goto-char font-lock-beg)
+    (set-mark font-lock-end)))
+
 (defun nxml-after-change (start end pre-change-length)
-  ;; Work around bug in insert-file-contents.
+  ; In font-lock mode, nxml-after-change1 is called via
-  (when (> end (1+ (buffer-size)))
+  ; nxml-extend-after-change-region instead so that the updated
-    (setq start 1)
+  ; book-keeping information is available for fontification.
-    (setq end (1+ (buffer-size))))
+  (unless (or font-lock-mode nxml-degraded)
-  (unless nxml-degraded
+    (nxml-with-degradation-on-error 'nxml-after-change
-    (condition-case err
+        (save-excursion
-	(save-excursion
+          (save-restriction
-	  (save-restriction
+            (widen)
-	    (widen)
+            (save-match-data
-	    (save-match-data
+              (nxml-with-invisible-motion
-	      (nxml-with-invisible-motion
+                (nxml-with-unmodifying-text-property-changes
-		(nxml-with-unmodifying-text-property-changes
+                  (nxml-after-change1
-		  (nxml-after-change1 start end pre-change-length))))))
+                   start end pre-change-length)))))))))
-      (error
-       (nxml-degrade 'nxml-after-change err)))))
 
 (defun nxml-after-change1 (start end pre-change-length)
-  (setq nxml-last-fontify-end nil)
+  "After-change bookkeeping.  Returns a cons cell containing a
+possibly-enlarged change region.  You must call
+nxml-extend-region on this expanded region to obtain the full
+extent of the area needing refontification.
+
+For bookkeeping, call this function even when fontification is
+disabled."
   (let ((pre-change-end (+ start pre-change-length)))
     (setq start
 	  (nxml-adjust-start-for-dependent-regions start
 						   end
 						   pre-change-length))
+    ;; If the prolog might have changed, rescan the prolog
     (when (<= start
-	      ;; Add 2 so as to include the < and following char
+	      ;; Add 2 so as to include the < and following char that
-	      ;; that start the instance, since changing these
+	      ;; start the instance (document element), since changing
-	      ;; can change where the prolog ends.
+	      ;; these can change where the prolog ends.
 	      (+ nxml-prolog-end 2))
-      ;; end must be extended to at least the end of the old prolog
+      ;; end must be extended to at least the end of the old prolog in
+      ;; case the new prolog is shorter
       (when (< pre-change-end nxml-prolog-end)
 	(setq end
 	      ;; don't let end get out of range even if pre-change-length
 	      ;; is bogus
 	      (min (point-max)
 		   (+ end (- nxml-prolog-end pre-change-end)))))
-      (nxml-scan-prolog)))
+      (nxml-scan-prolog)
-  (cond ((<= end nxml-prolog-end)
+      (setq start (point-min))))
-	 (setq end nxml-prolog-end)
+
-	 (goto-char start)
+  (when (> end nxml-prolog-end)
-	 ;; This is so that Emacs redisplay works
+    (goto-char start)
-	 (setq start (line-beginning-position)))
+    (nxml-move-tag-backwards (point-min))
-	((and (<= start nxml-scan-end)
+    (setq start (point))
-	      (> start (point-min))
+    (setq end (max (nxml-scan-after-change start end)
-	      (nxml-get-inside (1- start)))
+                   end)))
-	 ;; The closing delimiter might have been removed.
+
-	 ;; So we may need to redisplay from the beginning
+  (nxml-debug-change "nxml-after-change1" start end)
-	 ;; of the token.
+  (cons start end))
-	 (goto-char (1- start))
+
-	 (nxml-move-outside-backwards)
-	 ;; This is so that Emacs redisplay works
-	 (setq start (line-beginning-position))
-	 (setq end (max (nxml-scan-after-change (point) end)
-			end)))
-	(t
-	 (goto-char start)
-	 ;; This is both for redisplay and to move back
-	 ;; past any incomplete opening delimiters
-	 (setq start (line-beginning-position))
-	 (setq end (max (nxml-scan-after-change start end)
-			end))))
-  (when nxml-syntax-highlight-flag
-    (when (>= start end)
-      ;; Must clear at least one char so as to trigger redisplay.
-      (cond ((< start (point-max))
-	     (setq end (1+ start)))
-	    (t
-	     (setq end (point-max))
-	     (goto-char end)
-	     (setq start (line-beginning-position)))))
-    (nxml-clear-fontified start end)))
-  
 ;;; Encodings
 
 (defun nxml-insert-xml-declaration ()
@@ -854,51 +831,98 @@ The XML declaration will declare an encoding depending on the buffer's
 
 ;;; Fontification
 
-(defun nxml-fontify (start)
+(defun nxml-unfontify-region (start end)
-  (condition-case err
+  (font-lock-default-unfontify-region start end)
-      (save-excursion
+  (nxml-clear-char-ref-extra-display start end))
-	(save-restriction
-	  (widen)
-	  (save-match-data
-	    (nxml-with-invisible-motion
-	      (nxml-with-unmodifying-text-property-changes
-		(if (or nxml-degraded
-			;; just in case we get called in the wrong buffer
-			(not nxml-prolog-end))
-		    (nxml-set-fontified start (point-max))
-		  (nxml-fontify1 start)))))))
-    (error
-     (nxml-degrade 'nxml-fontify err))))
 
-(defun nxml-fontify1 (start)
+(defvar font-lock-beg) (defvar font-lock-end)
-  (cond ((< start nxml-prolog-end)
+(defun nxml-extend-region ()
-	 (nxml-fontify-prolog)
+  "Extend the region to hold the minimum area we can fontify with nXML.
-	 (nxml-set-fontified (point-min)
+Called with font-lock-beg and font-lock-end dynamically bound."
-			     nxml-prolog-end))
+  (let ((start font-lock-beg)
-	(t
+        (end font-lock-end))
-	 (goto-char start)
-	 (when (not (eq nxml-last-fontify-end start))
-	   (when (not (equal (char-after) ?\<))
-	     (search-backward "<" nxml-prolog-end t))
-	   (nxml-ensure-scan-up-to-date)
-	   (nxml-move-outside-backwards))
-	 (let ((start (point)))
-	   (nxml-do-fontify (min (point-max)
-				 (+ start nxml-fontify-chunk-size)))
-	   (setq nxml-last-fontify-end (point))
-	   (nxml-set-fontified start nxml-last-fontify-end)))))
 
-(defun nxml-fontify-buffer ()
+    (nxml-debug-change "nxml-extend-region(input)" start end)
-  (interactive)
+
-  (save-excursion
+    (when (< start nxml-prolog-end)
-    (save-restriction
+      (setq start (point-min)))
-      (widen)
+
-      (nxml-with-invisible-motion
+    (cond ((<= end nxml-prolog-end)
-	(goto-char (point-min))
+           (setq end nxml-prolog-end))
-	(nxml-with-unmodifying-text-property-changes
+
-	  (nxml-fontify-prolog)
+          (t
-	  (goto-char nxml-prolog-end)
+           (goto-char start)
-	  (nxml-do-fontify))))))
+           ;; some font-lock backends (like Emacs 22 jit-lock) snap
+           ;; the region to the beginning of the line no matter what
+           ;; we say here. To mitigate the resulting excess
+           ;; fontification, ignore leading whitespace.
+           (skip-syntax-forward " ")
+
+           ;; find the beginning of the previous tag
+           (when (not (equal (char-after) ?\<))
+             (search-backward "<" nxml-prolog-end t))
+           (nxml-ensure-scan-up-to-date)
+           (nxml-move-outside-backwards)
+           (setq start (point))
+
+           (while (< (point) end)
+             (nxml-tokenize-forward))
+
+           (setq end (point))))
+
+    (when (or (< start font-lock-beg)
+              (> end font-lock-end))
+      (setq font-lock-beg start
+            font-lock-end end)
+      (nxml-debug-change "nxml-extend-region" start end)
+      t)))
+
+(defun nxml-extend-after-change-region (start end pre-change-length)
+  (unless nxml-degraded
+    (setq nxml-last-fontify-end nil)
+
+    (nxml-with-degradation-on-error 'nxml-extend-after-change-region
+	(save-excursion
+	  (save-restriction
+	    (widen)
+	    (save-match-data
+	      (nxml-with-invisible-motion
+		(nxml-with-unmodifying-text-property-changes
+                  (nxml-extend-after-change-region1
+                   start end pre-change-length)))))))))
+
+(defun nxml-extend-after-change-region1 (start end pre-change-length)
+  (let* ((region (nxml-after-change1 start end pre-change-length))
+         (font-lock-beg (car region))
+         (font-lock-end (cdr region)))
+
+    (nxml-extend-region)
+    (cons font-lock-beg font-lock-end)))
+
+(defun nxml-fontify-matcher (bound)
+  "Called as font-lock keyword matcher."
+
+  (unless nxml-degraded
+    (nxml-debug-change "nxml-fontify-matcher" (point) bound)
+
+    (when (< (point) nxml-prolog-end)
+      ;; prolog needs to be fontified in one go, and
+      ;; nxml-extend-region makes sure we start at BOB.
+      (assert (bobp))
+      (nxml-fontify-prolog)
+      (goto-char nxml-prolog-end))
+
+    (let (xmltok-dependent-regions
+          xmltok-errors)
+      (while (and (nxml-tokenize-forward)
+                  (<= (point) bound)) ; intervals are open-ended
+        (nxml-apply-fontify-rule)))
+
+    (setq nxml-last-fontify-end (point)))
+
+  ;; Since we did the fontification internally, tell font-lock to not
+  ;; do anything itself.
+  nil)
 
 (defun nxml-fontify-prolog ()
   "Fontify the prolog.
@@ -906,7 +930,6 @@ The buffer is assumed to be prepared for fontification.
 This does not set the fontified property, but it does clear
 faces appropriately."
   (let ((regions nxml-prolog-regions))
-    (nxml-clear-face (point-min) nxml-prolog-end)
     (while regions
       (let ((region (car regions)))
 	(nxml-apply-fontify-rule (aref region 0)
@@ -914,17 +937,6 @@ faces appropriately."
 				 (aref region 2)))
       (setq regions (cdr regions)))))
 
-(defun nxml-do-fontify (&optional bound)
-  "Fontify at least as far as bound.
-Leave point after last fontified position."
-  (unless bound (setq bound (point-max)))
-  (let (xmltok-dependent-regions
-	xmltok-errors)
-    (while (and (< (point) bound)
-		(nxml-tokenize-forward))
-      (nxml-clear-face xmltok-start (point))
-      (nxml-apply-fontify-rule))))
-
 ;; Vectors identify a substring of the token to be highlighted in some face.
 
 ;; Token types returned by xmltok-forward.
@@ -2574,13 +2586,7 @@ With a prefix argument, inserts the character directly."
 	       (> (prefix-numeric-value arg) 0))))
     (when (not (eq new nxml-char-ref-extra-display))
       (setq nxml-char-ref-extra-display new)
-      (save-excursion
+      (font-lock-fontify-buffer))))
-	(save-restriction
-	  (widen)
-	  (if nxml-char-ref-extra-display
-	      (nxml-with-unmodifying-text-property-changes
-		(nxml-clear-fontified (point-min) (point-max)))
-	    (nxml-clear-char-ref-extra-display (point-min) (point-max))))))))
 
 (put 'nxml-char-ref 'evaporate t)
 

lisp/nxml/nxml-rap.el

@@ -110,9 +110,11 @@ There must be no nxml-inside properties after nxml-scan-end.")
   (get-text-property pos 'nxml-inside))
 
 (defsubst nxml-clear-inside (start end)
+  (nxml-debug-clear-inside start end)
   (remove-text-properties start end '(nxml-inside nil)))
 
 (defsubst nxml-set-inside (start end type)
+  (nxml-debug-set-inside start end)
   (put-text-property start end 'nxml-inside type))
 
 (defun nxml-inside-end (pos)
@@ -137,12 +139,10 @@ Return nil if the character at POS is not inside."
   "Restore `nxml-scan-end' invariants after a change.
 The change happened between START and END.
 Return position after which lexical state is unchanged.
-END must be > nxml-prolog-end."
+END must be > nxml-prolog-end. START must be outside
+any 'inside' regions and at the beginning of a token."
   (if (>= start nxml-scan-end)
       nxml-scan-end
-    (goto-char start)
-    (nxml-move-outside-backwards)
-    (setq start (point))
     (let ((inside-remove-start start)
 	  xmltok-errors
 	  xmltok-dependent-regions)
@@ -214,7 +214,7 @@ END must be > nxml-prolog-end."
 	      (setq adjusted-start ostart)))))
       (setq overlays (cdr overlays)))
     adjusted-start))
-		  
+
 (defun nxml-mark-parse-dependent-regions ()
   (while xmltok-dependent-regions
     (apply 'nxml-mark-parse-dependent-region
@@ -300,6 +300,20 @@ Sets variables like `nxml-token-after'."
       (set-marker nxml-scan-end (point)))
     xmltok-type))
 
+(defun nxml-move-tag-backwards (bound)
+  "Move point backwards outside any 'inside' regions or tags, up
+to nxml-prolog-end. Point will either be at bound or a '<'
+character starting a tag outside any 'inside' regions. Ignores
+dependent regions. As a precondition, point must be >= bound."
+  (nxml-move-outside-backwards)
+  (when (not (equal (char-after) ?<))
+    (if (search-backward "<" bound t)
+        (progn
+          (nxml-move-outside-backwards)
+          (when (not (equal (char-after) ?<))
+            (search-backward "<" bound t)))
+      (goto-char bound))))
+
 (defun nxml-move-outside-backwards ()
   "Move point to first character of the containing special thing.
 Leave point unmoved if it is not inside anything special."

lisp/nxml/nxml-util.el

@@ -24,6 +24,35 @@
 
 ;;; Code:
 
+(defconst nxml-debug nil
+  "enable nxml debugging. effective only at compile time")
+
+(eval-when-compile
+  (require 'cl))
+
+(defsubst nxml-debug (format &rest args)
+  (when nxml-debug
+    (apply #'message format args)))
+
+(defmacro nxml-debug-change (name start end)
+  (when nxml-debug
+    `(nxml-debug "%s: %S" ,name
+                (buffer-substring-no-properties ,start ,end))))
+
+(defmacro nxml-debug-set-inside (start end)
+  (when nxml-debug
+    `(let ((overlay (make-overlay ,start ,end)))
+       (overlay-put overlay 'face '(:background "red"))
+       (overlay-put overlay 'nxml-inside-debug t)
+       (nxml-debug-change "nxml-set-inside" ,start ,end))))
+
+(defmacro nxml-debug-clear-inside (start end)
+  (when nxml-debug
+    `(loop for overlay in (overlays-in ,start ,end)
+           if (overlay-get overlay 'nxml-inside-debug)
+           do (delete-overlay overlay)
+           finally (nxml-debug-change "nxml-clear-inside" ,start ,end))))
+
 (defun nxml-make-namespace (str)
   "Return a symbol for the namespace URI STR.
 STR must be a string. If STR is the empty string, return nil.
@@ -37,12 +66,21 @@ Otherwise, return the symbol whose name is STR prefixed with a colon."
 This is the inverse of `nxml-make-namespace'."
   (and ns (substring (symbol-name ns) 1)))
 
-(defconst nxml-xml-namespace-uri 
+(defconst nxml-xml-namespace-uri
   (nxml-make-namespace "http://www.w3.org/XML/1998/namespace"))
 
 (defconst nxml-xmlns-namespace-uri
   (nxml-make-namespace "http://www.w3.org/2000/xmlns/"))
 
+(defmacro nxml-with-degradation-on-error (context &rest body)
+  (if (not nxml-debug)
+      (let ((error-symbol (make-symbol "err")))
+        `(condition-case ,error-symbol
+             (progn ,@body)
+           (error
+            (nxml-degrade ,context ,error-symbol))))
+    `(progn ,@body)))
+
 (defmacro nxml-with-unmodifying-text-property-changes (&rest body)
   "Evaluate BODY without any text property changes modifying the buffer.
 Any text properties changes happen as usual but the changes are not treated as