cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/kotl/kfill.el

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