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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;        Copyright (C) 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)