faces+.el - extensions to GNU `faces.el'

[Drew Adams]

;;; faces+.el --- Extensions to `faces.el'.
;; 
;; Emacs Lisp Archive Entry
;; Filename: faces+.el
;; Description: Extensions to `faces.el'.
;; Author: Drew Adams
;; Maintainer: Drew Adams
;; Copyright (C) 1996-2001, Drew Adams, all rights reserved.
;; Created: Fri Jun 28 15:07:06 1996
;; Version: $Id: faces+.el,v 1.6 2001/01/08 22:46:29 dadams Exp $
;; Last-Updated: Mon Jan  8 14:46:24 2001
;;           By: dadams
;;     Update #: 81
;; Keywords: faces, local
;; Compatibility: GNU Emacs 20.x
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Commentary: 
;; 
;;    Extensions to `faces.el'.
;;
;;
;;  ***** NOTE: The following functions defined in `faces.el' have
;;              been REDEFINED HERE:
;;
;;  `make-face' - Uses `completing-read' in the interactive spec,
;;                with, as default, `symbol-nearest-point'.
;;
;;  `read-face-name' - `highlight' face is the default.
;;
;;
;;  This file should be loaded after loading the standard GNU file
;;  `faces.el'.  So, in your `~/.emacs' file, do this:
;;  (eval-after-load "faces" '(require 'faces+))
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;; Change log:
;; 
;; RCS $Log: faces+.el,v $
;; RCS Revision 1.6  2001/01/08 22:46:29  dadams
;; RCS Adapted file header for Emacs Lisp Archive.
;; RCS
;; RCS Revision 1.5  2001/01/05 18:00:41  dadams
;; RCS '(lambda...) -> (function (lambda...))
;; RCS
;; RCS Revision 1.4  2001/01/03 17:34:48  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.3  2001/01/03 00:36:56  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.2  2000/11/28 19:32:35  dadams
;; RCS Optional require's via 3rd arg=t now.
;; RCS
;; RCS Revision 1.1  2000/09/14 15:43:50  dadams
;; RCS Initial revision
;; RCS
; Revision 1.2  1999/03/17  13:28:59  dadams
; 1. protect calls with fboundp.
; 2. Updated to corrspond with version Emacs 34.1.
;
; Revision 1.1  1997/03/20  16:33:33  dadams
; Initial revision
;
; Revision 1.2  1996/07/15  09:04:03  dadams
; 1. Added redefinition of make-face.  Require cl.el.
; 2. Removed (unused) definition of old-read-face-name.
;
; Revision 1.1  1996/07/01  09:57:00  dadams
; Initial revision
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;; 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, 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.

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

(require 'faces)
(require 'cl) ;; when, unless, push, pop

(require 'thingatpt nil t) ;; (no error if not found): symbol-at-point
(require 'thingatpt+ nil t) ;; (no error if not found): symbol-nearest-point


(provide 'faces+)

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


;; REPLACES ORIGINAL in `faces.el': `highlight' face is the default.
;;;###autoload
(defun read-face-name (prompt)
  "Read name of a face (default: \"highlight\") and return it as a symbol.
Prompts with arg PROMPT (a string)."
  (let (face)
    (while (zerop (length face))
      (setq face (completing-read
                  prompt
                  (mapcar (function (lambda (x) (list (symbol-name x)))) 
(face-list))
                  nil t "highlight" 'minibuffer-history "highlight" t)))
    (intern face)))


;; REPLACES ORIGINAL in `faces.el':
;; Uses `completing-read' in interactive spec, with `symbol-nearest-point'.
;; `symbol-nearest-point' is defined in `thingatpt+.el'.
;; `symbol-at-point' is defined in `thingatpt.el'.
;;;###autoload
(defun make-face (name &optional no-resources)
  "Define a new face named NAME, on all frames.  
You can modify the font, color, etc of this face with the `set-face-*'
functions.  

If NO-RESOURCES is non-nil, then we ignore X resources
and always make a face whose attributes are all nil.

If the face already exists, it is unmodified.
The argument, NAME, is returned."
  (interactive
   (let ((symb (cond ((fboundp 'symbol-nearest-point) (symbol-nearest-point))
                     ((fboundp 'symbol-at-point) (symbol-at-point))
                     (t nil)))
         (enable-recursive-minibuffers t))
     (list (intern (completing-read "Make face: " obarray nil nil
                                     ; convert to string
                                    (symbol-name symb) nil
                                    (symbol-name symb) t)))))
  (unless (internal-find-face name)
    (let ((face (make-vector 12 nil)))
      (aset face 0 'face)
      (aset face 1 name)
      (let* ((frames (frame-list))
             (inhibit-quit t)
             (id (internal-next-face-id)))
        (when (fboundp 'make-face-internal) (make-face-internal id))
        (aset face 2 id)
        (while frames
          (set-frame-face-alist (car frames)
                                (cons (cons name (copy-sequence face))
                                      (frame-face-alist (car frames))))
          (pop frames))
        (push (cons name face) global-face-data))
      ;; When making a face after frames already exist.
      (unless no-resources
        (when (memq window-system '(x w32 win32)) 
(make-face-x-resource-internal face)))
      ;; Add to face menu.
      (when (fboundp 'facemenu-add-new-face) (facemenu-add-new-face name))))
  name)                                 ; Return the NAME.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; `faces+.el' ends here