;;;-------------------------------------------------------------------
; Highlighting for Tcl/Tk with hilit-19
;
(require 'hilit19)

(defun join (jstring l)
  "Join the elements of list L into a string with JSTRING as a separator"
  (let ((accum "") (tl l))
    (while tl (cond
	       ((= (length accum) 0)
		(setq accum (format "%s" (car tl))
		      tl (cdr tl)))
	       (t
		(setq accum (concat accum jstring (format "%s" (car tl)))
		      tl (cdr tl)))))
    accum))

(defun boundre (face init trail regexp &optional words)
  "Magical joining procedure that takes a fairly readable format in
the elisp source and magically transforms it into the input format for
hilit19."
  (list
   (concat init
	   (if words (concat "\\<\\("
			     (join "\\|" words)
			     "\\)\\>"))
	   regexp)
   trail face))

;----------------------------------------------------------------------

(let ((boc "\\(^\\|[[{;]\\)\\s-*")	; Beginning of command
      (eoc "[^\\]\n\\|[;}]")		; End of command
      (nw  "\\s-+\\S-+")		; Hilit following word
      (cw  "\\s-+\\([^ $.[]\\S-+\\)?")	; Hilit following word if subcommand

      (coment 'comment)			; Standard comment face
      (source 'include)			; Standard include face
      (fundef 'defun)			; Standard procedure definition face
      (vardef 'define)			; Standard variable face
      (delete 'red2-bold)		; Shows up well on light background
      (struct 'keyword)			; Keywords for structured programming
      (comand 'bold)			; Keywords for other ops
      (bindng 'orange2-bold)		; Key binding sequences
      (tkword 'sienna))			; Keywords for Tk

  (hilit-set-mode-patterns
   'tcl-mode
   (list
    (boundre coment boc "\n"   "#")
    (boundre source boc eoc "" '(load source))
    '(hilit-string-find ?\\ string)
    ;; Procedures
    (boundre fundef boc nil    "proc\\s-+\\S-+")
    ;; Keywords
    (boundre struct boc nil ""
	     '(vwait foreach while for if case switch eval uplevel
		     return catch expr continue break exit error after
		     time subst "\\(namespace\\|interp\\)\\s-+eval"))
    (boundre struct nil nil "" '(then else elseif))
    ;; Variables
    (boundre vardef boc eoc "" '(upvar global variable))
    (boundre vardef boc nil    "set\\s-+\\S-+")
    ;; Deletion
    (boundre delete boc eoc    "unset\\>")
    (boundre delete boc nil    "rename\\>")
    ;; Other commands
    (boundre comand boc nil ""
	     '(lsort append concat join split lindex llength lappend
		     lsearch list lrange lreplace linsert))
    (boundre comand boc nil ""
	     '(flush socket regexp regsub format scan fcopy glob incr puts
		     open close tell seek fileevent fconfigure gets
		     fblocked eof exec read bgerror pwd cd pid unknown
		     "update\\(\\s-+idletasks\\)?\\>"))
    (boundre comand boc nil nw
	     '(trace file string package interp info history clock
		     array binary namespace))
    ;; Bindings
    (boundre bindng nil nil    "<\\S-+>")
    ;; Tk commands (esp. widgets)
    (boundre tkword boc nil ""
	     '(frame bindtags toplevel focus raise message label menu
		     raise "\\(radio\\|check\\|menu\\)?button" listbox
		     scrollbar destroy entry scale canvas text lower
		     bell tkerror "tk_\\S-+"))
    ;; Tk (sub-cmd) commands (like geometry managers)
    (boundre tkword boc nil cw
	     '(winfo wm pack place grid bind option send selection
		     "image\\(\\s-+create\\)" grab font clipboard tk
		     tkwait event)))))
(provide 'tcl-hilit)