scheme-lock.el: fancy highlighting for Scheme code in XEmacs

[karlheg at bittersweet dot inetarena dot com (Karl M. Hegbloom)]

 It works.  I don't think I've set the font lock keywords correctly; I
 just learned about `font-lock-defaults', and have not studied into it
 yet.  This won't work in GNU Emacs, and I think that's why.  Anyone
 know?

 (require 'scheme)
 (require 'scheme-lock)

 `M-x customize-group scheme-lock'

;;; scheme-lock.el --- Configurable font locking for Scheme code

;; Copyright (C) 1998,2000 by Free Software Foundation, Inc.

;; Author: Karl M. Hegbloom <karlheg@debian.org>
;; Keywords: faces, languages, matching, scheme

;; This file is part of XEmacs.

;; XEmacs 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, or (at your option)
;; any later version.

;; XEmacs 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.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; Redefine the scheme-font-lock-keywords on the fly, using `custom'.

;;; Code:

(require 'regexp-opt)
(require 'font-lock)

(defgroup scheme-lock nil
  "Font lock keywords for Scheme codes."
  :group 'faces)

(defface font-lock-macro-name-face
  '((((class color) (background light)) (:foreground "brown" :bold t)))
  "Face for highlighting Scheme and Lisp macro names in definitions."
  :group 'scheme-lock)

(defface font-lock-underline-face
  '((t (:underline t)))
  "Mixin face for underlining things."
  :group 'scheme-lock)

(defvar scheme-lock-function-keywords
  '("define"
    "define*"
    "define-public"
    "define*-public"
    ))

(defvar scheme-lock-macro-keywords
  '("define-syntax"
    "defmacro"
    "defmacro-public"
    "defmacro*"
    "defmacro*-public"
    ))

(defvar scheme-lock-class-keywords
  '("define-class"))

(defvar scheme-lock-control-structure-keywords
  '("lambda"
    "lambda*"
    "begin"
    "call-with-current-continuation"
    "call/cc"
    "if"
    "cond"
    "=>"
    "else"
    "case"
    "do"
    "for-each"
    "let"
    "let*"
    "let-optional"
    "let-optional*"
    "let-keywords"
    "let-keywords*"
    "let-syntax"
    "letrec"
    "letrec-syntax"
    "and"
    "or"
    "delay"
    "map"
    "syntax"
    "syntax-rules"
    "call-with-input-file"
    "call-with-output-file"
    ))

(defvar scheme-lock-extra-highlighting-sexps
  (let ((fixme-todo  (concat "\\(?:"
			         "[Ff][Ii][Xx] ?\\(?:[Mm][Ee]\\)?"
			       "\\|"
			         "[Tt][Oo][ -_]?[Dd][Oo]"
			     "\\)"))
	(problem-exercise (concat "\\(?:"
				      "[Pp][Rr][Oo][Bb][Ll][Ee][Mm]"
				    "\\|"
				      "[Ee][Xx][Ee][Rr][Cc][Ii][Ss][Ee]"
				  "\\)"))
	)
    `(("David Fox <fox@graphics.cs.nyu.edu> for SOS/STklos class specifiers."
       "\\<<\\sw+>\\>" . font-lock-type-face)
      ("Scheme `:' keywords as references."
       "\\<:\\sw+\\>" . font-lock-reference-face)
      ("`(define-module (mod1 mod2 ...)"
       "(\\(define-module\\)[ 	]+(\\([^)]+\\))"
       (1 font-lock-preprocessor-face)
       (2 font-lock-type-face t))
      ("Second line of above."
       ":use-module[ 	]+(\\([^)]+\\))"
       (1 font-lock-type-face))
      ("(use-modules (ice-9 ilisp))"
       "(\\(use-modules\\)[ 	]+(\\([^)]+\\))"
       (1 font-lock-preprocessor-face)
       (2 font-lock-type-face t))
      ("optional args"
       "#&\\(?:\\sw\\|\\s_\\)+\\>" . font-lock-reference-face)
      ("Bolden the dot in dotted lists"
       "\\<\\.\\>" . bold)
      ("Todo items, boxes, etc."
       ;; +-------+
       ;; | Fixme |  <--- Highlights this whole box, and...
       ;; +-------+
       ;; Problem: 3.42        <-- colon and sharp optional
       ;; Exercise: #4.2.1         also works inside a box.
       ,(concat ";+[ \t]+"
                "\\(?:"
		  "\\("					   ; 1
		    "\\+[-=]+\\+?"
		  "\\)"
		"\\|"
		  "\\(?:"
		    "\\([:|#]+[ \t]*\\)?"		   ; 2
		    "\\(?:"
		      "\\("				   ; 3
		        "\\(?:"
		          fixme-todo
			"\\|"
		          "[#=]+"
			"\\)"
			":*"
		      "\\)"
		    "\\|"
		      "\\("				   ; 4
		        problem-exercise ":*"
		      "\\)"
		      "\\("				   ; 5
		        "[ \t]+#?[ \t]*"
			"[0-9]\\(?:[0-9.:]\\|\\sw\\|\\s_\\)*"
		      "\\)?"
		    "\\|"
		      "[^:|#]*"
		    "\\)"
		    "[^:|#]*"
		    "\\([:|#]+\\)?"			   ; 6
		  "\\)"
		"\\)"
                )
       (1 font-lock-warning-face t t)
       (2 font-lock-warning-face t t)
       (3 font-lock-warning-face t t)
       (4 font-lock-preprocessor-face t t)
       (5 font-lock-reference-face t t)
       (6 font-lock-warning-face t t)
       )
      )))

(defun scheme-lock-set-keywords-internal (var val)
  (set-default var val)
  (setq scheme-font-lock-keywords
	(append (list
		 (when scheme-lock-macro-keywords
		   (list (concat "(\\("
				 (regexp-opt scheme-lock-macro-keywords)
				 "\\)[ \t]+(?\\(\\sw+\\)?")
			 '(1 font-lock-keyword-face)
			 '(2 font-lock-macro-name-face nil t)))
		 ;;
		 (when scheme-lock-class-keywords
		   (list (concat "(\\("
				 (regexp-opt scheme-lock-class-keywords)
				 "\\)[ \t]+(?\\(\\sw+\\)?")
			 '(1 font-lock-keyword-face)
			 '(2 font-lock-type-face nil t)))
		 ;;
		 (when scheme-lock-function-keywords
		   (list (concat "(\\("
				 (regexp-opt scheme-lock-function-keywords)
				 "\\)[ \t]+(?\\(\\sw+\\)?")
			 '(1 font-lock-keyword-face)
			 '(2 font-lock-function-name-face nil t)))
		 ;;
		 (when scheme-lock-control-structure-keywords
		   (cons (concat "(\\("
				 (regexp-opt scheme-lock-control-structure-keywords)
				 "\\)\\>")
			 1))
		 )
		(mapcar #'cdr scheme-lock-extra-highlighting-sexps)
		))
  (loop
    for buf in (buffer-list)
    if (with-current-buffer buf
	 (memq major-mode '(scheme-mode inferior-scheme-mode)))
    do (with-current-buffer buf
	 (when font-lock-mode 
	   (font-lock-mode 0)
	   (font-lock-mode 1)))))

(defcustom scheme-lock-function-keywords
  scheme-lock-function-keywords
  "Keywords that introduce functions.
The next symbol will be highlighted in `font-lock-function-name-face'."
  :type '(repeat (string :tag ""))
  :set #'scheme-lock-set-keywords-internal
  :group 'scheme-lock)

(defcustom scheme-lock-macro-keywords
  scheme-lock-macro-keywords
  "Keywords that introduce macros.
The next symbol will be highlighted in `font-lock-macro-name-face'."
  :type '(repeat (string :tag ""))
  :set #'scheme-lock-set-keywords-internal
  :group 'scheme-lock)

(defcustom scheme-lock-class-keywords
  scheme-lock-class-keywords
  "Keywords that introduce classes."
  :type '(repeat (string :tag ""))
  :set #'scheme-lock-set-keywords-internal
  :group 'scheme-lock)

(defcustom scheme-lock-control-structure-keywords
  scheme-lock-control-structure-keywords
  "Keywords for control structures."
  :type '(repeat (string :tag ""))
  :set #'scheme-lock-set-keywords-internal
  :group 'scheme-lock)

;; These need to be able to have embedded comments.
(defcustom scheme-lock-extra-highlighting-sexps
  scheme-lock-extra-highlighting-sexps
  "Font locking keywords sexps to do extra highlighting."
  :type '(repeat (cons (string :tag "Comment")
		       (sexp :tag "Sexp")))
  :set #'scheme-lock-set-keywords-internal
  :group 'scheme-lock)


(provide 'scheme-lock)
;;; scheme-lock.el ends here