nxhtml/util/wrap-to-fill.el

   1 ;;; wrap-to-fill.el --- Make a fill-column wide space for editing
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2009-08-12 Wed
   5 ;; Version:
   6 ;; Last-Updated: x
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;;
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or
  29 ;; modify it under the terms of the GNU General Public License as
  30 ;; published by the Free Software Foundation; either version 3, or
  31 ;; (at your option) any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  36 ;; General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to
  40 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  41 ;; Floor, Boston, MA 02110-1301, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 (eval-when-compile (require 'mumamo))
  48
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 ;;;; Wrapping
  51
  52 ;;;###autoload
  53 (defgroup wrap-to-fill nil
  54   "Customizing of `wrap-to-fill-column-mode'."
  55   :group 'convenience)
  56
  57 ;;;###autoload
  58 (defcustom wrap-to-fill-left-marg nil
  59   "Left margin handling for `wrap-to-fill-column-mode'.
  60 Used by `wrap-to-fill-column-mode'. If nil then center the
  61 display columns. Otherwise it should be a number which will be
  62 the left margin."
  63   :type '(choice (const :tag "Center" nil)
  64                  (integer :tag "Left margin"))
  65   :group 'wrap-to-fill)
  66 (make-variable-buffer-local 'wrap-to-fill-left-marg)
  67
  68 (defvar wrap-to-fill--saved-state nil)
  69 ;;(make-variable-buffer-local 'wrap-to-fill--saved-state)
  70 (put 'wrap-to-fill--saved-state 'permanent-local t)
  71
  72 ;;;###autoload
  73 (defcustom wrap-to-fill-left-marg-modes
  74   '(text-mode
  75     fundamental-mode)
  76   "Major modes where `wrap-to-fill-left-margin' may be nil."
  77   :type '(repeat command)
  78   :group 'wrap-to-fill)
  79
  80
  81          ;;ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord
  82
  83 (defun wrap-to-fill-wider ()
  84   "Increase `fill-column' with 10."
  85   (interactive)
  86   (setq fill-column (+ fill-column 10))
  87   (wrap-to-fill-set-values-in-buffer-windows))
  88
  89 (defun wrap-to-fill-narrower ()
  90   "Decrease `fill-column' with 10."
  91   (interactive)
  92   (setq fill-column (- fill-column 10))
  93   (wrap-to-fill-set-values-in-buffer-windows))
  94
  95 (defun wrap-to-fill-normal ()
  96   "Reset `fill-column' to global value."
  97   (interactive)
  98   ;;(setq fill-column (default-value 'fill-column))
  99   (kill-local-variable 'fill-column)
 100   (wrap-to-fill-set-values-in-buffer-windows))
 101
 102 (defvar wrap-to-fill-column-mode-map
 103   (let ((map (make-sparse-keymap)))
 104     (define-key map [(control ?c) ?+] 'wrap-to-fill-wider)
 105     (define-key map [(control ?c) ?-] 'wrap-to-fill-narrower)
 106     (define-key map [(control ?c) ?0] 'wrap-to-fill-normal)
 107     map))
 108
 109 ;; Fix-me: Maybe make the `wrap-prefix' behavior an option or separate
 110 ;; minor mode.
 111
 112 ;; Fix-me: better handling of left-column in mumamo buffers (and other
 113 ;; if possible).
 114
 115 ;;;###autoload
 116 (define-minor-mode wrap-to-fill-column-mode
 117   "Use `fill-column' display columns in buffer windows.
 118 By default the display columns are centered, but see the option
 119 `wrap-to-fill-left-marg'.
 120
 121 Fix-me:
 122 Note 1: When turning this on `visual-line-mode' is also turned on. This
 123 is not reset when turning off this mode.
 124
 125 Note 2: The text properties 'wrap-prefix and 'wrap-to-fill-prefix
 126 is set by this mode to indent continuation lines.
 127
 128 Key bindings added by this minor mode:
 129
 130 \\{wrap-to-fill-column-mode-map}"
 131   :lighter " WrapFill"
 132   :group 'wrap-to-fill
 133   ;; (message "wrap-to-fill-column-mode %s, cb=%s, major=%s, multi=%s" wrap-to-fill-column-mode (current-buffer)
 134   ;;          major-mode mumamo-multi-major-mode)
 135   (if wrap-to-fill-column-mode
 136       (progn
 137         ;; Old values (idea from visual-line-mode)
 138         (set (make-local-variable 'wrap-to-fill--saved-state) nil)
 139         (dolist (var '(visual-line-mode
 140                        ;;left-margin-width
 141                        ;;right-margin-width
 142                        ))
 143           (push (list var (symbol-value var) (local-variable-p var))
 144                 wrap-to-fill--saved-state))
 145         ;; Hooks
 146         (add-hook 'window-configuration-change-hook 'wrap-to-fill-set-values nil t)
 147         ;; Wrapping
 148         (visual-line-mode 1)
 149         (wrap-to-fill-set-values-in-buffer-windows))
 150     ;; Hooks
 151     (remove-hook 'window-configuration-change-hook 'wrap-to-fill-set-values t)
 152     ;; Old values
 153     (dolist (saved wrap-to-fill--saved-state)
 154       (let ((var (nth 0 saved))
 155             (val (nth 1 saved))
 156             (loc (nth 2 saved)))
 157         (cond
 158          ((eq var 'visual-line-mode)
 159           (unless val (visual-line-mode -1)))
 160          (t
 161           (if loc
 162               (set (make-local-variable var) val)
 163             (kill-local-variable var))))))
 164     (kill-local-variable 'wrap-to-fill--saved-state)
 165     ;; Margins
 166     (dolist (win (get-buffer-window-list (current-buffer)))
 167       (set-window-margins win left-margin-width right-margin-width))
 168     ;; Indentation
 169     (let ((here (point))
 170           (inhibit-field-text-motion t)
 171           beg-pos
 172           end-pos)
 173       (mumamo-with-buffer-prepared-for-jit-lock
 174        (save-restriction
 175          (widen)
 176          (goto-char (point-min))
 177          (while (< (point) (point-max))
 178            (setq beg-pos (point))
 179            (setq end-pos (line-end-position))
 180            (when (equal (get-text-property beg-pos 'wrap-prefix)
 181                         (get-text-property beg-pos 'wrap-to-fill-prefix))
 182              (remove-list-of-text-properties
 183               beg-pos end-pos
 184               '(wrap-prefix)))
 185            (forward-line))
 186          (remove-list-of-text-properties
 187           (point-min) (point-max)
 188           '(wrap-to-fill-prefix)))
 189        (goto-char here))))
 190   (wrap-to-fill-font-lock wrap-to-fill-column-mode))
 191 (put 'wrap-to-fill-column-mode 'permanent-local t)
 192
 193 (defcustom wrap-to-fill-major-modes '(org-mode
 194                                       html-mode
 195                                       nxhtml-mode)
 196   "Major modes where to turn on `wrap-to-fill-column-mode'"
 197   ;;:type '(repeat major-mode)
 198   :type '(repeat command)
 199   :group 'wrap-to-fill)
 200
 201 (defun wrap-to-fill-turn-on-in-buffer ()
 202   "Turn on fun for globalization."
 203   (when (catch 'turn-on
 204           (dolist (m wrap-to-fill-major-modes)
 205             (when (derived-mode-p m)
 206               (throw 'turn-on t))))
 207     (wrap-to-fill-column-mode 1)))
 208
 209 (define-globalized-minor-mode wrap-to-fill-column-global-mode wrap-to-fill-column-mode
 210   wrap-to-fill-turn-on-in-buffer
 211   :group 'wrap-to-fill)
 212
 213 ;; Fix-me: There is a confusion between buffer and window margins
 214 ;; here. Also the doc says that left-margin-width and dito right may
 215 ;; be nil. However they seem to be 0 by default, but when displaying a
 216 ;; buffer in a window then window-margins returns (nil).
 217
 218 (defvar wrap-to-fill-timer nil)
 219 (make-variable-buffer-local 'wrap-to-fill-timer)
 220
 221 (defun wrap-to-fill-set-values ()
 222   (when (timerp wrap-to-fill-timer)
 223     (cancel-timer wrap-to-fill-timer))
 224   (setq wrap-to-fill-timer
 225         (run-with-idle-timer 0 nil 'wrap-to-fill-set-values-in-timer
 226                              (selected-window) (current-buffer))))
 227 (put 'wrap-to-fill-set-values 'permanent-local-hook t)
 228
 229 (defun wrap-to-fill-set-values-in-timer (win buf)
 230   (condition-case err
 231       (when (buffer-live-p buf)
 232         (wrap-to-fill-set-values-in-buffer-windows buf))
 233     (error (message "ERROR wrap-to-fill-set-values-in-timer: %s"
 234                     (error-message-string err)))))
 235
 236 (defun wrap-to-fill-set-values-in-timer-old (win buf)
 237   (when (and (window-live-p win) (buffer-live-p buf)
 238              (eq buf (window-buffer win)))
 239     (condition-case err
 240         (with-current-buffer buf
 241           (when wrap-to-fill-column-mode
 242             (wrap-to-fill-set-values-in-window win)))
 243       (error (message "ERROR wrap-to-fill-set-values: %s"
 244                       (error-message-string err))))))
 245
 246 (defun wrap-to-fill-set-values-in-buffer-windows (&optional buffer)
 247   "Use `fill-column' display columns in buffer windows."
 248   (let ((buf-windows (get-buffer-window-list (or buffer
 249                                                  (current-buffer))
 250                                              nil
 251                                              t)))
 252     (dolist (win buf-windows)
 253       (if wrap-to-fill-column-mode
 254           (wrap-to-fill-set-values-in-window win)
 255         (set-window-buffer nil (current-buffer))))))
 256
 257 (defvar wrap-old-win-width nil)
 258 (make-variable-buffer-local 'wrap-old-win-width)
 259 ;; Fix-me: compensate for left-margin-width etc
 260 (defun wrap-to-fill-set-values-in-window (win)
 261   (with-current-buffer (window-buffer win)
 262     (when wrap-to-fill-column-mode
 263       (let* ((win-width (window-width win))
 264              (win-margs (window-margins win))
 265              (win-full (+ win-width
 266                           (or (car win-margs) 0)
 267                           (or (cdr win-margs) 0)))
 268              (extra-width (- win-full fill-column))
 269              (fill-left-marg (unless (memq major-mode wrap-to-fill-left-marg-modes)
 270                                (or (when (> left-margin-width 0) left-margin-width)
 271                                    wrap-to-fill-left-marg)))
 272              (left-marg (if fill-left-marg
 273                             fill-left-marg
 274                           (- (/ extra-width 2) 1)))
 275              ;; Fix-me: Why do I have to subtract 1 here...???
 276              (right-marg (- win-full fill-column left-marg 1))
 277              (need-update nil)
 278              )
 279         ;; (when wrap-old-win-width
 280         ;;   (unless (= wrap-old-win-width win-width)
 281         ;;     (message "-")
 282         ;;     (message "win-width 0: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-marg right-marg (window-edges) (window-inside-edges) (window-margins))
 283         ;;    ))
 284         (setq wrap-old-win-width win-width)
 285         (unless (> left-marg 0) (setq left-marg 0))
 286         (unless (> right-marg 0) (setq right-marg 0))
 287         (unless nil;(= left-marg (or left-margin-width 0))
 288           ;;(setq left-margin-width left-marg)
 289           (setq need-update t))
 290         (unless nil;(= right-marg (or right-margin-width 0))
 291           ;;(setq right-margin-width right-marg)
 292           (setq need-update t))
 293         ;;(message "win-width a: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-margin-width right-margin-width (window-edges) (window-inside-edges) (window-margins))
 294         (when need-update
 295           ;;(set-window-buffer win (window-buffer win))
 296           ;;(run-with-idle-timer 0 nil 'set-window-buffer win (window-buffer win))
 297           ;;(dolist (win (get-buffer-window-list (current-buffer)))
 298             ;; Fix-me: check window width...
 299           (set-window-margins win left-marg right-marg)
 300           ;;)
 301           ;;(message "win-width b: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-marg right-marg (window-edges) (window-inside-edges) (window-margins))
 302           )
 303         ))))
 304
 305 ;; (add-hook 'post-command-hook 'my-win-post-command nil t)
 306 ;; (remove-hook 'post-command-hook 'my-win-post-command t)
 307 (defun my-win-post-command ()
 308   (message "win-post-command: l/r=%s/%s %S %S %S" left-margin-width right-margin-width (window-edges) (window-inside-edges) (window-margins))
 309            )
 310
 311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 312 ;;; Font lock
 313
 314 (defun wrap-to-fill-fontify (bound)
 315   (save-restriction
 316     (widen)
 317     (while (< (point) bound)
 318       (let ((this-bol (if (bolp) (point)
 319                         (1+ (line-end-position)))))
 320         (unless (< this-bol bound) (setq this-bol nil))
 321         (when this-bol
 322           (goto-char (+ this-bol 0))
 323           (let (ind-str
 324                 ind-str-fill
 325                 (beg-pos this-bol)
 326                 (end-pos (line-end-position)))
 327             (when (equal (get-text-property beg-pos 'wrap-prefix)
 328                          (get-text-property beg-pos 'wrap-to-fill-prefix))
 329               ;; Find indentation
 330               (skip-chars-forward "[:blank:]")
 331               (setq ind-str (buffer-substring-no-properties beg-pos (point)))
 332               ;; Any special markers like -, * etc
 333               (if (and (< (1+ (point)) (point-max))
 334                        (memq (char-after) '(?- ;; 45
 335                                             ?– ;; 8211
 336                                             ?*
 337                                             ))
 338                        (eq (char-after (1+ (point))) ?\ ))
 339                   (setq ind-str-fill (concat "  " ind-str))
 340                 (setq ind-str-fill ind-str))
 341               ;;(setq ind-str-fill (concat "  " ind-str))
 342               (mumamo-with-buffer-prepared-for-jit-lock
 343                (put-text-property beg-pos end-pos 'wrap-prefix ind-str-fill)
 344                (put-text-property beg-pos end-pos 'wrap-to-fill-prefix ind-str-fill))))))
 345       (forward-line 1))
 346     ;; Note: doing it line by line and returning t gave problem in mumamo.
 347     (when nil ;this-bol
 348       (set-match-data (list (point) (point)))
 349       t)))
 350
 351 (defun wrap-to-fill-font-lock (on)
 352   ;; See mlinks.el
 353   (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
 354          (fontify-fun 'wrap-to-fill-fontify)
 355          (args (list nil `(( ,fontify-fun ( 0 'font-lock-warning-face t ))))))
 356     (when fontify-fun
 357       (when on (setq args (append args (list t))))
 358       (apply add-or-remove args)
 359       (font-lock-mode -1)
 360       (font-lock-mode 1))))
 361
 362 (provide 'wrap-to-fill)
 363 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 364 ;;; wrap-to-fill.el ends here