path: root/emacs.d/nxhtml/util/wrap-to-fill.el

;;; wrap-to-fill.el --- Make a fill-column wide space for editing
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Created: 2009-08-12 Wed
;; Version:
;; Last-Updated: x
;; URL:
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
;;   None
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 3, 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(eval-when-compile (require 'mumamo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Wrapping

;;;###autoload
(defgroup wrap-to-fill nil
  "Customizing of `wrap-to-fill-column-mode'."
  :group 'convenience)

;;;###autoload
(defcustom wrap-to-fill-left-marg nil
  "Left margin handling for `wrap-to-fill-column-mode'.
Used by `wrap-to-fill-column-mode'. If nil then center the
display columns. Otherwise it should be a number which will be
the left margin."
  :type '(choice (const :tag "Center" nil)
                 (integer :tag "Left margin"))
  :group 'wrap-to-fill)
(make-variable-buffer-local 'wrap-to-fill-left-marg)

(defvar wrap-to-fill--saved-state nil)
;;(make-variable-buffer-local 'wrap-to-fill--saved-state)
(put 'wrap-to-fill--saved-state 'permanent-local t)

;;;###autoload
(defcustom wrap-to-fill-left-marg-modes
  '(text-mode
    fundamental-mode)
  "Major modes where `wrap-to-fill-left-margin' may be nil."
  :type '(repeat command)
  :group 'wrap-to-fill)


         ;;ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord

(defun wrap-to-fill-wider ()
  "Increase `fill-column' with 10."
  (interactive)
  (setq fill-column (+ fill-column 10))
  (wrap-to-fill-set-values-in-buffer-windows))

(defun wrap-to-fill-narrower ()
  "Decrease `fill-column' with 10."
  (interactive)
  (setq fill-column (- fill-column 10))
  (wrap-to-fill-set-values-in-buffer-windows))

(defun wrap-to-fill-normal ()
  "Reset `fill-column' to global value."
  (interactive)
  ;;(setq fill-column (default-value 'fill-column))
  (kill-local-variable 'fill-column)
  (wrap-to-fill-set-values-in-buffer-windows))

(defvar wrap-to-fill-column-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [(control ?c) ?+] 'wrap-to-fill-wider)
    (define-key map [(control ?c) ?-] 'wrap-to-fill-narrower)
    (define-key map [(control ?c) ?0] 'wrap-to-fill-normal)
    map))

;; Fix-me: Maybe make the `wrap-prefix' behavior an option or separate
;; minor mode.

;; Fix-me: better handling of left-column in mumamo buffers (and other
;; if possible).

;;;###autoload
(define-minor-mode wrap-to-fill-column-mode
  "Use `fill-column' display columns in buffer windows.
By default the display columns are centered, but see the option
`wrap-to-fill-left-marg'.

Fix-me:
Note 1: When turning this on `visual-line-mode' is also turned on. This
is not reset when turning off this mode.

Note 2: The text properties 'wrap-prefix and 'wrap-to-fill-prefix
is set by this mode to indent continuation lines.

Key bindings added by this minor mode:

\\{wrap-to-fill-column-mode-map}"
  :lighter " WrapFill"
  :group 'wrap-to-fill
  ;; (message "wrap-to-fill-column-mode %s, cb=%s, major=%s, multi=%s" wrap-to-fill-column-mode (current-buffer)
  ;;          major-mode mumamo-multi-major-mode)
  (if wrap-to-fill-column-mode
      (progn
        ;; Old values (idea from visual-line-mode)
	(set (make-local-variable 'wrap-to-fill--saved-state) nil)
	(dolist (var '(visual-line-mode
                       ;;left-margin-width
                       ;;right-margin-width
                       ))
          (push (list var (symbol-value var) (local-variable-p var))
                wrap-to-fill--saved-state))
        ;; Hooks
        (add-hook 'window-configuration-change-hook 'wrap-to-fill-set-values nil t)
        ;; Wrapping
        (visual-line-mode 1)
        (wrap-to-fill-set-values-in-buffer-windows))
    ;; Hooks
    (remove-hook 'window-configuration-change-hook 'wrap-to-fill-set-values t)
    ;; Old values
    (dolist (saved wrap-to-fill--saved-state)
      (let ((var (nth 0 saved))
            (val (nth 1 saved))
            (loc (nth 2 saved)))
        (cond
         ((eq var 'visual-line-mode)
          (unless val (visual-line-mode -1)))
         (t
          (if loc
              (set (make-local-variable var) val)
            (kill-local-variable var))))))
    (kill-local-variable 'wrap-to-fill--saved-state)
    ;; Margins
    (dolist (win (get-buffer-window-list (current-buffer)))
      (set-window-margins win left-margin-width right-margin-width))
    ;; Indentation
    (let ((here (point))
          (inhibit-field-text-motion t)
          beg-pos
          end-pos)
      (mumamo-with-buffer-prepared-for-jit-lock
       (save-restriction
         (widen)
         (goto-char (point-min))
         (while (< (point) (point-max))
           (setq beg-pos (point))
           (setq end-pos (line-end-position))
           (when (equal (get-text-property beg-pos 'wrap-prefix)
                        (get-text-property beg-pos 'wrap-to-fill-prefix))
             (remove-list-of-text-properties
              beg-pos end-pos
              '(wrap-prefix)))
           (forward-line))
         (remove-list-of-text-properties
          (point-min) (point-max)
          '(wrap-to-fill-prefix)))
       (goto-char here))))
  (wrap-to-fill-font-lock wrap-to-fill-column-mode))
(put 'wrap-to-fill-column-mode 'permanent-local t)

(defcustom wrap-to-fill-major-modes '(org-mode
                                      html-mode
                                      nxhtml-mode)
  "Major modes where to turn on `wrap-to-fill-column-mode'"
  ;;:type '(repeat major-mode)
  :type '(repeat command)
  :group 'wrap-to-fill)

(defun wrap-to-fill-turn-on-in-buffer ()
  "Turn on fun for globalization."
  (when (catch 'turn-on
          (dolist (m wrap-to-fill-major-modes)
            (when (derived-mode-p m)
              (throw 'turn-on t))))
    (wrap-to-fill-column-mode 1)))

(define-globalized-minor-mode wrap-to-fill-column-global-mode wrap-to-fill-column-mode
  wrap-to-fill-turn-on-in-buffer
  :group 'wrap-to-fill)

;; Fix-me: There is a confusion between buffer and window margins
;; here. Also the doc says that left-margin-width and dito right may
;; be nil. However they seem to be 0 by default, but when displaying a
;; buffer in a window then window-margins returns (nil).

(defvar wrap-to-fill-timer nil)
(make-variable-buffer-local 'wrap-to-fill-timer)

(defun wrap-to-fill-set-values ()
  (when (timerp wrap-to-fill-timer)
    (cancel-timer wrap-to-fill-timer))
  (setq wrap-to-fill-timer
        (run-with-idle-timer 0 nil 'wrap-to-fill-set-values-in-timer
                             (selected-window) (current-buffer))))
(put 'wrap-to-fill-set-values 'permanent-local-hook t)

(defun wrap-to-fill-set-values-in-timer (win buf)
  (condition-case err
      (when (buffer-live-p buf)
        (wrap-to-fill-set-values-in-buffer-windows buf))
    (error (message "ERROR wrap-to-fill-set-values-in-timer: %s"
                    (error-message-string err)))))

(defun wrap-to-fill-set-values-in-timer-old (win buf)
  (when (and (window-live-p win) (buffer-live-p buf)
             (eq buf (window-buffer win)))
    (condition-case err
        (with-current-buffer buf
          (when wrap-to-fill-column-mode
            (wrap-to-fill-set-values-in-window win)))
      (error (message "ERROR wrap-to-fill-set-values: %s"
                      (error-message-string err))))))

(defun wrap-to-fill-set-values-in-buffer-windows (&optional buffer)
  "Use `fill-column' display columns in buffer windows."
  (let ((buf-windows (get-buffer-window-list (or buffer
                                                 (current-buffer))
                                             nil
                                             t)))
    (dolist (win buf-windows)
      (if wrap-to-fill-column-mode
          (wrap-to-fill-set-values-in-window win)
        (set-window-buffer nil (current-buffer))))))

(defvar wrap-old-win-width nil)
(make-variable-buffer-local 'wrap-old-win-width)
;; Fix-me: compensate for left-margin-width etc
(defun wrap-to-fill-set-values-in-window (win)
  (with-current-buffer (window-buffer win)
    (when wrap-to-fill-column-mode
      (let* ((win-width (window-width win))
             (win-margs (window-margins win))
             (win-full (+ win-width
                          (or (car win-margs) 0)
                          (or (cdr win-margs) 0)))
             (extra-width (- win-full fill-column))
             (fill-left-marg (unless (memq major-mode wrap-to-fill-left-marg-modes)
                               (or (when (> left-margin-width 0) left-margin-width)
                                   wrap-to-fill-left-marg)))
             (left-marg (if fill-left-marg
                            fill-left-marg
                          (- (/ extra-width 2) 1)))
             ;; Fix-me: Why do I have to subtract 1 here...???
             (right-marg (- win-full fill-column left-marg 1))
             (need-update nil)
             )
        ;; (when wrap-old-win-width
        ;;   (unless (= wrap-old-win-width win-width)
        ;;     (message "-")
        ;;     (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))
        ;;    ))
        (setq wrap-old-win-width win-width)
        (unless (> left-marg 0) (setq left-marg 0))
        (unless (> right-marg 0) (setq right-marg 0))
        (unless nil;(= left-marg (or left-margin-width 0))
          ;;(setq left-margin-width left-marg)
          (setq need-update t))
        (unless nil;(= right-marg (or right-margin-width 0))
          ;;(setq right-margin-width right-marg)
          (setq need-update t))
        ;;(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))
        (when need-update
          ;;(set-window-buffer win (window-buffer win))
          ;;(run-with-idle-timer 0 nil 'set-window-buffer win (window-buffer win))
          ;;(dolist (win (get-buffer-window-list (current-buffer)))
            ;; Fix-me: check window width...
          (set-window-margins win left-marg right-marg)
          ;;)
          ;;(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))
          )
        ))))

;; (add-hook 'post-command-hook 'my-win-post-command nil t)
;; (remove-hook 'post-command-hook 'my-win-post-command t)
(defun my-win-post-command ()
  (message "win-post-command: l/r=%s/%s %S %S %S" left-margin-width right-margin-width (window-edges) (window-inside-edges) (window-margins))
           )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Font lock

(defun wrap-to-fill-fontify (bound)
  (save-restriction
    (widen)
    (while (< (point) bound)
      (let ((this-bol (if (bolp) (point)
                        (1+ (line-end-position)))))
        (unless (< this-bol bound) (setq this-bol nil))
        (when this-bol
          (goto-char (+ this-bol 0))
          (let (ind-str
                ind-str-fill
                (beg-pos this-bol)
                (end-pos (line-end-position)))
            (when (equal (get-text-property beg-pos 'wrap-prefix)
                         (get-text-property beg-pos 'wrap-to-fill-prefix))
              ;; Find indentation
              (skip-chars-forward "[:blank:]")
              (setq ind-str (buffer-substring-no-properties beg-pos (point)))
              ;; Any special markers like -, * etc
              (if (and (< (1+ (point)) (point-max))
                       (memq (char-after) '(?- ;; 45
                                            ?– ;; 8211
                                            ?*
                                            ))
                       (eq (char-after (1+ (point))) ?\ ))
                  (setq ind-str-fill (concat "  " ind-str))
                (setq ind-str-fill ind-str))
              ;;(setq ind-str-fill (concat "  " ind-str))
              (mumamo-with-buffer-prepared-for-jit-lock
               (put-text-property beg-pos end-pos 'wrap-prefix ind-str-fill)
               (put-text-property beg-pos end-pos 'wrap-to-fill-prefix ind-str-fill))))))
      (forward-line 1))
    ;; Note: doing it line by line and returning t gave problem in mumamo.
    (when nil ;this-bol
      (set-match-data (list (point) (point)))
      t)))

(defun wrap-to-fill-font-lock (on)
  ;; See mlinks.el
  (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
         (fontify-fun 'wrap-to-fill-fontify)
         (args (list nil `(( ,fontify-fun ( 0 'font-lock-warning-face t ))))))
    (when fontify-fun
      (when on (setq args (append args (list t))))
      (apply add-or-remove args)
      (font-lock-mode -1)
      (font-lock-mode 1))))

(provide 'wrap-to-fill)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; wrap-to-fill.el ends here