;;; filladapt.el --- adaptive fill; replacement for fill commands

;; Keywords: wp

;;; Copyright (C) 1989 Kyle E. Jones
;;;
;;; 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 1, 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.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to kyle@cs.odu.edu) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Send bug reports to kyle@crystal.wonderworks.com.

;;; Synched up with: Not synched with FSF.

;; This package provides no muss, no fuss word wrapping and filling of
;; paragraphs with hanging indents, included text from news and mail
;; messages, and Lisp, C++, PostScript or shell comments.  It is table
;; driven, so you can add your own favorites.
;;
;; These functions enhance the default behavior of the Emacs'
;; auto-fill-mode and the command fill-paragraph.  The chief improvement
;; is that the beginning of a line to be filled is examined and
;; appropriate values for fill-prefix, and the various paragraph-*
;; variables are constructed and used during fills.  This occurs only if
;; the fill prefix is not already non-nil.
;;
;; The net result of this is that blurbs of text that are offset from
;; left margin by asterisks, dashes, and/or spaces, numbered examples,
;; included text from USENET news articles, etc. are generally filled
;; correctly with no fuss.
;;
;; Since this package replaces two existing Emacs functions, it cannot
;; be autoloaded.  Save this in a file named filladapt.el in a Lisp
;; directory that Emacs knows about, byte-compile it and put
;;    (require 'filladapt)
;; in your .emacs file.

(provide 'filladapt)

(defvar filladapt-prefix-table
  '(
    ;; Included text in news or mail replies
    ("[ \t]*\\(>+ *\\)+" . filladapt-normal-included-text)
    ;; Included text generated by SUPERCITE.  We can't hope to match all
    ;; the possible variations, your mileage may vary.
    ("[^'`\"< \t]*> *" . filladapt-supercite-included-text)
    ;; Lisp comments
    ("[ \t]*\\(;+[ \t]*\\)+" . filladapt-lisp-comment)
    ;; UNIX shell comments
    ("[ \t]*\\(#+[ \t]*\\)+" . filladapt-sh-comment)
    ;; Postscript comments
    ("[ \t]*\\(%+[ \t]*\\)+" . filladapt-postscript-comment)
    ;; C++ comments
    ("[ \t]*//[/ \t]*" . filladapt-c++-comment)
    ;; Lists with hanging indents, e.g.
    ;; 1. xxxxx   or   *   xxxxx   etc.
    ;;    xxxxx            xxx
    (" *(?\\([0-9]+[a-z]?\\|[a-z]\\)) +" . filladapt-hanging-list)
    (" *\\([0-9]+[a-z]?\\|[a-z]\\)\\. +" . filladapt-hanging-list)
    ("[?!~*+ ---]+ " . filladapt-hanging-list)
    ;; This keeps normal paragraphs from interacting unpleasantly with
    ;; the types given above.
    ("[^ \t/#%?!~*+---]" . filladapt-normal)
    )
"Value is an alist of the form

   ((REGXP . FUNCTION) ...)

When fill-paragraph or do-auto-fill is called, the REGEXP of each alist
element is compared with the beginning of the current line.  If a match
is found the crorrespoding FUNCTION is called.  FUNCTION is called with
one argument, which is non-nil when invoked on the behalf of
fill-paragraph, nil for do-auto-fill.  It is the job of FUNCTION to set
the values of the paragraph-* variables (or set a clipping region, if
paragraph-start and paragraph-separate cannot be made discerning enough)
so that fill-paragraph and do-auto-fill work correctly in various
contexts.")

(defvar filladapt-function-table
  (list (cons 'fill-paragraph (symbol-function 'fill-paragraph))
	(cons 'do-auto-fill (symbol-function 'do-auto-fill)))
  "Table containing the old function definitions that filladapt usurps.")

(defun filladapt-funcall (function &rest args)
  (apply (cdr (assoc function filladapt-function-table)) args))

(defun filladapt-adapt (paragraph)
  (let ((table filladapt-prefix-table)
	case-fold-search
	success )
    (save-excursion
      (beginning-of-line)
      (while table
	(if (not (looking-at (car (car table))))
	    (setq table (cdr table))
	  (funcall (cdr (car table)) paragraph)
	  (setq success t table nil))))
    success ))

(defun filladapt-negate-string (string)
  (let ((len (length string))
	(i 0) string-list)
    (setq string-list (cons "\\(" nil))
    (while (< i len)
      (setq string-list
	    (cons (if (= i (1- len)) "" "\\|")
		  (cons "]"
			(cons (let ((str (substring string i (1+ i))))
				(cond ((equal str "-") "---")
				      (t str)))
			      (cons "[^"
				    (cons (regexp-quote (substring string 0 i))
					  string-list)))))
	    i (1+ i)))
    (setq string-list (cons "\\)" string-list))
    (apply 'concat (nreverse string-list))))

(defun filladapt-normal-included-text (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate
	    (concat "^" fill-prefix " *>\\|^"
		    (filladapt-negate-string fill-prefix)))))

(defun filladapt-supercite-included-text (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate
	    (concat "^" (filladapt-negate-string fill-prefix)))))

(defun filladapt-lisp-comment (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate
	    (concat "^" fill-prefix " *;\\|^"
		    (filladapt-negate-string fill-prefix)))))

(defun filladapt-postscript-comment (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate
	    (concat "^" fill-prefix " *%\\|^"
		    (filladapt-negate-string fill-prefix)))))

(defun filladapt-sh-comment (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate
	    (concat "^" fill-prefix " *#\\|^"
		    (filladapt-negate-string fill-prefix)))))

(defun filladapt-c++-comment (paragraph)
  (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  (if paragraph
      (setq paragraph-separate "^[^ \t/]")))

(defun filladapt-hanging-list (paragraph)
  (let (prefix match beg end)
    (setq prefix (make-string (- (match-end 0) (match-beginning 0)) ?\ ))
    (if paragraph
	(progn
	  (setq match (buffer-substring (match-beginning 0) (match-end 0)))
	  (if (string-match "^ +$" match)
	      (save-excursion
		(while (and (not (bobp)) (looking-at prefix))
		  (forward-line -1))
		(cond ((or (looking-at " *(?\\([0-9]+[a-z]?\\|[a-z]\\)) +")
			   (looking-at " *\\([0-9]+[a-z]?\\|[a-z]\\)\\. +")
			   (looking-at " *[?!~*+---]+ +"))
		       (setq beg (point)))
		      (t (setq beg (progn (forward-line 1) (point))))))
	    (setq beg (point)))
	  (save-excursion
	    (forward-line)
	    (while (and (looking-at prefix)
			(not (equal (char-after (match-end 0)) ?\ )))
	      (forward-line))
	    (setq end (point)))
	  (narrow-to-region beg end)))
    (setq fill-prefix prefix)))

(defun filladapt-normal (paragraph)
  (if paragraph
      (setq paragraph-separate
	    (concat paragraph-separate "\\|^[ \t/#%?!~*+---]"))))

(defun do-auto-fill ()
  (save-restriction
    (if (null fill-prefix)
	(let (fill-prefix)
	  (filladapt-adapt nil)
	  (filladapt-funcall 'do-auto-fill))
      (filladapt-funcall 'do-auto-fill))))

(defun fill-paragraph (arg)
  (interactive "P")
  (save-restriction
    (catch 'done
      (if (null fill-prefix)
	  (let (paragraph-ignore-fill-prefix
		fill-prefix
		(paragraph-start paragraph-start)
		(paragraph-separate paragraph-separate))
	    (if (filladapt-adapt t)
		(throw 'done (filladapt-funcall 'fill-paragraph arg)))))
      ;; filladapt-adapt failed, so do fill-paragraph normally.
      (filladapt-funcall 'fill-paragraph arg))))
