;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;; sym-lock.el - Extension of Font-Lock mode for symbol fontification.

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;        Copyright © 1997-2004 Albert Cohen, all rights reserved.

 ;;         Copying is covered by the GNU General Public License.

 ;;

 ;;    This program 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 2 of the License, or

 ;;    (at your option) any later version.

 ;;

 ;;    This program 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.

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;                                 History

 ;; 

 ;; first prototype by wg <wg@cs.tu-berlin.de> 5-96

 ;; tweaked by Steve Dunham <dunham@gdl.msu.edu> 5-96

 ;; rewritten and enhanced by Albert Cohen <Albert.Cohen@inria.fr> 3-97

 ;;   new symbol-face format and ergonomy improvement 2-98

 ;;   major step towards portability and customization 5-98

 ;;   removed bug with multiple appends in hook by 3-99

 ;;   removed use-fonts check (due to incomatibilities) 9-00

 ;;   new after-change/pre-idle policy 6-01

 ;;   disable M$ Windows (symbol font problem) and fixed movement bug

 ;;     (incompatibile atomic-extents and paren) 8-01

 ;;   check for the availability of a symbol font 1-02

 ;;   patch size inference and use the upper bound (of <= sizes) 1-02

 ;;   support for custom replacement faces (e.g., for the lambda symbol) 10-04

 ;; look at the symbol font? check out: xfd -fn '-adobe-symbol-*--14-*'

 (require 'cl)

 (require 'font-lock)

 (require 'atomic-extents)

 (defvar sym-lock-sym-count 0

   "Counter for internal symbols.")

 (defvar sym-lock-ext-start nil "Temporary for atomicization.")

 (make-variable-buffer-local 'sym-lock-ext-start)

 (defvar sym-lock-ext-end nil "Temporary for atomicization.")

 (make-variable-buffer-local 'sym-lock-ext-end)

 (defvar sym-lock-font-size nil

   "Default size for Sym-Lock symbol font.")

 (make-variable-buffer-local 'sym-lock-font-size)

 (put 'sym-lock-font-size 'permanent-local t)

 (defvar sym-lock-keywords nil

   "Similar to `font-lock-keywords'.")

 (make-variable-buffer-local 'sym-lock-keywords)

 (put 'sym-lock-keywords 'permanent-local t)

 (defvar sym-lock-enabled nil

   "Sym-Lock switch.")

 (make-variable-buffer-local 'sym-lock-enabled)

 (put 'sym-lock-enabled 'permanent-local t)

 (defvar sym-lock-color (face-foreground 'default)

   "*Sym-Lock default color in `font-lock-use-colors' mode.")

 (make-variable-buffer-local 'sym-lock-color)

 (put 'sym-lock-color 'permanent-local t)

 (defvar sym-lock-mouse-face-enabled t

   "Mouse face switch.")

 (make-variable-buffer-local 'sym-lock-mouse-face-enabled)

 (put 'sym-lock-mouse-face-enabled 'permanent-local t)

 (defun sym-lock-gen-symbol (&optional prefix)

   "Generate a new internal symbol."

   ;; where is the standard function to do this ?

   (setq sym-lock-sym-count (+ sym-lock-sym-count 1))

   (intern (concat "sym-lock-gen-" (or prefix "") 

 		  (int-to-string sym-lock-sym-count))))

 (defun sym-lock-make-symbols-atomic (&optional begin end)

   "Function to make symbol faces atomic."

   (if sym-lock-enabled

       (map-extents

        (lambda (extent maparg)

 	 (let ((face (extent-face extent)) (ext))

 	   (if (and face (setq ext (face-property face 'sym-lock-remap)))

 	       (progn

 		 (if (numberp ext)

 		     (set-extent-endpoints

 		      extent (- (extent-start-position extent) ext)

 		      (extent-end-position extent)))

 		 (if ext

 		     (progn

 		       (if sym-lock-mouse-face-enabled

 			   (set-extent-property extent 'mouse-face

 						'default))

 		       (set-extent-property extent 'atomic t)

 		       (set-extent-property extent 'start-open t))))))

 	 nil)

        (current-buffer)

        (if begin (save-excursion (goto-char begin) (beginning-of-line) (point))

 	 (point-min))

        (if end (save-excursion (goto-char end) (end-of-line) (point))

 	 (point-max))

        nil nil)))

 (defun sym-lock-compute-font-size ()

   "Computes the size of the \"better\" symbol font."

   (let ((num (face-height 'default))

 	(size) (minsize)

 	(lf (list-fonts "-adobe-symbol-medium-r-normal--*")))

     (setq minsize 8)

     (while lf

       (string-match "-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-\\([^-]*\\)-.*"

 		    (car lf))

       (setq size (string-to-number (substring (car lf)

 					      (match-beginning 1)

 					      (match-end 1))))

       (if (and (<= size num) (> size minsize))

 	  (setq minsize size))

       (setq lf (cdr lf)))

     minsize))

 (defun sym-lock-enable ()

   "Enable Sym-Lock on this buffer."

   (interactive)

   (if (not (and (fboundp 'console-type)

 		(or (eq (console-type) 'x)

 		    (eq (console-type) 'gtk))

 		(sym-lock-look-for-symbol-font)))

       (setq sym-lock-enabled nil)

     ;; X-Window with symbol font

     (if (not sym-lock-keywords)

 	(error "No Sym-Lock keywords defined!")

       (setq sym-lock-enabled t)

       (if font-lock-mode

 	  (progn

 	    (setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!

 	    (font-lock-set-defaults t)

 	    (font-lock-fontify-buffer)))

       (message "Sym-Lock enabled."))))

 (defun sym-lock-disable ()

   "Disable Sym-Lock on this buffer."

   (interactive)

   (if (not sym-lock-keywords)

       (error "No Sym-Lock keywords defined!")

     (setq sym-lock-enabled nil)

     (if font-lock-mode

 	(progn

 	  (setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!

 	  (font-lock-set-defaults t)

 	  (font-lock-fontify-buffer)))

     (message "Sym-Lock disabled.")))

 (defvar sym-lock-font-name

   (concat "-adobe-symbol-medium-r-normal--"

 	  (if sym-lock-font-size sym-lock-font-size

 	    (number-to-string (sym-lock-compute-font-size)))

 	  "-*-*-*-p-*-adobe-fontspecific")

   "Name of the font used by Sym-Lock.")

 (make-variable-buffer-local 'sym-lock-font-name)

 (put 'sym-lock-font-name 'permanent-local t)

 ;;(make-face 'sym-lock-adobe-symbol-face "Face for Sym-Lock symbols")

 ;;(set-face-property 'sym-lock-adobe-symbol-face 'font sym-lock-font-name)

 (defun sym-lock-look-for-symbol-font ()

   "Returns whether there is a symbol font registred in the font server,

    and sets sym-lock-enabled to false if not."

   (if (list-fonts sym-lock-font-name)

       t

     (setq sym-lock-enabled nil)

     nil))

 (defun sym-lock-set-foreground ()

   "Set foreground color of Sym-Lock faces."

   (if (and (boundp 'sym-lock-defaults) sym-lock-defaults)

       (let ((l (car sym-lock-defaults))

 	    (color (face-foreground 'default) sym-lock-color))

 	(if (and (consp l) (eq (car l) 'quote)) (setq l (eval l)))

 	(if (symbolp l) (setq l (eval l)))

 	(dolist (c l)

 	  (setq c (nth 2 c))

 	  (if (consp c) (setq c (eval c)))

 	  (if (string-match "-adobe-symbol-medium-r-normal-"

 			    (font-name (face-font c)))

 	      (set-face-foreground c color))))))

 (defun sym-lock-remap-face (pat pos obj atomic face)

   "Make a temporary face which remaps the POS char of PAT to the

 given OBJ under the symbol face and all other characters to

 the empty string. OBJ may either be a string or a character."

   (let* ((name (sym-lock-gen-symbol "face"))

 	 (table (make-display-table))

 	 (tface (make-face name "sym-lock-remap-face" t)))

     (fillarray table "")

     (aset table (string-to-char (substring pat (1- pos) pos))

 	  (if (stringp obj) obj (make-string 1 obj)))

     (if face

 	(set-face-parent tface face)

       (set-face-foreground tface sym-lock-color)

       (set-face-property tface 'font sym-lock-font-name))

     (set-face-property tface 'display-table table)

     (set-face-property tface 'sym-lock-remap atomic) ; mark it

     tface

     ;; return face value and not face name

     ;; the temporary face would be otherwise GCed

     ))

 (defvar sym-lock-clear-face

   (let* ((name (sym-lock-gen-symbol "face"))

 	 (table (make-display-table))

 	 (tface (make-face name "sym-lock-remap-face" t)))

     (fillarray table "")

     (set-face-property tface 'display-table table)

     (set-face-property tface 'sym-lock-remap 1) ; mark it

     tface 

     ;; return face value and not face name

     ;; the temporary face would be otherwise GCed

     ))

 (defun sym-lock (fl)

   "Create font-lock table entries from a list of (PAT NUM POS OBJ) where

 PAT (at NUM) is substituted by OBJ under the symbol face. The face's extent

 will become atomic."

   (if (not (and (fboundp 'console-type)

 		(or (eq (console-type) 'x)

 		    (eq (console-type) 'gtk))))

       (setq sym-lock-enabled nil)

     ;; X-Window

     (if (sym-lock-look-for-symbol-font)

 	(progn

 	  (message "Computing Sym-Lock faces...")

 	  (setq sym-lock-keywords (sym-lock-rec fl))

 	  (setq sym-lock-enabled t)

 	  (message "Computing Sym-Lock faces... done.")))

     ;; ugly hack to make atomic keywords traversable when

     ;; paren-highlighting is also using post-command-hook...

     ;; it moves atomic-extents post-command-hook to the front

     (remove-hook 'post-command-hook 'atomic-extent-post-hook)

     (add-hook 'post-command-hook 'atomic-extent-post-hook)))

 (defun sym-lock-rec (fl)

   (let ((f (car fl)))

     (if f (let* ((pat (car f))

 		 (pos (caddr f))

 		 (c (substring pat (1- pos) pos)))

 	    (if (or (string-match c (substring pat pos (length pat)))

 		    (string-match c (substring pat 0 (1- pos))))

 		(cons (apply 'sym-lock-atom f)

 		      (cons (apply 'sym-lock-face f)

 			    (sym-lock-rec (cdr fl))))

 	      (cons (apply 'sym-lock-atom-face f)

 		    (sym-lock-rec (cdr fl))))))))

 (defun sym-lock-atom-face (pat num pos obj face &optional override)

   "Define an entry for the font-lock table which substitutes PAT (at NUM) by

 OBJ under the symbol face. The face extent WILL become atomic."

   (list pat num (sym-lock-remap-face pat pos obj t face) override))

 (defun sym-lock-face (pat num pos obj face &optional override)

   "Define an entry for the font-lock table which substitutes PAT (at NUM) by

 OBJ under symbol face. The face extent will NOT become

 atomic."

   (list (concat "\\(" (substring pat 0 pos) "\\)"

 		(substring pat pos (length pat)))

 	(1+ num) (sym-lock-remap-face pat pos obj nil face) override))

 (defun sym-lock-atom (pat num pos obj face &optional override)

   "Define an entry for the font lock table which substitutes PAT (at NUM) by

 a void face. To build the atom, the face extent will be reshaped from

 \"begin_point\"-1 to \"end_point\"."

   (list (concat (substring pat 0 pos) "\\("

 		(substring pat pos (length pat)) "\\)")

 	(1+ num) sym-lock-clear-face override))

 (defun sym-lock-after-change-function (beg end old-len)

   (when sym-lock-enabled

     (setq sym-lock-ext-start (if sym-lock-ext-start

 				 (min beg sym-lock-ext-start) beg))

     (setq sym-lock-ext-end (if sym-lock-ext-end

 			       (max end sym-lock-ext-end) end))))

 (defun sym-lock-pre-idle-hook-last ()

   (if sym-lock-enabled

       (condition-case nil

 	  (when (and sym-lock-enabled sym-lock-ext-start)

 	    (sym-lock-make-symbols-atomic sym-lock-ext-start sym-lock-ext-end)

 	    (setq sym-lock-ext-start nil)

 	    (setq sym-lock-ext-end nil))

 	(error (warn "Error caught in `sym-lock-pre-idle-hook-last'")))))

 (add-hook 'font-lock-after-fontify-buffer-hook

 	  'sym-lock-make-symbols-atomic)

 (defun sym-lock-mouse-face-enable ()

   "Enable special face for symbols under mouse."

   (interactive)

   (setq sym-lock-mouse-face-enabled t)

   (if sym-lock-enabled

       (font-lock-fontify-buffer)))

 (defun sym-lock-mouse-face-disable ()

   "Disable special face for symbols under mouse."

   (interactive)

   (setq sym-lock-mouse-face-enabled nil)

   (if sym-lock-enabled

       (font-lock-fontify-buffer)))

 (defun sym-lock-font-lock-hook ()

   "Function called by `font-lock-mode' for initialization purposes."

   (add-hook 'after-change-functions 'sym-lock-after-change-function)

   (add-hook 'pre-idle-hook 'sym-lock-pre-idle-hook-last t)

   (if (and (featurep 'sym-lock) sym-lock-enabled

 	   font-lock-defaults (boundp 'sym-lock-keywords))

       (progn

 	(sym-lock-patch-keywords)

 	(sym-lock-set-foreground))))

 (defun font-lock-set-defaults (&optional explicit-defaults)

   (when

       (and

        (featurep 'font-lock)

        (if font-lock-auto-fontify

            (not (memq major-mode font-lock-mode-disable-list))

          (memq major-mode font-lock-mode-enable-list))

        (font-lock-set-defaults-1 explicit-defaults)

        (sym-lock-patch-keywords))

     (turn-on-font-lock)))

 (defun sym-lock-patch-keywords ()

   (if (and font-lock-keywords sym-lock-enabled

 	   (boundp 'sym-lock-keywords)

 	   (listp (car font-lock-keywords))

 	   (listp (cdar font-lock-keywords))

 	   (listp (cddar font-lock-keywords))

 	   (or (listp (caddar font-lock-keywords))

 	       (not (string-match

 		     "sym-lock"

 		     (symbol-name

 		      (face-name (cadr (cdar font-lock-keywords))))))))

       (setq font-lock-keywords (append sym-lock-keywords

 				       font-lock-keywords))) t)

 (add-menu-button '("Options" "Syntax Highlighting")

 		 ["Sym-Lock"

 		  (if sym-lock-enabled (sym-lock-disable) (sym-lock-enable))

 		  :style toggle :selected sym-lock-enabled

 		  :active sym-lock-keywords] "Automatic")

 (add-hook 'font-lock-mode-hook 'sym-lock-font-lock-hook)

 (provide 'sym-lock)