Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/kotl/kfill.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: kfill.el
4 ;; SUMMARY: Fill and justify koutline cells (adapted from Kyle Jones' filladapt).
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: outlines, wp
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORIG-DATE: 23-Jan-94
10 ;; LAST-MOD: 4-Nov-95 at 04:53:42 by Bob Weiner
11 ;;; ************************************************************************
12 ;;; Public variables
13 ;;; ************************************************************************
14
15 (defvar kfill:function-table
16 (progn
17 (if (featurep 'filladapt)
18 (progn (load "fill") ;; Save basic fill-paragraph function.
19 (load "simple"))) ;; Save basic do-auto-fill function.
20 (list (cons 'fill-paragraph (symbol-function 'fill-paragraph))
21 (cons 'do-auto-fill (symbol-function 'do-auto-fill))))
22 "Table containing the old function definitions that kfill overrides.")
23
24 (defvar kfill:prefix-table
25 '(
26 ;; Lists with hanging indents, e.g.
27 ;; 1. xxxxx or 1) xxxxx etc.
28 ;; xxxxx xxx
29 ;;
30 ;; Be sure pattern does not match to: (last word in parens starts
31 ;; newline)
32 (" *(?\\([0-9][0-9a-z.]*\\|[a-z][0-9a-z.]\\)) +" . kfill:hanging-list)
33 (" *\\([0-9]+[a-z.]+[0-9a-z.]*\\|[0-9]+\\|[a-z]\\)\\([.>] +\\| +\\)"
34 . kfill:hanging-list)
35 ;; Included text in news or mail replies
36 ("[ \t]*\\(>+ *\\)+" . kfill:normal-included-text)
37 ;; Included text generated by SUPERCITE. We can't hope to match all
38 ;; the possible variations, your mileage may vary.
39 ("[ \t]*[A-Za-z0-9][^'`\"< \t\n]*>[ \t]*" . kfill:supercite-included-text)
40 ;; Lisp comments
41 ("[ \t]*\\(;+[ \t]*\\)+" . kfill:lisp-comment)
42 ;; UNIX shell comments
43 ("[ \t]*\\(#+[ \t]*\\)+" . kfill:sh-comment)
44 ;; Postscript comments
45 ("[ \t]*\\(%+[ \t]*\\)+" . kfill:postscript-comment)
46 ;; C++ comments
47 ("[ \t]*//[/ \t]*" . kfill:c++-comment)
48 ("[?!~*+ -]+ " . kfill:hanging-list)
49 ;; This keeps normal paragraphs from interacting unpleasantly with
50 ;; the types given above.
51 ("[^ \t/#%?!~*+-]" . kfill:normal)
52 )
53 "Value is an alist of the form
54
55 ((REGXP . FUNCTION) ...)
56
57 When fill-paragraph or do-auto-fill is called, the REGEXP of each alist
58 element is compared with the beginning of the current line. If a match
59 is found the corresponding FUNCTION is called. FUNCTION is called with
60 one argument, which is non-nil when invoked on the behalf of
61 fill-paragraph, nil for do-auto-fill. It is the job of FUNCTION to set
62 the values of the paragraph-* variables (or set a clipping region, if
63 paragraph-start and paragraph-separate cannot be made discerning enough)
64 so that fill-paragraph and do-auto-fill work correctly in various
65 contexts.")
66
67 ;;; ************************************************************************
68 ;;; Public functions
69 ;;; ************************************************************************
70
71 (defun do-auto-fill ()
72 (save-restriction
73 (if (null fill-prefix)
74 (let ((paragraph-ignore-fill-prefix nil)
75 ;; Need this or Emacs 19 ignores fill-prefix when
76 ;; inside a comment.
77 (comment-multi-line t)
78 fill-prefix)
79 (kfill:adapt nil)
80 (kfill:funcall 'do-auto-fill))
81 (kfill:funcall 'do-auto-fill))))
82
83 (defun fill-paragraph (arg &optional skip-prefix-remove)
84 "Fill paragraph at or after point. Prefix ARG means justify as well."
85 (interactive "*P")
86 ;; Emacs 19 expects a specific symbol here.
87 (if (and arg (not (symbolp arg))) (setq arg 'full))
88 (or skip-prefix-remove (kfill:remove-paragraph-prefix))
89 (save-restriction
90 (catch 'done
91 (if (null fill-prefix)
92 (let ((paragraph-ignore-fill-prefix nil)
93 ;; Need this or Emacs 19 ignores fill-prefix when
94 ;; inside a comment.
95 (comment-multi-line t)
96 (paragraph-start paragraph-start)
97 (paragraph-separate paragraph-separate)
98 fill-prefix)
99 (if (kfill:adapt t)
100 (throw 'done (kfill:funcall 'fill-paragraph arg)))))
101 ;; Kfill:adapt failed or fill-prefix is set, so do a basic
102 ;; paragraph fill as adapted from par-align.el.
103 (kfill:fill-paragraph arg skip-prefix-remove))))
104
105 ;;;
106 ;;; Redefine this function so that it sets 'fill-prefix-prev' also.
107 ;;;
108 (defun set-fill-prefix (&optional turn-off)
109 "Set the fill-prefix to the current line up to point.
110 Also sets fill-prefix-prev to previous value of fill-prefix.
111 Filling expects lines to start with the fill prefix and reinserts the fill
112 prefix in each resulting line."
113 (interactive)
114 (setq fill-prefix-prev fill-prefix
115 fill-prefix (if turn-off
116 nil
117 (buffer-substring
118 (save-excursion (beginning-of-line) (point))
119 (point))))
120 (if (equal fill-prefix-prev "")
121 (setq fill-prefix-prev nil))
122 (if (equal fill-prefix "")
123 (setq fill-prefix nil))
124 (if fill-prefix
125 (message "fill-prefix: \"%s\"" fill-prefix)
126 (message "fill-prefix cancelled")))
127
128 ;;; ************************************************************************
129 ;;; Private functions
130 ;;; ************************************************************************
131
132 (defun kfill:adapt (paragraph)
133 (let ((table kfill:prefix-table)
134 case-fold-search
135 success )
136 (save-excursion
137 (beginning-of-line)
138 (while table
139 (if (not (looking-at (car (car table))))
140 (setq table (cdr table))
141 (funcall (cdr (car table)) paragraph)
142 (setq success t table nil))))
143 success ))
144
145 (defun kfill:c++-comment (paragraph)
146 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
147 (if paragraph
148 (setq paragraph-separate "^[^ \t/]")))
149
150 (defun kfill:fill-paragraph (justify-flag &optional leave-prefix)
151 (save-excursion
152 (end-of-line)
153 ;; Backward to para begin
154 (re-search-backward (concat "\\`\\|" paragraph-separate))
155 (forward-line 1)
156 (let ((region-start (point)))
157 (forward-line -1)
158 (let ((from (point)))
159 (forward-paragraph)
160 ;; Forward to real paragraph end
161 (re-search-forward (concat "\\'\\|" paragraph-separate))
162 (or (= (point) (point-max)) (beginning-of-line))
163 (or leave-prefix
164 (kfill:replace-string
165 (or fill-prefix fill-prefix-prev)
166 "" nil region-start (point)))
167 (fill-region-as-paragraph from (point) justify-flag)))))
168
169 (defun kfill:funcall (function &rest args)
170 (apply (cdr (assq function kfill:function-table)) args))
171
172 (defun kfill:hanging-list (paragraph)
173 (let (prefix match beg end)
174 (setq prefix (make-string (- (match-end 0) (match-beginning 0)) ?\ ))
175 (if paragraph
176 (progn
177 (setq match (buffer-substring (match-beginning 0) (match-end 0)))
178 (if (string-match "^ +$" match)
179 (save-excursion
180 (while (and (not (bobp)) (looking-at prefix))
181 (forward-line -1))
182
183 (cond ((kfill:hanging-p)
184 (setq beg (point)))
185 (t (setq beg (progn (forward-line 1) (point))))))
186 (setq beg (point)))
187 (save-excursion
188 (forward-line)
189 (while (and (looking-at prefix)
190 (not (equal (char-after (match-end 0)) ?\ )))
191 (forward-line))
192 (setq end (point)))
193 (narrow-to-region beg end)))
194 (setq fill-prefix prefix)))
195
196 (defun kfill:hanging-p ()
197 "Return non-nil iff point is in front of a hanging list."
198 (eval kfill:hanging-expression))
199
200 (defun kfill:lisp-comment (paragraph)
201 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
202 (if paragraph
203 (setq paragraph-separate
204 (concat "^" fill-prefix " *;\\|^"
205 (kfill:negate-string fill-prefix)))))
206
207 (defun kfill:negate-string (string)
208 (let ((len (length string))
209 (i 0) string-list)
210 (setq string-list (cons "\\(" nil))
211 (while (< i len)
212 (setq string-list
213 (cons (if (= i (1- len)) "" "\\|")
214 (cons "]"
215 (cons (substring string i (1+ i))
216 (cons "[^"
217 (cons (regexp-quote (substring string 0 i))
218 string-list)))))
219 i (1+ i)))
220 (setq string-list (cons "\\)" string-list))
221 (apply 'concat (nreverse string-list))))
222
223 (defun kfill:normal (paragraph)
224 (if paragraph
225 (setq paragraph-separate
226 (concat paragraph-separate "\\|^[ \t/#%?!~*+-]"))))
227
228 (defun kfill:normal-included-text (paragraph)
229 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
230 (if paragraph
231 (setq paragraph-separate
232 (concat "^" fill-prefix " *>\\|^"
233 (kfill:negate-string fill-prefix)))))
234
235 (defun kfill:postscript-comment (paragraph)
236 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
237 (if paragraph
238 (setq paragraph-separate
239 (concat "^" fill-prefix " *%\\|^"
240 (kfill:negate-string fill-prefix)))))
241
242 (defun kfill:remove-paragraph-prefix (&optional indent-str)
243 "Remove fill prefix from current paragraph."
244 (save-excursion
245 (end-of-line)
246 ;; Backward to para begin
247 (re-search-backward (concat "\\`\\|" paragraph-separate))
248 (forward-line 1)
249 (let ((region-start (point)))
250 (forward-line -1)
251 (forward-paragraph)
252 ;; Forward to real paragraph end
253 (re-search-forward (concat "\\'\\|" paragraph-separate))
254 (or (= (point) (point-max)) (beginning-of-line))
255 (kfill:replace-string (or fill-prefix fill-prefix-prev)
256 (if (eq major-mode 'kotl-mode)
257 (or indent-str
258 (make-string (kcell-view:indent) ? ))
259 "")
260 nil region-start (point)))))
261
262 (defun kfill:replace-string (fill-str-prev fill-str &optional suffix start end)
263 "Replace whitespace separated FILL-STR-PREV with FILL-STR.
264 Optional SUFFIX non-nil means replace at ends of lines, default is beginnings.
265 Optional arguments START and END specify the replace region, default is the
266 current region."
267 (if fill-str-prev
268 (progn (if start
269 (let ((s (min start end)))
270 (setq end (max start end)
271 start s))
272 (setq start (region-beginning)
273 end (region-end)))
274 (if (not fill-str) (setq fill-str ""))
275 (save-excursion
276 (save-restriction
277 (narrow-to-region start end)
278 (goto-char (point-min))
279 (let ((prefix
280 (concat
281 (if suffix nil "^")
282 "[ \t]*"
283 (regexp-quote
284 ;; Get non-whitespace separated fill-str-prev
285 (substring
286 fill-str-prev
287 (or (string-match "[^ \t]" fill-str-prev) 0)
288 (if (string-match
289 "[ \t]*\\(.*[^ \t]\\)[ \t]*$"
290 fill-str-prev)
291 (match-end 1))))
292 "[ \t]*"
293 (if suffix "$"))))
294 (while (re-search-forward prefix nil t)
295 (replace-match fill-str nil t))))))))
296
297 (defun kfill:sh-comment (paragraph)
298 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
299 (if paragraph
300 (setq paragraph-separate
301 (concat "^" fill-prefix " *#\\|^"
302 (kfill:negate-string fill-prefix)))))
303
304 (defun kfill:supercite-included-text (paragraph)
305 (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
306 (if paragraph
307 (setq paragraph-separate
308 (concat "^" (kfill:negate-string fill-prefix)))))
309
310 ;;; ************************************************************************
311 ;;; Private variables
312 ;;; ************************************************************************
313
314 (defconst kfill:hanging-expression
315 (cons 'or
316 (delq nil (mapcar (function
317 (lambda (pattern-type)
318 (if (eq (cdr pattern-type) 'kfill:hanging-list)
319 (list 'looking-at (car pattern-type)))))
320 kfill:prefix-table)))
321 "Conditional expression used to test for hanging indented lists.")
322
323 (defvar fill-prefix-prev nil
324 "Prior string inserted at front of new line during filling, or nil for none.
325 Setting this variable automatically makes it local to the current buffer.")
326 (make-variable-buffer-local 'fill-prefix-prev)
327
328
329 (provide 'kfill)