;;; headers.el --- header insertion and editing routines

;; Copyright (C) 2001, 2002 by Free Software Foundation, Inc.

;; Author: Peder Stray <peder@linpro.no>
;; Keywords: convenience, outlines
;; Time-stamp: <2002-01-03 20:02:54 peder@linpro.no>
;;
;;   $Id: header.el,v 1.3 2002/01/03 20:06:49 peder Exp $

;; This file 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 file 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This package includes functions for insertion and editing of headers,
;; outline setup and font-lock fontification rules for these headers.

;;; Code:

(defgroup headers nil
  "Support for header editing"
  :prefix "header-"
  :group 'outlines)

(defcustom header-remove-blank-lines t
  "*If non-nil, `header-insert' will remove empty lines before the header."
  :type 'boolean
  :group 'headers)

(defcustom header-font-list
  '(font-lock-warning-face
    font-lock-function-name-face
    font-lock-variable-name-face
    font-lock-keyword-face
    font-lock-builtin-face
    font-lock-constant-face
    font-lock-type-face
    font-lock-string-face)
  "*Fonts used to fontify headers. First element is the default font."
  :type '(repeat face)
  :group 'headers)

(defcustom header-flag-font 'bold
  "*Font used to fontify header flags."
  :type 'face
  :group 'headers)

(defcustom header-min-indent 3
  "*Minimum level of indent of the title in header lines."
  :type 'integer
  :group 'headers)

(defcustom header-indent-level 2
  "*Extra indentation per header level."
  :type 'integer
  :group 'headers)

(defcustom header-chars "-="
  "*Characters used for headers."
  :type 'string
  :group 'headers)

(defcustom header-initial-hide nil
  "*Hide all bodies in document when turning on header-minor-mode."
  :type 'boolean
  :group 'headers)
(make-variable-buffer-local 'header-initial-hide)

(defcustom header-minor-mode nil
  "Non-nil if using Header minor mode."
  :type 'boolean
  :group 'headers)
(make-variable-buffer-local 'header-minor-mode)

(defcustom header-minor-mode-prefix "\C-c\C-h"
  "*Prefix key to use for Header commands in minor mode.
The value of this variable is checked as part of loading Header.")

;;;###autoload
(defun header-insert (header &optional arg)
  "Insert a header line.
Without prefix, on the same level as previous, with prefix, indented."
  (interactive "*sHeader: \nP")
  (beginning-of-line)
  (let ((re (header-regexp)) 
	(level 1))
    (save-excursion
      (if (re-search-backward re nil t)
	  (setq level (header-level-string (match-string 1) (if arg 1 0)))))
    (insert (concat "\n\n" (header-string header level) "\n\n"))
    (when header-remove-blank-lines
      (forward-line -3)
      (delete-blank-lines)
      (forward-line 3))))

;;;###autoload
(defun header-edit ()
  "Edit header for current section."
  (interactive "*")
  (save-excursion
    (beginning-of-line)
    (let ((re (header-regexp)))
      (when (or (looking-at re)
		(re-search-backward re nil t))
	(replace-match
	 (header-string
	  (read-string "Header: " (match-string 2) nil (match-string 2))
	  (header-level-string (match-string 1))
	  (match-string 4)) t t)))))

;;;###autoload
(defun header-indent (&optional arg)
  "Indent current header. With prefix, unindent."
  (interactive "*P")
  (save-excursion
    (beginning-of-line)
    (let ((re (header-regexp)))
      (when (or (looking-at re)
		(re-search-backward re nil t))
	(replace-match
	 (header-string
	  (match-string 2)
	  (header-level-string (match-string 1) (if arg -1 1))
	  (match-string 4)) t t)))))

;;;###autoload
(defun header-flag-add (char)
  "*Add a flag character to current header."
  (interactive "*c")
  (save-excursion
    (beginning-of-line)
    (let ((re (header-regexp)) flags)
      (when (or (looking-at re)
		(re-search-backward re nil t))
	(setq flags (append (match-string 4) nil))
	(if (null (memq char flags))
	    (replace-match
	     (header-string
	      (match-string 2)
	      (header-level-string (match-string 1))
	      (apply 'string
		     (sort (append flags (list char)) '<))) t t))))))

;;;###autoload
(defun header-flag-remove (char)
  "*Remove a flag character from current header."
  (interactive "*c")
  (save-excursion
    (beginning-of-line)
    (let ((re (header-regexp)) flags)
      (when (or (looking-at re)
		(re-search-backward re nil t))
	(setq flags (append (match-string 4) nil))
	(if (memq char flags)
	    (replace-match
	     (header-string
	      (match-string 2)
	      (header-level-string (match-string 1))
	      (apply 'string
		     (sort (delq char flags)
			   '<))) t t))))))

;;;###autoload
(defun header-flag-clear ()
  "*Remove all flags from current header."
  (interactive "*")
  (save-excursion
    (beginning-of-line)
    (let ((re (header-regexp)))
      (when (or (looking-at re)
		(re-search-backward re nil t))
	(if (match-string 4)
	    (replace-match
	     (header-string
	      (match-string 2)
	      (header-level-string (match-string 1)))))))))

;;;###autoload
(defun header-minor-mode (&optional arg)
  "Toggle Header minor mode.
With ARG, turn Header minor mode on if positive, off otherwise."
  (interactive "P")
  (setq header-minor-mode
	(if (null arg) (not header-minor-mode)
	  (> (prefix-numeric-value arg) 0)))
  (if header-minor-mode
      (progn
	(outline-minor-mode 1)
	(font-lock-add-keywords
	 major-mode
	 (list (list (header-regexp)
		     '(2 (header-font) prepend)
		     '(4 header-flag-font t t))))
	(when font-lock-mode
	  ; reinitialize font-lock
	  (font-lock-mode (not font-lock-mode))
	  (font-lock-mode (not font-lock-mode)))
	(setq outline-regexp
	      (concat comment-start " *[" header-chars "]+"))
	(if header-initial-hide
	    (progn
	      (save-excursion
		(goto-char (point-min))
		(outline-next-heading)
		(hide-region-body (point) (point-max)))
	      (if (eq this-command 'header-minor-mode)
		  (if (outline-visible)
		      nil (show-entry))
		; this is for desktop-read
		(add-hook 'desktop-delay-hook
			  `(lambda ()
			     (save-excursion
			       (set-buffer ,(buffer-name))
			       (if (outline-visible)
				   nil (show-entry)))))))))
    (outline-minor-mode 0)))

;;; support methods

(defun header-char (level)
  "*Get separator character for LEVEL."
  (let ((list (append header-chars nil)))
    (or (nth level list)
	(car list))))

(defun header-string (header level &optional flags)
  "Generate a header line."
  (let* ((char (header-char level))
	 (start (concat comment-start
			(if (equal (substring comment-start -1) " ")
			    (string char) " ")
			(make-string
			 (+ header-min-indent
			    (* header-indent-level level)) char)))
	 (head (concat "[ " header " ]"))
	 (flag (if (< 0 (length flags))
		   (concat "[" flags "]") ""))
	 (end (concat (string char)
		      (if (and (< 0 (length comment-end))
			       (not (equal (substring comment-end 0 1) " ")))
			  " ")
		      comment-end)))
    (concat start head
	    (make-string (- fill-column
			    (length start)
			    (length head)
			    (length flag)
			    (length end)) char)
	    flag end)))

(defun header-regexp ()
  "Return regexp for use with header search."
  (let ((sep header-chars))
    (concat "^" (regexp-quote comment-start) " *\\([" sep "]+\\)"
	    "\\[ \\(.*\\) \\]" "[" sep "]+" "\\(\\[\\(.+\\)\\]\\)?"
	    "[" sep "]" " *" (regexp-quote comment-end) "$")))

(defun header-level-string (string &optional addition)
  "Calculate level from STRING."
  (let ((level (/ (- (length string) header-min-indent) 
		  header-indent-level)))
    (if (numberp addition)
	(setq level (+ level addition)))
    (if (> level 1) level 1)))
	
(defun header-level ()
  "Return level of current section."
  (save-excursion
    (save-match-data
      (if (re-search-backward (header-regexp) nil t)
	  (header-level-string (match-string 1))
	0))))
   
(defun header-font ()
  "Return font to use for fontification."
  (or (nth (header-level) header-font-list)
	(car header-font-list)))

; keybindings

(defvar header-prefix-map nil)
(if header-prefix-map
    nil
  (setq header-prefix-map (make-sparse-keymap))
  (define-key header-prefix-map "i" 'header-insert)
  (define-key header-prefix-map "e" 'header-edit)
  (define-key header-prefix-map "\C-i" 'header-indent)
  (define-key header-prefix-map "f" 'header-flag-add)
  (define-key header-prefix-map "d" 'header-flag-remove)
  (define-key header-prefix-map "c" 'header-flag-clear))

(defvar header-minor-mode-map nil)
(if header-minor-mode-map
    nil
  (setq header-minor-mode-map (make-sparse-keymap))
  (define-key header-minor-mode-map header-minor-mode-prefix
    header-prefix-map))

(or (assq 'header-minor-mode minor-mode-map-alist)
    (setq minor-mode-map-alist
	  (cons (cons 'header-minor-mode header-minor-mode-map)
		minor-mode-map-alist)))

(provide 'header)

;;; header.el ends here