;;; p-whim-lock.el --- Minor mode for interactive automatic highlighting.

;; Author: David M. Koppelman, koppel@ee.lsu.edu

;;; Commentary
;;  With the p-whim-lock commands text matching interactively entered
;;  regexp's can be highlighted.  For example, `M-x highlight-regexp
;;  RET clearly RET RET' will highlight all occurrences of `clearly'
;;  using a yellow background face.  New occurrences of `clearly' will
;;  be highlighted as they are typed.  `M-x unhighlight-regexp RET'
;;  will remove the highlighting.  Any existing face can be used for
;;  highlighting and a set of appropriate faces is provided.  The
;;  regexps can be written into the current buffer in a form that will
;;  be recognized the next time the corresponding file is read.
;;  An updated version of this package (renamed hi-lock) will be included
;;  in Emacs 21.
;;  Applications:
;;    In program source code highlight a variable to quickly see all
;;    places it is modified or referenced:
;;    M-x highlight-regexp ground_contact_switches_closed RET RET
;;    In a shell or other buffer that is showing lots of program
;;    output, highlight the parts of the output you're interested in:
;;    M-x highlight-regexp Total execution time [0-9]+ RET hi-blue-b RET
;;    In buffers displaying tables, highlight the lines you're interested in:
;;    M-x highlight-lines-matching-regexp January 2000 RET hi-black-b RET
;;    When writing text, highlight personal cliches.  This can be
;;    amusing.
;;    M-x highlight-regexp as can be seen RET RET

;; Setup:
;; Put the following code in your .emacs file, possibly changing
;; the key bindings in the global-set-key functions.
;; (if window-system
;;     (progn
;;       (require 'p-whim-lock)
;;       (global-set-key "\C-xwi" 'p-whim-lock-find-patterns)
;;       (global-set-key "\C-xwh" 'p-whim-lock-face-buffer)
;;       (global-set-key "\C-xwr" 'p-whim-lock-unface-buffer)
;;       (global-set-key "\C-xwb" 'p-whim-lock-write-interactive-patterns)))
;; Re-start Emacs or evaluate the added code.
;; Go to a buffer in which font-lock is turned on.
;; To highlight all occurrences of the word "the" type \C-xwh the RET RET.
;; To remove highlighting type \C-xwr.
;; To save highlight patterns at the point type \C-xwb.
;; To re-read saved patterns type \C-xwi.

;; Whim-lock: (("\\<\\(setq\\|interactive\\|list\\|intern\\|mapcar\\|lambda\\)\\>" . font-lock-keyword-face))
;; Whim-lock:  (("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append)))
;; Whim-lock: (("^;;;.*" (0 (quote bold) t)))
;; Whim-lock: end

;;; Version
;; Version numbers may appear in a future version.
;; This version copied: 22 February 2001,  9:14:41 CST
;; Get the latest version via http://www.ee.lsu.edu/koppel/lisp/p-whim-lock.el

;;; History:

;;; Code:
(defvar whim-lock-mode nil
  "Whim lock mode.")

(defvar p-whim-lock-file-keywords nil
  "Keywords found in file for whim lock.")

(defvar p-whim-lock-original-keywords nil
  "Saved font lock keywords, used whenever whim-lock keywords change.")

(defvar p-whim-lock-exclude-modes
  '(rmail-mode mime/viewer-mode)
  "List of major modes in which whim lock will not run.
Perhaps for security reasons.")

(defvar p-whim-lock-interactive-keywords nil
  "Keywords provided to whim-lock by user.")

(defvar p-whim-lock-face-history
      (list "hi-yellow" "hi-blue" "hi-pink" "hi-green"
            "bwl-black" "bwl-blue" "bwl-red"  )
      "History list of faces for whim-lock interactive functions.")

(defvar p-whim-lock-regexp-history nil
  "History of regexps used for interactive fontification.")

(make-variable-buffer-local 'p-whim-lock-original-keywords)
(make-variable-buffer-local 'p-whim-lock-interactive-keywords)
(put 'p-whim-lock-interactive-keywords 'permanent-local t)
(make-variable-buffer-local 'p-whim-lock-regexp-history)
(put 'p-whim-lock-regexp-history 'permanent-local t)
(make-variable-buffer-local 'p-whim-lock-file-keywords)
(put 'p-whim-lock-file-keywords 'permanent-local t)
(make-variable-buffer-local 'whim-lock-mode)
(put 'whim-lock-mode 'permanent-local t)

(if window-system
      (copy-face 'default 'hi-yellow)
      (set-face-background 'hi-yellow "yellow")
      (copy-face 'default 'hi-pink)
      (set-face-background 'hi-pink "pink")
      (copy-face 'default 'hi-green)
      (set-face-background 'hi-green "green")
      (copy-face 'default 'hi-blue)
      (set-face-background 'hi-blue "light blue")
      (copy-face 'default 'bwl-black)
      (make-face-bold 'bwl-black)
      (copy-face 'default 'bwl-blue)
      (set-face-foreground 'bwl-blue "blue")
      (make-face-bold 'bwl-blue)
      (copy-face 'default 'bwl-red)
      (set-face-foreground 'bwl-red "red")
      (make-face-bold 'bwl-red)))

(or (assq 'whim-lock-mode minor-mode-alist)
    (setq minor-mode-alist
	  (cons '(whim-lock-mode " W") minor-mode-alist)))

;; Visible Functions
(defalias 'highlight-lines-matching-regexp 'p-whim-lock-line-face-buffer)
(defun p-whim-lock-line-face-buffer (regexp &optional face)
  "Set face of each lines containing a match of REGEXP to FACE."
    (read-from-minibuffer "Regexp to highlight line: "
			  (cons (or (car p-whim-lock-regexp-history) "") 1 )
			  nil nil 'p-whim-lock-regexp-history)
    (intern (completing-read "Highlight using face: "
			  obarray 'facep t (car p-whim-lock-face-history)
			  '(p-whim-lock-face-history . 0)))))
  (if (or (not (stringp regexp)) (= (length regexp) 0))
      (error "Invalid regexp"))
  (if (not whim-lock-mode) (whim-lock-mode))
  (or (facep face) (setq face 'hi-yellow))
  (add-to-list 'p-whim-lock-interactive-keywords
               (list (concat "^.*" regexp ".*$") (list 0 (list 'quote face) t)))

(defalias 'highlight-regexp 'p-whim-lock-face-buffer)
(defun p-whim-lock-face-buffer (regexp &optional face)
  "Set face of each match of REGEXP to FACE."
    (read-from-minibuffer "Regexp to highlight: "
			  (cons (or (car p-whim-lock-regexp-history) "") 1 )
			  nil nil 'p-whim-lock-regexp-history)
    (intern (completing-read "Highlight using face: "
                             obarray 'facep t (car p-whim-lock-face-history)
                             '(p-whim-lock-face-history . 0)))))
  (if (or (not (stringp regexp)) (= (length regexp) 0))
      (error "Invalid regexp"))
  (or (facep face) (setq face 'hi-yellow))
  (if (not whim-lock-mode) (whim-lock-mode))
  (add-to-list 'p-whim-lock-interactive-keywords
               (list regexp (list 0 (list 'quote face) t)))

(defalias 'unhighlight-regexp 'p-whim-lock-unface-buffer)
(defun p-whim-lock-unface-buffer (regexp)
  "Remove highlighting of each match to REGEXP set by whim-lock."
      ((history-list (mapcar (lambda (p) (car p))
    (completing-read "Regexp to unhighlight: "
		     p-whim-lock-interactive-keywords t t
		     (car (car p-whim-lock-interactive-keywords))
		     (cons 'history-list 1)))))
 (setq p-whim-lock-interactive-keywords
	(assoc regexp p-whim-lock-interactive-keywords)

(defun p-whim-lock-write-interactive-patterns ()
  "Write interactive patterns, if any, into buffer at point."
   (lambda (pattern)
     (insert (format "%s Whim-lock: (%s) %s\n"
		     (or comment-start "")
		     (prin1-to-string pattern)
		     (or comment-end ""))))

(defun whim-lock-mode (&optional arg)
  "Toggle minor mode for adding per-buffer font-lock patterns.
If ARG positive turn whim-lock on.

\\[p-whim-lock-face-buffer] REGEXP FACE
  Highlight matches of REGEXP with FACE.

\\[p-whim-lock-line-face-buffer] REGEXP FACE
  Highlight lines continain matches of REGEXP with FACE.

\\[p-whim-lock-unface-buffer] REGEXP
  Remove highlighting on matches of REGEXP.

  Write active REGEXPs into buffer as comments (if possible).  They
will be used next time file is loaded.

  Re-read patterns stored in buffer (in format produced by
When font lock started beginning of file searched for:
 Whim-lock: FOO
where FOO is a list of patterns.  These are added to the font lock keywords
already present."
  (let ((whim-lock-mode-prev whim-lock-mode))
    (setq whim-lock-mode
           (if (null arg) (not whim-lock-mode)
             (> (prefix-numeric-value arg) 0)))
    ;; Turned on.
    (if (and (not whim-lock-mode-prev) whim-lock-mode)
          (if (not font-lock-mode) (turn-on-font-lock))
    ;; Turned off.
    (if (and whim-lock-mode-prev (not whim-lock-mode))
          ;; Keep keywords.
          (setq font-lock-keywords p-whim-lock-original-keywords)

(defun whim-lock-find-file-hook ()
  "Turn on whim lock if patterns present."

;; Support Functions

(defun p-current-line (&optional end)
  "Return line number of point or END, whichever is smaller."
    (1+ (count-lines 1 (or end (point))))))

;; Implementation Functions

(defun p-whim-lock-set-keywords (&optional reinit)
  "Add whim-lock's interactive and file keywords to font-lock keywords.
Save font-lock's existing keywords if not already saved or if REINIT non-null."
  (if (or reinit (null p-whim-lock-original-keywords))
      (setq p-whim-lock-original-keywords (or font-lock-keywords '(t))))
  (setq font-lock-keywords
	(append (delq t p-whim-lock-original-keywords)

(add-hook 'font-lock-mode-hook 'p-whim-lock-grab-keywords)
(add-hook 'find-file-hooks 'whim-lock-find-file-hook)

(defun p-whim-lock-grab-keywords ()
  "If whim lock on, save font lock's keywords."
  (if whim-lock-mode (progn (p-whim-lock-set-keywords t))))

(defun p-whim-lock-refontify ()
  "Unfontify and refontify buffer.  Used when whim-lock patterns change."
  (if (not font-lock-mode) (font-lock-mode))
   ;; Need a better way, since this assumes too much about lazy lock.
    (let ((windows (get-buffer-window-list (current-buffer) 'nomini t)))
      (while windows
;	  (lazy-lock-fontify-conservatively (car windows))
        (lazy-lock-fontify-window (car windows))
        (setq windows (cdr windows)))))
   (t (font-lock-fontify-buffer))))

(defun p-whim-lock-find-patterns ()
  "Find patterns in current buffer for whim lock."
   (memq major-mode p-whim-lock-exclude-modes)
   (let ((all-patterns nil))
       (goto-char (point-min))
            (re-search-forward "\\<Whim-lock: " (+ (point) 5000) t)
            (not (looking-at "end")))
               (condition-case nil
                   (read (current-buffer))
                 (error  (message
                          (format "Could not read expression at %d"
           (if patterns
               (setq all-patterns
                     (append patterns all-patterns))))))
     (if (and (not whim-lock-mode) all-patterns)
         (whim-lock-mode 1))
     (if whim-lock-mode
           (setq p-whim-lock-file-keywords all-patterns)

(provide 'p-whim-lock)

;;; p-whim-lock.el ends here