emacs/external/tuareg/sym-lock.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; sym-lock.el - Extension of Font-Lock mode for symbol fontification.
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;;        Copyright © 1997-2004 Albert Cohen, all rights reserved.
   6 ;;         Copying is covered by the GNU General Public License.
   7 ;;
   8 ;;    This program is free software; you can redistribute it and/or modify
   9 ;;    it under the terms of the GNU General Public License as published by
  10 ;;    the Free Software Foundation; either version 2 of the License, or
  11 ;;    (at your option) any later version.
  12 ;;
  13 ;;    This program is distributed in the hope that it will be useful,
  14 ;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 ;;    GNU General Public License for more details.
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;;                                 History
  20 ;;
  21 ;; first prototype by wg <wg@cs.tu-berlin.de> 5-96
  22 ;; tweaked by Steve Dunham <dunham@gdl.msu.edu> 5-96
  23 ;; rewritten and enhanced by Albert Cohen <Albert.Cohen@inria.fr> 3-97
  24 ;;   new symbol-face format and ergonomy improvement 2-98
  25 ;;   major step towards portability and customization 5-98
  26 ;;   removed bug with multiple appends in hook by 3-99
  27 ;;   removed use-fonts check (due to incomatibilities) 9-00
  28 ;;   new after-change/pre-idle policy 6-01
  29 ;;   disable M$ Windows (symbol font problem) and fixed movement bug
  30 ;;     (incompatibile atomic-extents and paren) 8-01
  31 ;;   check for the availability of a symbol font 1-02
  32 ;;   patch size inference and use the upper bound (of <= sizes) 1-02
  33 ;;   support for custom replacement faces (e.g., for the lambda symbol) 10-04
  34
  35 ;; look at the symbol font? check out: xfd -fn '-adobe-symbol-*--14-*'
  36
  37 (require 'cl)
  38 (require 'font-lock)
  39 (require 'atomic-extents)
  40
  41 (defvar sym-lock-sym-count 0
  42   "Counter for internal symbols.")
  43
  44 (defvar sym-lock-ext-start nil "Temporary for atomicization.")
  45 (make-variable-buffer-local 'sym-lock-ext-start)
  46 (defvar sym-lock-ext-end nil "Temporary for atomicization.")
  47 (make-variable-buffer-local 'sym-lock-ext-end)
  48
  49 (defvar sym-lock-font-size nil
  50   "Default size for Sym-Lock symbol font.")
  51 (make-variable-buffer-local 'sym-lock-font-size)
  52 (put 'sym-lock-font-size 'permanent-local t)
  53
  54 (defvar sym-lock-keywords nil
  55   "Similar to `font-lock-keywords'.")
  56 (make-variable-buffer-local 'sym-lock-keywords)
  57 (put 'sym-lock-keywords 'permanent-local t)
  58
  59 (defvar sym-lock-enabled nil
  60   "Sym-Lock switch.")
  61 (make-variable-buffer-local 'sym-lock-enabled)
  62 (put 'sym-lock-enabled 'permanent-local t)
  63
  64 (defvar sym-lock-color (face-foreground 'default)
  65   "*Sym-Lock default color in `font-lock-use-colors' mode.")
  66 (make-variable-buffer-local 'sym-lock-color)
  67 (put 'sym-lock-color 'permanent-local t)
  68
  69 (defvar sym-lock-mouse-face-enabled t
  70   "Mouse face switch.")
  71 (make-variable-buffer-local 'sym-lock-mouse-face-enabled)
  72 (put 'sym-lock-mouse-face-enabled 'permanent-local t)
  73
  74 (defun sym-lock-gen-symbol (&optional prefix)
  75   "Generate a new internal symbol."
  76   ;; where is the standard function to do this ?
  77   (setq sym-lock-sym-count (+ sym-lock-sym-count 1))
  78   (intern (concat "sym-lock-gen-" (or prefix "")
  79                   (int-to-string sym-lock-sym-count))))
  80
  81 (defun sym-lock-make-symbols-atomic (&optional begin end)
  82   "Function to make symbol faces atomic."
  83   (if sym-lock-enabled
  84       (map-extents
  85        (lambda (extent maparg)
  86          (let ((face (extent-face extent)) (ext))
  87            (if (and face (setq ext (face-property face 'sym-lock-remap)))
  88                (progn
  89                  (if (numberp ext)
  90                      (set-extent-endpoints
  91                       extent (- (extent-start-position extent) ext)
  92                       (extent-end-position extent)))
  93                  (if ext
  94                      (progn
  95                        (if sym-lock-mouse-face-enabled
  96                            (set-extent-property extent 'mouse-face
  97                                                 'default))
  98                        (set-extent-property extent 'atomic t)
  99                        (set-extent-property extent 'start-open t))))))
 100          nil)
 101        (current-buffer)
 102        (if begin (save-excursion (goto-char begin) (beginning-of-line) (point))
 103          (point-min))
 104        (if end (save-excursion (goto-char end) (end-of-line) (point))
 105          (point-max))
 106        nil nil)))
 107
 108 (defun sym-lock-compute-font-size ()
 109   "Computes the size of the \"better\" symbol font."
 110   (let ((num (face-height 'default))
 111         (size) (minsize)
 112         (lf (list-fonts "-adobe-symbol-medium-r-normal--*")))
 113     (setq minsize 8)
 114     (while lf
 115       (string-match "-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-\\([^-]*\\)-.*"
 116                     (car lf))
 117       (setq size (string-to-number (substring (car lf)
 118                                               (match-beginning 1)
 119                                               (match-end 1))))
 120       (if (and (<= size num) (> size minsize))
 121           (setq minsize size))
 122       (setq lf (cdr lf)))
 123     minsize))
 124
 125 (defun sym-lock-enable ()
 126   "Enable Sym-Lock on this buffer."
 127   (interactive)
 128   (if (not (and (fboundp 'console-type)
 129                 (or (eq (console-type) 'x)
 130                     (eq (console-type) 'gtk))
 131                 (sym-lock-look-for-symbol-font)))
 132       (setq sym-lock-enabled nil)
 133     ;; X-Window with symbol font
 134     (if (not sym-lock-keywords)
 135         (error "No Sym-Lock keywords defined!")
 136       (setq sym-lock-enabled t)
 137       (if font-lock-mode
 138           (progn
 139             (setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!
 140             (font-lock-set-defaults t)
 141             (font-lock-fontify-buffer)))
 142       (message "Sym-Lock enabled."))))
 143
 144 (defun sym-lock-disable ()
 145   "Disable Sym-Lock on this buffer."
 146   (interactive)
 147   (if (not sym-lock-keywords)
 148       (error "No Sym-Lock keywords defined!")
 149     (setq sym-lock-enabled nil)
 150     (if font-lock-mode
 151         (progn
 152           (setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!
 153           (font-lock-set-defaults t)
 154           (font-lock-fontify-buffer)))
 155     (message "Sym-Lock disabled.")))
 156
 157 (defvar sym-lock-font-name
 158   (concat "-adobe-symbol-medium-r-normal--"
 159           (if sym-lock-font-size sym-lock-font-size
 160             (number-to-string (sym-lock-compute-font-size)))
 161           "-*-*-*-p-*-adobe-fontspecific")
 162   "Name of the font used by Sym-Lock.")
 163 (make-variable-buffer-local 'sym-lock-font-name)
 164 (put 'sym-lock-font-name 'permanent-local t)
 165
 166 ;;(make-face 'sym-lock-adobe-symbol-face "Face for Sym-Lock symbols")
 167 ;;(set-face-property 'sym-lock-adobe-symbol-face 'font sym-lock-font-name)
 168
 169 (defun sym-lock-look-for-symbol-font ()
 170   "Returns whether there is a symbol font registred in the font server,
 171    and sets sym-lock-enabled to false if not."
 172   (if (list-fonts sym-lock-font-name)
 173       t
 174     (setq sym-lock-enabled nil)
 175     nil))
 176
 177 (defun sym-lock-set-foreground ()
 178   "Set foreground color of Sym-Lock faces."
 179   (if (and (boundp 'sym-lock-defaults) sym-lock-defaults)
 180       (let ((l (car sym-lock-defaults))
 181             (color (face-foreground 'default) sym-lock-color))
 182         (if (and (consp l) (eq (car l) 'quote)) (setq l (eval l)))
 183         (if (symbolp l) (setq l (eval l)))
 184         (dolist (c l)
 185           (setq c (nth 2 c))
 186           (if (consp c) (setq c (eval c)))
 187           (if (string-match "-adobe-symbol-medium-r-normal-"
 188                             (font-name (face-font c)))
 189               (set-face-foreground c color))))))
 190
 191 (defun sym-lock-remap-face (pat pos obj atomic face)
 192   "Make a temporary face which remaps the POS char of PAT to the
 193 given OBJ under the symbol face and all other characters to
 194 the empty string. OBJ may either be a string or a character."
 195   (let* ((name (sym-lock-gen-symbol "face"))
 196          (table (make-display-table))
 197          (tface (make-face name "sym-lock-remap-face" t)))
 198     (fillarray table "")
 199     (aset table (string-to-char (substring pat (1- pos) pos))
 200           (if (stringp obj) obj (make-string 1 obj)))
 201     (if face
 202         (set-face-parent tface face)
 203       (set-face-foreground tface sym-lock-color)
 204       (set-face-property tface 'font sym-lock-font-name))
 205     (set-face-property tface 'display-table table)
 206     (set-face-property tface 'sym-lock-remap atomic) ; mark it
 207     tface
 208     ;; return face value and not face name
 209     ;; the temporary face would be otherwise GCed
 210     ))
 211
 212 (defvar sym-lock-clear-face
 213   (let* ((name (sym-lock-gen-symbol "face"))
 214          (table (make-display-table))
 215          (tface (make-face name "sym-lock-remap-face" t)))
 216     (fillarray table "")
 217     (set-face-property tface 'display-table table)
 218     (set-face-property tface 'sym-lock-remap 1) ; mark it
 219     tface
 220     ;; return face value and not face name
 221     ;; the temporary face would be otherwise GCed
 222     ))
 223
 224 (defun sym-lock (fl)
 225   "Create font-lock table entries from a list of (PAT NUM POS OBJ) where
 226 PAT (at NUM) is substituted by OBJ under the symbol face. The face's extent
 227 will become atomic."
 228   (if (not (and (fboundp 'console-type)
 229                 (or (eq (console-type) 'x)
 230                     (eq (console-type) 'gtk))))
 231       (setq sym-lock-enabled nil)
 232     ;; X-Window
 233     (if (sym-lock-look-for-symbol-font)
 234         (progn
 235           (message "Computing Sym-Lock faces...")
 236           (setq sym-lock-keywords (sym-lock-rec fl))
 237           (setq sym-lock-enabled t)
 238           (message "Computing Sym-Lock faces... done.")))
 239     ;; ugly hack to make atomic keywords traversable when
 240     ;; paren-highlighting is also using post-command-hook...
 241     ;; it moves atomic-extents post-command-hook to the front
 242     (remove-hook 'post-command-hook 'atomic-extent-post-hook)
 243     (add-hook 'post-command-hook 'atomic-extent-post-hook)))
 244
 245 (defun sym-lock-rec (fl)
 246   (let ((f (car fl)))
 247     (if f (let* ((pat (car f))
 248                  (pos (caddr f))
 249                  (c (substring pat (1- pos) pos)))
 250             (if (or (string-match c (substring pat pos (length pat)))
 251                     (string-match c (substring pat 0 (1- pos))))
 252                 (cons (apply 'sym-lock-atom f)
 253                       (cons (apply 'sym-lock-face f)
 254                             (sym-lock-rec (cdr fl))))
 255               (cons (apply 'sym-lock-atom-face f)
 256                     (sym-lock-rec (cdr fl))))))))
 257
 258 (defun sym-lock-atom-face (pat num pos obj face &optional override)
 259   "Define an entry for the font-lock table which substitutes PAT (at NUM) by
 260 OBJ under the symbol face. The face extent WILL become atomic."
 261   (list pat num (sym-lock-remap-face pat pos obj t face) override))
 262
 263 (defun sym-lock-face (pat num pos obj face &optional override)
 264   "Define an entry for the font-lock table which substitutes PAT (at NUM) by
 265 OBJ under symbol face. The face extent will NOT become
 266 atomic."
 267   (list (concat "\\(" (substring pat 0 pos) "\\)"
 268                 (substring pat pos (length pat)))
 269         (1+ num) (sym-lock-remap-face pat pos obj nil face) override))
 270
 271 (defun sym-lock-atom (pat num pos obj face &optional override)
 272   "Define an entry for the font lock table which substitutes PAT (at NUM) by
 273 a void face. To build the atom, the face extent will be reshaped from
 274 \"begin_point\"-1 to \"end_point\"."
 275   (list (concat (substring pat 0 pos) "\\("
 276                 (substring pat pos (length pat)) "\\)")
 277         (1+ num) sym-lock-clear-face override))
 278
 279 (defun sym-lock-after-change-function (beg end old-len)
 280   (when sym-lock-enabled
 281     (setq sym-lock-ext-start (if sym-lock-ext-start
 282                                  (min beg sym-lock-ext-start) beg))
 283     (setq sym-lock-ext-end (if sym-lock-ext-end
 284                                (max end sym-lock-ext-end) end))))
 285
 286 (defun sym-lock-pre-idle-hook-last ()
 287   (if sym-lock-enabled
 288       (condition-case nil
 289           (when (and sym-lock-enabled sym-lock-ext-start)
 290             (sym-lock-make-symbols-atomic sym-lock-ext-start sym-lock-ext-end)
 291             (setq sym-lock-ext-start nil)
 292             (setq sym-lock-ext-end nil))
 293         (error (warn "Error caught in `sym-lock-pre-idle-hook-last'")))))
 294
 295 (add-hook 'font-lock-after-fontify-buffer-hook
 296           'sym-lock-make-symbols-atomic)
 297
 298 (defun sym-lock-mouse-face-enable ()
 299   "Enable special face for symbols under mouse."
 300   (interactive)
 301   (setq sym-lock-mouse-face-enabled t)
 302   (if sym-lock-enabled
 303       (font-lock-fontify-buffer)))
 304
 305 (defun sym-lock-mouse-face-disable ()
 306   "Disable special face for symbols under mouse."
 307   (interactive)
 308   (setq sym-lock-mouse-face-enabled nil)
 309   (if sym-lock-enabled
 310       (font-lock-fontify-buffer)))
 311
 312 (defun sym-lock-font-lock-hook ()
 313   "Function called by `font-lock-mode' for initialization purposes."
 314   (add-hook 'after-change-functions 'sym-lock-after-change-function)
 315   (add-hook 'pre-idle-hook 'sym-lock-pre-idle-hook-last t)
 316   (if (and (featurep 'sym-lock) sym-lock-enabled
 317            font-lock-defaults (boundp 'sym-lock-keywords))
 318       (progn
 319         (sym-lock-patch-keywords)
 320         (sym-lock-set-foreground))))
 321
 322 (defun font-lock-set-defaults (&optional explicit-defaults)
 323   (when
 324       (and
 325        (featurep 'font-lock)
 326        (if font-lock-auto-fontify
 327            (not (memq major-mode font-lock-mode-disable-list))
 328          (memq major-mode font-lock-mode-enable-list))
 329        (font-lock-set-defaults-1 explicit-defaults)
 330        (sym-lock-patch-keywords))
 331     (turn-on-font-lock)))
 332
 333 (defun sym-lock-patch-keywords ()
 334   (if (and font-lock-keywords sym-lock-enabled
 335            (boundp 'sym-lock-keywords)
 336            (listp (car font-lock-keywords))
 337            (listp (cdar font-lock-keywords))
 338            (listp (cddar font-lock-keywords))
 339            (or (listp (caddar font-lock-keywords))
 340                (not (string-match
 341                      "sym-lock"
 342                      (symbol-name
 343                       (face-name (cadr (cdar font-lock-keywords))))))))
 344       (setq font-lock-keywords (append sym-lock-keywords
 345                                        font-lock-keywords))) t)
 346
 347 (add-menu-button '("Options" "Syntax Highlighting")
 348                  ["Sym-Lock"
 349                   (if sym-lock-enabled (sym-lock-disable) (sym-lock-enable))
 350                   :style toggle :selected sym-lock-enabled
 351                   :active sym-lock-keywords] "Automatic")
 352
 353 (add-hook 'font-lock-mode-hook 'sym-lock-font-lock-hook)
 354
 355 (provide 'sym-lock)