Patch pour tuareg

[Stefan Monnier]

Salut,

Voilà un gros patch contre 1.44.3.

- string-as-multibyte n'est plus utilisé.
- Emacs-21 offre l'héritage entre faces.
- n'utilise pas tuareg-cache si syntax-ppss peut s'utiliser à la place.
- tuareg-font-lock-symbols (un sym-lock pour Emacs).
- correction de tuareg-mode-syntax-table pour que "?i?n" ne soit pas
  considéré comme un identificateur.
- execute tuareg-mode-hook plus tard (idéalement ca devrait s'exécuter
  en dernier, pour donner le dernier mot à l'utilisateur).
- simplifie la set/restore de case-fold-search.
  un changement similaire est possible avec tuareg-restore-syntax
  en utilisant une nouvelle syntax-table tuareg-syntax-internal-table
  et un (with-syntax-table ...).
- enlève un test de XEmacs qui semble aussi applicable à Emacs.  S'il ne
  l'est pas, il serait bon d'ajouter un commentaire expliquant pourquoi.

Il y a quelques "rough edges" (principalement les warnings a la
compilation), mais j'ai pas le temps de faire mieux pour le moment.


        Stefan


Index: tuareg.el
===================================================================
RCS file: /u/monnier/cvsroot/elisp/tuareg-mode/tuareg.el,v
retrieving revision 1.1.1.10
diff -u -u -b -r1.1.1.10 tuareg.el
--- tuareg.el   18 Feb 2005 19:26:07 -0000      1.1.1.10
+++ tuareg.el   18 Feb 2005 23:46:12 -0000
@@ -53,12 +53,6 @@
       (read-from-minibuffer prompt initial-input nil nil
                            (or history 'shell-command-history))))
 
-(if (not (fboundp 'string-as-multibyte))
-    (defun string-as-multibyte (str)
-      "Return same string for not multibyte emacs'en"
-      str))
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                             Import types and help features
 
@@ -117,7 +111,7 @@
        (*
           ...
         *)
-(without leading `*'), set `tuareg-comment-end-extra-indent' to 1."
+\(without leading `*'), set `tuareg-comment-end-extra-indent' to 1."
   :group 'tuareg :type 'boolean)
 
 (defcustom tuareg-leading-star-in-doc nil
@@ -311,7 +305,7 @@
   :group 'tuareg :type 'boolean)
 
 (defcustom tuareg-interactive-read-only-input nil
-  "*Non-nil means input send to the Caml toplevel is read-only."
+  "*Non-nil means input sent to the Caml toplevel is read-only."
   :group 'tuareg :type 'boolean)
 
 (defcustom tuareg-interactive-echo-phrase t
@@ -387,10 +381,15 @@
   "Special faces for the Tuareg mode."
   :group 'tuareg)
 
+(defconst tuareg-faces-inherit-p
+  (if (boundp 'face-attribute-name-alist)
+      (assq :inherit face-attribute-name-alist)))
+
 (defface tuareg-font-lock-governing-face
-  '((((background light))
-     (:foreground "darkorange3" :bold t))
-    (t (:foreground "orange" :bold t)))
+  (if tuareg-faces-inherit-p
+      '((t :inherit font-lock-keywords-face))
+    '((((background light)) (:foreground "darkorange3" :bold t))
+      (t (:foreground "orange" :bold t))))
   "Face description for governing/leading keywords."
   :group 'tuareg-faces)
 (defvar tuareg-font-lock-governing-face
@@ -406,16 +405,19 @@
   'tuareg-font-lock-multistage-face)
 
 (defface tuareg-font-lock-operator-face
-  '((((background light))
-     (:foreground "brown4"))
-    (t (:foreground "salmon")))
+  (if tuareg-faces-inherit-p
+      '((t :inherit font-lock-keywords-face))
+    '((((background light)) (:foreground "brown"))
+      (t (:foreground "khaki"))))
   "Face description for all operators."
   :group 'tuareg-faces)
 (defvar tuareg-font-lock-operator-face
   'tuareg-font-lock-operator-face)
 
 (defface tuareg-font-lock-error-face
-  '((t (:foreground "yellow" :background "red")))
+  (if tuareg-faces-inherit-p
+      '((t :inherit font-lock-warning-face))
+    '((t (:foreground "yellow" :background "red"))))
   "Face description for all errors reported to the source."
   :group 'tuareg-faces)
 (defvar tuareg-font-lock-error-face
@@ -442,16 +444,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                            Support definitions
 
-(defvar tuareg-cache-stop (point-min))
-(make-variable-buffer-local 'tuareg-cache-stop)
-(defvar tuareg-cache nil)
-(make-variable-buffer-local 'tuareg-cache)
-(defvar tuareg-cache-local nil)
-(make-variable-buffer-local 'tuareg-cache-local)
-(defvar tuareg-cache-last-local nil)
-(make-variable-buffer-local 'tuareg-cache-last-local)
-(defvar tuareg-last-loc (cons nil nil))
-
 (defun tuareg-leading-star-p ()
   (and tuareg-support-leading-star-comments
        (save-excursion ; this function does not make sense outside of a comment
@@ -505,6 +497,39 @@
     (skip-chars-backward " \t")
     (bolp)))
 
+(defconst tuareg-use-syntax-ppss (fboundp 'syntax-ppss)
+  "If nil, use our own parsing and caching.")
+
+(if tuareg-use-syntax-ppss
+    (progn
+      (defun tuareg-in-literal-p ()
+       "Returns non-nil if point is inside a Caml literal."
+       (nth 3 (syntax-ppss)))
+      (defun tuareg-in-comment-p ()
+       "Returns non-nil if point is inside a Caml comment."
+       (nth 4 (syntax-ppss)))
+      (defun tuareg-in-literal-or-comment-p ()
+       "Returns non-nil if point is inside a Caml literal or comment."
+       (nth 8 (syntax-ppss)))
+      (defun tuareg-beginning-of-literal-or-comment ()
+       "Skips to the beginning of the current literal or comment (or buffer)."
+       (interactive)
+       (goto-char (or (nth 8 (syntax-ppss)) (point))))
+      (defun tuareg-beginning-of-literal-or-comment-fast ()
+       (goto-char (or (nth 8 (syntax-ppss)) (point-min))))
+      ;; FIXME: not clear if moving out of a string/comment counts as 1 or no.
+      (defalias 'tuareg-backward-up-list 'backward-up-list)
+      )
+(defvar tuareg-cache-stop (point-min))
+(make-variable-buffer-local 'tuareg-cache-stop)
+(defvar tuareg-cache nil)
+(make-variable-buffer-local 'tuareg-cache)
+(defvar tuareg-cache-local nil)
+(make-variable-buffer-local 'tuareg-cache-local)
+(defvar tuareg-cache-last-local nil)
+(make-variable-buffer-local 'tuareg-cache-last-local)
+(defvar tuareg-last-loc (cons nil nil))
+
 (defun tuareg-before-change-function (begin end)
   (setq tuareg-cache-stop (min tuareg-cache-stop (1- begin))))
 
@@ -622,18 +647,6 @@
     (goto-char (point-min)))
   (if (eq 'b (cadar tuareg-cache-last-local)) (tuareg-backward-char)))
 
-(defun tuareg-false-=-p ()
-  "Is the underlying `=' the first/second letter of an operator?"
-  (or (memq (preceding-char) '(?: ?> ?< ?=))
-      (char-equal ?= (char-after (1+ (point))))))
-
-(defun tuareg-at-phrase-break-p ()
-  "Is the underlying `;' a phrase break?"
-  (and (char-equal ?\; (following-char))
-       (or (and (not (eobp))
-               (char-equal ?\; (char-after (1+ (point)))))
-          (char-equal ?\; (preceding-char)))))
-
 (defun tuareg-backward-up-list ()
   "Safe up-list regarding comments, literals and errors."
   (let ((balance 1) (op (point)) (oc nil))
@@ -653,6 +666,21 @@
          (tuareg-beginning-of-literal-or-comment-fast)))
       (setq op (point)))))
 
+) ;; End of (if tuareg-use-syntax-ppss
+
+
+(defun tuareg-false-=-p ()
+  "Is the underlying `=' the first/second letter of an operator?"
+  (or (memq (preceding-char) '(?: ?> ?< ?=))
+      (char-equal ?= (char-after (1+ (point))))))
+
+(defun tuareg-at-phrase-break-p ()
+  "Is the underlying `;' a phrase break?"
+  (and (char-equal ?\; (following-char))
+       (or (and (not (eobp))
+               (char-equal ?\; (char-after (1+ (point)))))
+          (char-equal ?\; (preceding-char)))))
+
 (defun tuareg-assoc-indent (kwop &optional look-for-let-or-and)
   "Return relative indentation of the keyword given in argument."
   (let ((ind (symbol-value (cdr (assoc kwop tuareg-keyword-alist))))
@@ -666,8 +694,100 @@
       ind)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                                  Sym-lock in Emacs
+
+(defcustom tuareg-font-lock-symbols t
+  "Display \\ and -> and such using symbols in fonts.
+This may sound like a neat trick, but note that it can change the
+alignment and can thus lead to surprises."
+  :type 'bool)
+
+(defvar tuareg-font-lock-symbols-alist
+  (append
+   ;; The symbols can come from a JIS0208 font.
+   (and (fboundp 'make-char) (charsetp 'japanese-jisx0208)
+       (list (cons "fun" (make-char 'japanese-jisx0208 38 75))
+             (cons "sqrt" (make-char 'japanese-jisx0208 34 101))
+             (cons "not" (make-char 'japanese-jisx0208 34 76))
+             (cons "or" (make-char 'japanese-jisx0208 34 75))
+             (cons "||" (make-char 'japanese-jisx0208 34 75))
+             (cons "&&" (make-char 'japanese-jisx0208 34 74))
+             ;; (cons "*." (make-char 'japanese-jisx0208 33 95))
+             ;; (cons "/." (make-char 'japanese-jisx0208 33 96))
+             (cons "->" (make-char 'japanese-jisx0208 34 42))
+             (cons "=>" (make-char 'japanese-jisx0208 34 77))
+             (cons "<-" (make-char 'japanese-jisx0208 34 43))
+             (cons "<>" (make-char 'japanese-jisx0208 33 98))
+             (cons "==" (make-char 'japanese-jisx0208 34 97))
+             (cons ">=" (make-char 'japanese-jisx0208 33 102))
+             (cons "<=" (make-char 'japanese-jisx0208 33 101))
+             ;; Some greek letters for type parameters.
+             (cons "'a" (make-char 'japanese-jisx0208 38 65))
+             (cons "'b" (make-char 'japanese-jisx0208 38 66))
+             (cons "'c" (make-char 'japanese-jisx0208 38 67))
+             (cons "'d" (make-char 'japanese-jisx0208 38 68))))
+   ;; Or a unicode font.
+   (and (fboundp 'decode-char)
+       (list (cons "fun" (decode-char 'ucs 955))
+             (cons "sqrt" (decode-char 'ucs 8730))
+             (cons "not" (decode-char 'ucs 172))
+             (cons "or" (decode-char 'ucs 8897))
+             (cons "&&" (decode-char 'ucs 8896))
+             (cons "||" (decode-char 'ucs 8897))
+             ;; (cons "*." (decode-char 'ucs 215))
+             ;; (cons "/." (decode-char 'ucs 247))
+             (cons "->" (decode-char 'ucs 8594))
+             (cons "<-" (decode-char 'ucs 8592))
+             (cons "<=" (decode-char 'ucs 8804))
+             (cons ">=" (decode-char 'ucs 8805))
+             (cons "<>" (decode-char 'ucs 8800))
+             (cons "==" (decode-char 'ucs 8801))
+             ;; Some greek letters for type parameters.
+             (cons "'a" (decode-char 'ucs 945))
+             (cons "'b" (decode-char 'ucs 946))
+             (cons "'c" (decode-char 'ucs 947))
+             (cons "'d" (decode-char 'ucs 948))
+             ))))
+
+(defun tuareg-font-lock-compose-symbol (alist)
+  "Compose a sequence of ascii chars into a symbol.
+Regexp match data 0 points to the chars."
+  ;; Check that the chars should really be composed into a symbol.
+  (let* ((start (match-beginning 0))
+        (end (match-end 0))
+        (syntaxes (if (eq (char-syntax (char-after start)) ?w)
+                      '(?w) '(?. ?\\))))
+    (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
+           (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
+           (memq (get-text-property start 'face)
+                 '(font-lock-doc-face font-lock-string-face
+                   font-lock-comment-face)))
+       ;; No composition for you.  Let's actually remove any composition
+       ;; we may have added earlier and which is now incorrect.
+       (remove-text-properties start end '(composition))
+      ;; That's a symbol alright, so add the composition.
+      (compose-region start end (cdr (assoc (match-string 0) alist)))))
+  ;; Return nil because we're not adding any face property.
+  nil)
+
+(defun tuareg-font-lock-symbols-keywords ()
+  (when (fboundp 'compose-region)
+    (let ((alist nil))
+      (dolist (x tuareg-font-lock-symbols-alist)
+       (when (and (if (fboundp 'char-displayable-p)
+                      (char-displayable-p (cdr x))
+                    t)
+                  (not (assoc (car x) alist))) ;Not yet in alist.
+         (push x alist)))
+      (when alist
+       `((,(regexp-opt (mapcar 'car alist) t)
+          (0 (tuareg-font-lock-compose-symbol ',alist))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                                  Font-Lock
 
+(unless tuareg-use-syntax-ppss
+
 (defun tuareg-fontify-buffer ()
   (font-lock-default-fontify-buffer)
   (tuareg-fontify (point-min) (point-max)))
@@ -719,6 +839,8 @@
                            'font-lock-doc-face
                          'font-lock-doc-string-face))
 
+) ;; End of (unless tuareg-use-syntax-ppss
+  
 ;; Patch by Stefan Monnier: redesigned font-lock installation
 ;; and use char classes
 
@@ -751,6 +873,7 @@
   (copy-face font-lock-keyword-face 'font-lock-preprocessor-face))
 
 (defvar tuareg-font-lock-keywords
+  (append
   (list
    (list 
"\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[
 
\t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|and\\|begin\\|object\\|end\\)\\>"
         0 'tuareg-font-lock-governing-face nil nil)
@@ -784,6 +907,7 @@
         1 'font-lock-variable-name-face 'keep nil)
    (list "^#\\w+\\>"
         0 'font-lock-preprocessor-face t nil))
+  (tuareg-font-lock-symbols-keywords))
   "Font-Lock patterns for Tuareg mode.")
 
 (when (featurep 'sym-lock)
@@ -873,8 +997,8 @@
 (defvar tuareg-mode-syntax-table
   (let ((st (make-syntax-table)))
     (modify-syntax-entry ?_ "_" st)
-    (modify-syntax-entry ?? "w" st)
-    (modify-syntax-entry ?~ "w" st)
+    (modify-syntax-entry ?? ". p" st)
+    (modify-syntax-entry ?~ ". p" st)
     (modify-syntax-entry ?: "." st)
     (modify-syntax-entry ?' "w" st)    ; ' is part of words (for primes).
     (modify-syntax-entry
@@ -894,8 +1018,9 @@
   "Syntax table in use in Tuareg mode buffers.")
 
 (defconst tuareg-font-lock-syntax
-  '((?_ . "w") (?` . ".") (?\" . ".") (?\( . ".") (?\) . ".") (?* . ".")
-    (?~ . ".") (?? . "."))
+  `((?_ . "w") (?` . ".")
+    ,@(unless tuareg-use-syntax-ppss
+       '((?\" . ".") (?\( . ".") (?\) . ".") (?* . "."))))
   "Syntax changes for Font-Lock.")
 
 (defvar tuareg-mode-abbrev-table ()
@@ -1017,14 +1142,15 @@
   (setq parse-sexp-ignore-comments nil)
   (make-local-variable 'indent-line-function)
   (setq indent-line-function 'tuareg-indent-command)
+  (unless tuareg-use-syntax-ppss
   (make-local-hook 'before-change-functions)
-  (add-hook 'before-change-functions 'tuareg-before-change-function nil t)
+    (add-hook 'before-change-functions 'tuareg-before-change-function nil t))
   (make-local-variable 'normal-auto-fill-function)
   (setq normal-auto-fill-function 'tuareg-auto-fill-function)
         
   ;; Hooks for tuareg-mode, use them for tuareg-mode configuration
-  (run-hooks 'tuareg-mode-hook)
   (tuareg-install-font-lock)
+  (run-hooks 'tuareg-mode-hook)
   (if tuareg-use-abbrev-mode (abbrev-mode 1))
   (message (concat "Major mode for Caml programs, "
                   tuareg-mode-version ".")))
@@ -1038,8 +1164,8 @@
        (if (not sym-lock-keywords)
            (sym-lock tuareg-sym-lock-keywords))))
   (setq font-lock-defaults
-       (list
-        'tuareg-font-lock-keywords t nil
+       (list*
+        'tuareg-font-lock-keywords (not tuareg-use-syntax-ppss) nil
         tuareg-font-lock-syntax nil
         '(font-lock-syntactic-keywords
           . tuareg-font-lock-syntactic-keywords)
@@ -1047,10 +1173,12 @@
           . t)
         '(font-lock-syntactic-face-function
           . tuareg-font-lock-syntactic-face-function)
-        '(font-lock-fontify-region-function
-          . tuareg-fontify-region)))
+        (unless tuareg-use-syntax-ppss
+          '((font-lock-fontify-region-function
+             . tuareg-fontify-region)))))
+  (when (and (boundp 'font-lock-fontify-region-function)
+            (not tuareg-use-syntax-ppss))
   (make-local-variable 'font-lock-fontify-region-function)
-  (if (boundp 'font-lock-fontify-region-function)
       (setq font-lock-fontify-region-function 'tuareg-fontify-region)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1879,16 +2007,14 @@
 
 Compute new indentation based on Caml syntax."
   (interactive "*")
-  (let ((old-cfs case-fold-search))
     (if (not from-leading-star)
        (tuareg-auto-fill-insert-leading-star))
-    (setq case-fold-search nil)
+  (let ((case-fold-search nil))
     (tuareg-modify-syntax)
     (save-excursion
       (back-to-indentation)
       (indent-line-to (tuareg-compute-indent)))
     (if (tuareg-in-indentation-p) (back-to-indentation))
-    (setq case-fold-search old-cfs)
     (tuareg-restore-syntax)))
 
 (defun tuareg-compute-indent ()
@@ -2284,8 +2410,7 @@
 
 (defun tuareg-discover-phrase (&optional quiet)
   (end-of-line)
-  (let ((end (point)) (old-cfs case-fold-search))
-    (setq case-fold-search nil)
+  (let ((end (point)) (case-fold-search nil))
     (tuareg-modify-syntax)
     (tuareg-find-phrase-beginning)
     (if (> (point) end) (setq end (point)))
@@ -2324,7 +2449,6 @@
        (if (>= cpt 8) (message "Looking for enclosing phrase... done."))
        (save-excursion (tuareg-skip-blank-and-comments) (setq end (point)))
        (tuareg-skip-back-blank-and-comments)
-       (setq case-fold-search old-cfs)
        (tuareg-restore-syntax)
        (list begin (point) end)))))
 
@@ -2568,7 +2692,7 @@
   (when (eq major-mode 'tuareg-interactive-mode)
     (save-excursion
       (when (>= comint-last-input-end comint-last-input-start)
-       (if (and tuareg-with-xemacs tuareg-interactive-read-only-input)
+       (if tuareg-interactive-read-only-input
            (add-text-properties
             comint-last-input-start comint-last-input-end
             (list 'read-only t)))
@@ -2721,7 +2845,7 @@
        (goto-char (point-max))
        (comint-send-input))
     (insert "\n")
-    (tuareg-indent-command)
+    (indent-according-to-mode)
     (message tuareg-interactive-send-warning)))
 
 (defun tuareg-eval-region (start end)