SiteMap Search ElispArea HowTo Glossary RecentChanges News Problems Suggestions
Eritrea, Independence Day

fill-column-indicator-legacy.el

Last edit

Summary: Code for the legacy version of fill-column-indicator.

No diff available.

Download

;;; fill-column-indicator-legacy.el --- graphically indicate the fill column

;; Copyright (c) 2011 Alp Aker 

;; Author: Alp Aker <aker@pitt.edu>
;; Version: 0.42
;; Keywords: convenience

;; 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 2 of the
;; License, 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 the
;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
;; MA 02111-1307 USA

;;; Commentary:

;; Many modern editors and IDEs can graphically indicate the location of the
;; fill column, either by shading the area to the right of the fill column or
;; by drawing a thin line (in design parlance, a `rule') down the length of
;; the editing window.  Fill-column-indicator implements both of these
;; facilities in Emacs. 

;; Installation
;; ============

;; Put this file in your load path and put 
;; 
;;   (require 'fill-column-indicator)
;;
;; in your .emacs.  

;; Usage
;; =====

;; To toggle graphical indication of the fill column in a buffer, use the
;; command `fci-mode'.

;; Fill-column-indicator has two modes of operation:

;; o In shading mode, it shades the portion of the window to the right of the
;;   fill column.  This is the default.

;; o In rule mode, it draws a thin line at the fill column.

;; The mode of operation is controlled by the variable `fci-style'; the
;; recognized values are 'shading and 'rule.  If you'd like fci-mode to use a
;; rule by default, put
;;
;;   (setq fci-style 'rule) 
;;
;; in your .emacs.  (Buffer-local values of fci-style are supported.)

;; Configuration:  Shading Style
;; =============================

;; The appearance of the shading is controlled by the face `fci-shading'; its
;; attributes can be set like those of any face.

;; Configuration:  Rule Style
;; ==========================

;; On window systems the rule is drawn using an image generated by fci-mode;
;; the rule's width (in pixels) is determined by the variable
;; `fci-rule-width'.  On character terminals the rule is drawn using the
;; character specified by `fci-rule-character'.  In both cases the color is
;; controlled by `fci-rule-color'.  If you'd like the rule to be drawn using
;; fci-rule-character even on graphical displays, set
;; `fci-always-use-textual-rule' to a non-nil value.

;; The image formats used by fci-mode are XPM, PBM, and XBM.  By default, it
;; tries to use use them in that order.  You can specify a particular format
;; by setting `fci-rule-image-format' to either 'xpm, 'xpm, or 'xbm.

;; Other Options
;; =============

;; When `truncate-lines' is nil, the effect of drawing a fill-column
;; indicator is very odd looking. Indeed, in a window with continuation
;; lines, it makes little sense to indicate the position of the fill column
;; relative to the window edge (think about what it would mean to talk about
;; "the" location of the fill column in that case).  For this reason,
;; fci-mode sets truncate-lines to t in buffers in which it is enabled and
;; restores it to its previous value when disabled.  You can turn off this
;; feature by setting `fci-handle-truncate-lines' to nil.

;; If `line-move-visual' is t, then vertical navigation can behave oddly in
;; several edge cases while fci-mode is enabled (I think this is due to a bug
;; in pos_visible_p).  Accordingly, fci-mode locally sets line-move-visual to
;; nil when enabled and restores it when disabled.  This can be suppressed by
;; setting `fci-handle-line-move-visual' to nil.  (But you shouldn't want to
;; do this.  There's no reason to use line-move-visual if truncate-lines is
;; t, and it doesn't make sense to use something like fci-mode when
;; truncate-lines is nil.)

;; Troubleshooting
;; ===============

;; o If the fill-column indication is misaligned on some lines but otherwise
;;   looks normal, then you're most likely not displaying the buffer contents
;;   with a monospaced font.  Check whether the lines in question contain
;;   non-ascii characters that are wider or shorter than the normal character
;;   width.  Also, be aware that certain font-lock themes set some faces so
;;   that they look monospaced but aren't quite so.

;; o If the rule appears as a dashed (rather than uninterrupted) line on
;;   window systems, try changing the image format. (See the above section on
;;   configuring the rule style indicator.)

;; o If the terminal type does not support at least inverse video, then
;;   shading is impossible, and you should set fci-style to 'rule.

;; o Although the XBM format is natively supported by Emacs, the
;;   implementation on some ports is incomplete; the v23 and v24 Mac OS X
;;   ports are examples.  On these systems XBM images are always drawn in the
;;   foreground color of the frame's default face, in which case one cannot
;;   control the color of the rule.  Use XPM or PBM images instead.

;; Known Issues
;; ============

;; o The indicator extends only to end of the buffer contents (as opposed to
;;   running the full length of the editing window).

;; o If the buffer contents do not end in a newline, then the indicator
;;   extends only to the penultimate line.

;; o When using shading style on a character terminal, lines that fall one
;;   character short of the window border show the frame background color in
;;   the last column instead of shading.  (This appears to be an artifact of
;;   the mechanism that displays truncation and line continuation glyphs; I
;;   don't know how to fix it from within Lisp.)

;; Todo
;; ====

;; o Play well with outline mode, outline minor mode, and other forms of
;;   folding (nxml-outln, elide-head, etc.).

;;; Code:

(unless (< 21 emacs-major-version)
  (error "Fill-column-indicator requires version 22 or later"))

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

;;; ---------------------------------------------------------------------
;;; User Options
;;; ---------------------------------------------------------------------

(defgroup fill-column-indicator nil
 "Graphically indicate the fill-column."
 :tag "Fill-Column Indicator"
 :group 'convenience
 :group 'fill)

(defcustom fci-style 'shading
  "How fci-mode should indicate the fill-column.
If `shading', each line will be shaded past the fill column.  If
`rule', a thin rule (line) will be drawn at the fill column.

Changes to this variable do not take effect until the mode
function `fci-mode' is run."
  :tag "Fill-Column Style"
  :group 'fill-column-indicator
  :type '(choice (symbol :tag "Shading" 'shading)
                 (symbol :tag "Rule (a line)" 'rule)))

(defface fci-shading
  '((((class grayscale) (background light)) (:background "gray80"))
    (((class grayscale) (background dark)) (:background "gray50"))
    (((class color) (min-colors 88) (background light)) (:background "gray80"))
    (((class color) (min-colors 88) (background dark)) (:background "gray50"))
    (((class color) (min-colors 16)) (:background "lightgray"))
    (((class color) (min-colors 8)) (:background "yellow"))
    (t (:inverse-video t)))
 "Face used by fci-mode to color the area past the fill column."
 :group 'fill-column-indicator
 :tag "Fill-column shading color")

;; Sharp quoting the anonymous function here causes an error; that should be
;; considered a bug in the widget library.  Also, we should really be using
;; :validate instead of :match, but that seems not to work with defcustom
;; widgets.
(defcustom fci-rule-width 1
  "Width, in pixels, of the fill-column rule on graphical displays.
The value must be less than the default character width of the selected frame.

Changes to this variable do not take effect until the mode
function `fci-mode' is run."
  :tag "Fill-Column Rule Width"
  :group 'fill-column-indicator
  :type  '(integer :match (lambda (w val) (<= val (frame-char-width)))))

(defcustom fci-rule-color nil
 "Color used to indicate the fill-column with a rule.
If nil, fill-column-indicator tries to make a sensible choice.

Changes to this variable do not take effect until the mode
function `fci-mode' is run."
 :group 'fill-column-indicator
 :tag "Fill-column rule color"
 :type '(choice (const :tag "Let fci-mode choose" nil)
                (color :tag "Specify a color")))

(defcustom fci-rule-image-format 
  (let ((formats (delq nil 
                       (mapcar #'(lambda (x) (if (image-type-available-p x) x))
                               image-types))))
    ;; The xbm and pbm types should always be available, so this should never
    ;; evaluate to nil.
    (cond
     ((memq 'xpm formats) 'xpm)
     ((memq 'pbm formats) 'pbm)
     ((memq 'xbm formats) 'xbm)))
  "Image format fci-mode uses for the fill-column rule on graphical displays.
See the comments in the package file for more information on the
choice of format."
  :tag "Fill-Column Rule Image Format"
  :group 'fill-column-indicator
  :type '(choice (symbol :tag "XPM" 'xpm)
                 (symbol :tag "PBM" 'pbm)
                 (symbol :tag "XBM" 'xbm)))

(defcustom fci-rule-character ?|
  "Character fci-mode uses on non-graphical displays.
This is also used when the chosen image format isn't supported."
  :tag "Fill-Column Rule Character"
  :group 'fill-column-indicator
  :type 'character)

(defcustom fci-always-use-textual-rule nil
  "If non-nil, fci-mode will draw the rule using characters instead of images.
Specifically, it will use `fci-rule-character' to draw the rule,
even on graphical displays."
  :tag "Don't Use Image for Fill-Column Rule"
  :group 'fill-column-indicator
  :type 'boolean)

(defcustom fci-handle-line-move-visual (< 22 emacs-major-version)
 "Whether fci-mode should set line-move-visual to nil while enabled.
If non-nil, fci-mode will set line-move-visual to nil in buffers in which it 
is enabled, and restore t to its previous value when disabled. 

Leaving this option set to the default value is recommended."
 :group 'fill-column-indicator
 :tag "Locally set line-move-visual to nil during fci-mode"
 :type 'boolean)

(defcustom fci-handle-truncate-lines t
 "Whether fci-mode should set truncate-lines to t while enabled.
If non-nil, fci-mode will set truncate-lines to t in buffers in which it  
is enabled, and restore it to its previous value when disabled. 

Leaving this option set to the default value is recommended."
 :group 'fill-column-indicator
 :tag "Locally set truncate-lines to t during fci-mode"
 :type 'boolean)

;;; ---------------------------------------------------------------------
;;; Internal Variables
;;; ---------------------------------------------------------------------

;; Records whether we already did initial set-up in this buffer.
(defvar fci-buffer-initialized nil)

;; Stores the value of fill-column for our use.  (Some progmodes let-bind it
;; during their filling routines, so we need to store the value.)
(defvar fci-column nil)

;; Used by fci-after-change-function to call the right redrawing function
;; (shading or rule).  Set when fci-mode is called.
(defvar fci-put-overlays-function nil)

;; Stores the rule image/propertized rule character for use by the drawing
;; function. Set when fci-mode is called.
(defvar fci-rule nil)

;; When we add padding to a line to make the fill-column indicator appear at
;; the right place, this is the start of the padding. 
(defconst fci-cursor-space (propertize " " 'cursor t))

;; Combined padding and rule for lines that end right at the fill column.
(defvar fci-cursor-rule nil)

;; Records whether fci-mode created a new buffer-display-table.
(defvar fci-made-display-table nil)

;; Records any truncation glyph we might need to restore.
(defvar fci-prior-truncation-glyph nil)

;; If we nix line-move-visual in a buffer, we save its prior state here.
(defvar fci-saved-line-move-visual nil)

;; If we turn on truncate-lines in a buffer, we save its prior state here.
(defvar fci-saved-truncate-lines nil)

(defvar fci-pre-string "")

(defvar fci-pre-string-length 0)

;; Make certain internal variables buffer local. 
(let ((vars '(fci-buffer-initialized
              fci-column
              fci-rule
              fci-put-overlays-function
              fci-cursor-rule
              fci-pre-string
              fci-pre-string-length
              fci-made-display-table
              fci-prior-truncation-glyph
              fci-saved-line-move-visual
              fci-saved-truncate-lines)))
  (dolist (var vars)
    (make-variable-buffer-local var)))

(defconst fci-advised-functions '(set-fill-column
                                  whitespace-display-char-on
                                  whitespace-display-char-off
                                  hl-line-highlight
                                  hl-line-unhighlight
                                  global-hl-line-highlight
                                  global-hl-line-unhighlight
                                  show-paren-function
                                  mic-paren-highlight))

(defconst fci-hook-assignments 
  `((after-change-functions . ,#'fci-after-change-function)
    (post-command-hook . ,#'fci-correct-for-hscroll)
    (change-major-mode-hook . ,#'(lambda () (fci-mode -1)))))

;;; ---------------------------------------------------------------------
;;; Mode Definition 
;;; ---------------------------------------------------------------------

(define-minor-mode fci-mode
  "Toggle fci mode on and off.
Fci-mode indicates the location of the fill column, either by
shading the area of the window past the fill column or by
drawing a thin line (a `rule') at the fill column.

With prefix ARG, turn fci-mode on if and only if ARG is positive.

The following options control the appearance of the fill-column
indicator: `fci-style', `fci-shading', `fci-rule-width',
`fci-rule-color', and `fci-rule-character'.  For further options,
see the Customization menu or the package file.  (See the latter
for tips on troubleshooting.)"

  nil nil nil

  (if fci-mode
      ;; Enabling
      (unwind-protect 
          (progn
            (setq fci-column fill-column)
            (cond 
             ((eq fci-style 'rule)
              (fci-initialize-rule))
             ((eq fci-style 'shading)
              (fci-initialize-shading))
             (t
              (error "Unrecognized value of `fci-style'")))
            (dolist (hook fci-hook-assignments)
              (add-hook (car hook) (cdr hook) nil t))
            (ad-enable-regexp "fill-column-indicator")
            (dolist (fn fci-advised-functions)
              (ad-activate fn t))
            ;; In case we were already in fci-mode and are resetting the
            ;; indicator, clear out any existing overlays.
            (when fci-buffer-initialized
              (fci-delete-overlays-buffer))
            (fci-initialize-local-vars)
            (fci-put-overlays-buffer))
        (fci-mode -1))

    ;; Disabling
    (setq fci-column nil)
    (when fci-prior-display-table
      (fci-restore-display-table))
    (ad-disable-regexp "fill-column-indicator")
    (dolist (fn fci-advised-functions)
      (ad-activate fn))
    (dolist (hook fci-hook-assignments)
      (remove-hook (car hook) (cdr hook) t))
    (fci-delete-overlays-buffer)
    (fci-restore-local-vars)))


;;; ---------------------------------------------------------------------
;;; Initialization
;;; ---------------------------------------------------------------------

(defun fci-initialize-rule ()
  (setq fci-put-overlays-function #'fci-put-overlays-rule
        fci-rule (fci-make-rule)
        fci-cursor-rule (propertize fci-rule 'cursor 1))
  (when fci-made-prior-display-table
    (fci-restore-display-table)))

(defun fci-initialize-shading ()
  (setq fci-put-overlays-function #'fci-put-overlays-shading)
  (fci-set-display-table))


;; The following three functions each create a string with a rule bitmap as
;; its display property.

(defun fci-make-xbm-rule (rule-width color str)
  (let* ((fcw (frame-char-width))
         ;; Pad image width out to next multiple of 8 (some ports don't like
         ;; xbm bitmaps with widths that aren't equal to 0 mod 8).
         (img-width (+ fcw (- 8 (% fcw 8))))
         (img-height (frame-char-height))
         (row-pixels (make-bool-vector img-width nil))
         (raster (make-vector img-height row-pixels))
         (left-margin (/ (- fcw rule-width) 2))
         (i 0))
    (while (< i rule-width)
      (aset row-pixels (+ i left-margin) t)
      (setq i (1+ i)))
    (propertize str 'display (list 'image 
                                    :type 'xbm :data raster :foreground color
                                    :mask 'heuristic :ascent 'center 
                                    :height img-height :width img-width))))

(defun fci-make-pbm-rule (rule-width color str)
  (let* ((img-height (frame-char-height))
         (img-height-str (number-to-string img-height))
         (img-width (frame-char-width))
         (img-width-str (number-to-string img-width))
         (margin (/ (- img-width rule-width) 2.0))
         (left (floor margin))
         (right (ceiling margin))
         (identifier "P1\n") 
         (dimens (concat img-width-str " " img-height-str "\n"))
         (left-pixels (mapconcat #'identity (make-list left "0") " "))
         (rule-pixels (mapconcat #'identity (make-list rule-width "1") " "))
         (right-pixels (mapconcat #'identity (make-list right "0") " "))
         (row-pixels (concat left-pixels " " rule-pixels " " right-pixels))
         (raster (mapconcat #'identity (make-list img-height row-pixels) "\n"))
         (data (concat identifier dimens raster)))
    (propertize str 'display (list 'image 
                                    :type 'pbm :data data :mask 'heuristic
                                    :foreground color :ascent 'center))))

(defun fci-make-xpm-rule (rule-width color str)
  (let* ((img-height  (frame-char-height))
         (img-height-str (number-to-string img-height))
         (img-width (frame-char-width))
         (img-width-str (number-to-string img-width))
         (margin (/ (- img-width rule-width) 2.0))
         (left (floor margin))
         (right (ceiling margin))
         (identifier "/* XPM */\nstatic char *rule[] = {\n")
         (dimens (concat "\"" img-width-str " " img-height-str " 2 1\",\n"))
         (color-spec (concat "\"1 c " color "\",\n \"0 c None\",\n"))
         (row-pixels (concat "\"" 
                             (make-string left ?0)
                             (make-string rule-width ?1)
                             (make-string right ?0)
                             "\",\n"))
         (raster (mapconcat #'identity (make-list img-height row-pixels) ""))
         (end "};")
         (data (concat identifier dimens color-spec raster end)))
    (propertize str 'display (list 'image 
                                    :type 'xpm :data data :ascent 'center))))

(defun fci-get-rule-color ()
  (if fci-rule-color
      ;; User specified a color.  Check that it's valid.
      (if (color-defined-p fci-rule-color)
          fci-rule-color
        (error "Value of `fci-rule-color' is not a recognized color"))
    ;; Otherwise, choose an appropriate color.  
    (let ((light-bg (eq (frame-parameter (selected-frame) 'background-mode) 'light))
          (grays (display-grayscale-p))
          (planes (display-planes))
          (colors (display-color-p)))
      (cond
       ((and light-bg grays)
        "gray50")
       ((and (not light-bg) grays)
        "gray80")
       ((and colors (> 3 planes))
        "lightgray")
       ((and colors (> 2 planes))
        "yellow")
       (light-bg
        "black")
       (t
        "white")))))

;; Check that rule character is valid.  If so, propertize it, making
;; sure it doesn't pick up weight or slant from font lock.
(defun fci-make-rule-string (color)
  (if (characterp fci-rule-character)
      (propertize (char-to-string fci-rule-character)
                  'face
                  `(:foreground ,color :weight normal :slant normal))
    (error "Value of `fci-rule-character' must be a character")))

(defun fci-make-rule ()
  (let* ((color (fci-get-rule-color))
         (rule-str (fci-make-rule-string color)))
    (cond
     ;; Use the textual rule.
     ((or (not (display-images-p))
          fci-always-use-textual-rule)
      rule-str)
     ;; Use the graphical rule in next three cases.  Note that when we
     ;; display the bitmap we use the textual rule character for the
     ;; underlying string so that our failure mode is more graceful in case
     ;; the image display fails.  In addition, this handles the case in which
     ;; someone running a daemon invokes the mode on a graphical display then
     ;; subsequently displays the buffer on a terminal.
     ((eq fci-rule-image-format 'xbm)
      (fci-make-xbm-rule fci-rule-width color rule-str))
     ((eq fci-rule-image-format 'pbm)
      (fci-make-pbm-rule fci-rule-width color rule-str))
     ((eq fci-rule-image-format 'xpm)
      (fci-make-xpm-rule fci-rule-width color rule-str))
     (t
      (error "Unrecognized value of `fci-rule-image-format'")))))

;;; ---------------------------------------------------------------------
;;; Core Drawing/Undrawing Functions
;;; ---------------------------------------------------------------------

(defun fci-delete-overlays-region (start end)
  (mapc #'(lambda (x) (if (eq (overlay-get x 'category) 'fci) 
                          (delete-overlay x)))
        (overlays-in start end)))

(defun fci-put-overlays-shading (start end) 
  (goto-char start)
  (let (o)
    (while (search-forward "\n" end t)
      (goto-char (match-beginning 0))
      (setq o (make-overlay (match-beginning 0) (match-end 0)))
      (overlay-put o 'face 'fci-shading)
      (overlay-put o 'category 'fci)
      (if (< (current-column) fci-column)
          (overlay-put o
                       'before-string
                       (concat fci-pre-string
                               (propertize " "
                                           'display (list 'space 
                                                          :width 
                                                          (- fci-column 
                                                             (current-column)
                                                             fci-pre-string-length))
                                           'cursor 1)))
        (move-to-column fci-column)
        (setq o (make-overlay (point) (match-beginning 0)))
        (overlay-put o 'category 'fci)
        (overlay-put o 'face 'fci-shading)
        (overlay-put o 'after-string fci-pre-string))
      (goto-char (match-end 0)))))

;; Profiling shows that using a `cond' form here is about twice as fast as
;; using nested `if-progn' constructs when the code isn't byte compiled.
(defun fci-put-overlays-rule (start end)
  (goto-char start)
  (let (o)
    (while (search-forward "\n" end t)
      (goto-char (match-beginning 0))
      (cond 
       ((< (current-column) fci-column)
        (setq o (make-overlay (match-beginning 0) (match-end 0)))
        (overlay-put o 'category 'fci)
        (overlay-put o 
                     'before-string
                     (concat 
                      (propertize " "
                                  'display (list 'space 
                                                 :width 
                                                 (- fci-column (current-column)))
                                  'cursor t)
                             fci-rule)))
       ((= (current-column) fci-column)
        (setq o (make-overlay (match-beginning 0) (match-end 0)))
        (overlay-put o 'category 'fci)
        (overlay-put o 'before-string fci-cursor-rule)))
      (goto-char (match-end 0)))))

;;; ---------------------------------------------------------------------
;;; Entry Points to Drawing/Undrawing
;;; ---------------------------------------------------------------------

(defmacro fci-sanitize-actions (&rest body)
  `(save-match-data
     (save-excursion
       (save-restriction
         (widen)
         ,@body))))

;; The main entry point.  This is put in after-change-functions and locally
;; redraws the indicator after each buffer change.  Note that we redraw an
;; extra preceding line.  Motivation: at the beginning of a line,
;; insert-before-markers will grab the end marker of the overlay on the
;; previous line, in which case we need to reset the previous line's overlay
;; as well.  Unconditionally redoing the previous line is the fastest way to
;; handle that case.  (Using a hook on the overlay is conceptually tidier
;; but incurs the overhead of multiple extra lisp function calls.)
(defun fci-after-change-function (start end unused)
  (fci-sanitize-actions
   ;; Make sure our bounds span at least whole lines.
   (goto-char start)
   (setq start (line-beginning-position 0))
   (goto-char end)
   (setq end (line-beginning-position 2))
   ;; Clear any existing overlays.
   (fci-delete-overlays-region start end)
   ;; Then set the fill-column indicator in that region.
   (funcall fci-put-overlays-function start end)))

(defun fci-put-overlays-buffer ()
  (overlay-recenter (point-max))
  (fci-sanitize-actions
   (funcall fci-put-overlays-function (point-min) (point-max))))

(defun fci-delete-overlays-buffer ()
   (save-restriction
     (widen)
     (fci-delete-overlays-region (point-min) (point-max))))

;; Automatically reset the rule after changes to fill-column.
(defadvice set-fill-column (after fill-column-indicator)
 (when (and ad-return-value
            fci-mode)
   (fci-mode 1)))

;;; ---------------------------------------------------------------------
;;; Workarounds 
;;; ---------------------------------------------------------------------

;;; Workaround for the fact that cursor overlay properties are ignored
;;; if the position they specify for the cursor is out of sight due to
;;; horizontal scrolling. 

(defun fci-correct-for-hscroll ()
  ;; We could get the same result by omitting the first conjunct of the `and'
  ;; form.  But `window-hscroll' is much cheaper than `current-column', and
  ;; the former will return 0 in the overwhelming majority of calls to this
  ;; function.  Inserting the extra test causes the function to bail quickly
  ;; most of the time, speeding up modal case performance without greatly
  ;; impairing performance in other cases (desirable since this is put in
  ;; post-command-hook.)
  (if (and (< 0 (window-hscroll))
           auto-hscroll-mode
           (<= (current-column) (window-hscroll)))
      ;; FIX ME:  Rather than setting hscroll to 0, this should reproduce the
      ;; relevant part of the auto-hscrolling algorithm.  Most people won't
      ;; notice the difference in behavior, though.
      (set-window-hscroll (selected-window) 0)))
 
;;; ---------------------------------------------------------------------
;;; Compatibility with whitespace-mode
;;; ---------------------------------------------------------------------

(defadvice whitespace-display-char-on (after fill-column-indicator)
  (fci-mode 1))

(defadvice whitespace-display-char-off (after fill-column-indicator)
  (setq fci-pre-string ""
        fci-pre-string-length 0)
  (fci-mode 1))

(defun fci-unset-whitespace-display-char ()
  (let* ((display-vector (aref buffer-display-table 10))
         (newline-glyphs (and display-vector
                              (delq 10 (append display-vector nil)))))
    (when newline-glyphs
      (aset buffer-display-table 10 
            (if whitespace-display-table
                (aref whitespace-display-table 10)))
      (setq fci-pre-string 
            (propertize (mapconcat #'(lambda (x) (char-to-string (glyph-char x)))
                                   newline-glyphs 
                                   "")
                        'face
                        whitespace-newline
                        'cursor
                        1)
            fci-pre-string-length (length fci-pre-string)))))

(defun fci-reset-whitespace-display-char ()
  (let* ((newline-chars (split-string fci-pre-string "" t))
         (newline-glyphs (mapcar #'(lambda (x) (make-glyph-code x whitespace-newline))
                                 (append newline-chars '(10))))
         (newline-display-vector (vconcat newline-glyphs)))
    (when buffer-display-table
      (aset buffer-display-table 10 newline-display-vector))))

;;; ---------------------------------------------------------------------
;;; Compatibility with Highlighting
;;; ---------------------------------------------------------------------

;; The problem:  We rely on overlay before-strings placed on newline
;; characters; that's how we insert padding at the end of lines so that the
;; fill-column indicator appears at the right column.  But the face
;; attributes of an overlay's before-string aren't merged with any face
;; attributes that come from other overlays, so we end up breaking any kind
;; of highlighting that spans newlines.  (There is an alternative mechanism
;; we could use that would avoid this problem, but it would only work for
;; shading style.)

;; So we advise functions that set overlays that highlight newline-spanning
;; regions.  The basic strategy is this:  When such an overlay OLAY is
;; placed, we remove ("cache") our each before-string in the region spanned
;; by OLAY, storing it as the property `fci-saved-str' on each respective
;; overlay.  We then also note that each overlay is "deferring" to OLAY,
;; adding OLAY to its `fci-deferring-to' property.  When OLAY is moved, we
;; removed it from the `fci-deferring-to' prop, and if there are no other
;; overlays we're deferring to at that place, we restore the
;; before-string.  (Profiling shows that caching and restoring the
;; before-strings is faster than deleting our overlays and regenerating
;; them.)

;; One twist:  Some packages (e.g., hl-line) use a highlighting OLAY that is
;; restricted to one window, even if the same buffer is displayed in
;; multiple windows.  To deal with such cases, we cache the before-string as
;; usual.  But we still want our highlighting to appear in other windows
;; displaying that buffer, so we create copies ("siblings") of the overlay
;; whose before-string is cached, and set them to appear only in those other
;; windows.  When OLAY is moved, we destroy the siblings and restore the
;; cached before-string.

;; Quiet the compiler.
(defvar fci-other-olay nil)

(defsubst fci-cache-string (o)
  (when (overlay-get o 'before-string)
    (overlay-put o 'fci-cached-str (overlay-get o 'before-string)) 
    (overlay-put o 'before-string nil)) 
  (overlay-put o 'fci-deferring-to (cons fci-other-olay (overlay-get o 'fci-deferring-to))))

(defsubst fci-restore-string (o) 
  (overlay-put o 'fci-deferring-to (delq fci-other-olay (overlay-get o 'fci-deferring-to)))
  (unless (or (overlay-get o 'fci-deferring-to)
              (overlay-get o 'before-string))
    (overlay-put o 'before-string (overlay-get o 'fci-cached-str))
    (overlay-put o 'fci-cached-str nil)))  
 
(defun fci-cache-string-make-sibs (o)
  (mapc #'(lambda (x) (overlay-put o 'fci-sibs (cons (copy-overlay o) (overlay-get o 'fci-sibs)))
                      (overlay-put (car (overlay-get o 'fci-sibs)) 'window x))
        (delq (selected-window) (get-buffer-window-list nil 'no-minibuf t)))
  (fci-cache-string o))

(defun fci-restore-string-delete-sibs (o)
  (mapc #'(lambda (x) (delete-overlay x)) (overlay-get o 'fci-sibs))
  (overlay-put o 'fci-sibs nil)
  (fci-restore-string o))

(defsubst fci-get-overlays-region (start end)
  (delq nil (mapcar #'(lambda (x) (if (eq (overlay-get x 'category) 'fci) x))
                    (overlays-in start end))))

(defsubst fci-cacher (cache-fn)
  (when (and fci-other-olay (overlay-start fci-other-olay)) 
    (mapc cache-fn (fci-get-overlays-region (overlay-start fci-other-olay) 
                                            (overlay-end fci-other-olay)))))

(defsubst fci-restorer (restore-fn)
  (when (and fci-other-olay (overlay-start fci-other-olay)) 
    (with-current-buffer (overlay-buffer fci-other-olay)
      (mapc restore-fn (fci-get-overlays-region (overlay-start fci-other-olay)
                                                  (overlay-end fci-other-olay))))))

(defsubst fci-cache-strings (fci-other-olay)
  (fci-cacher #'fci-cache-string))

(defsubst fci-cache-strings-make-sibs (fci-other-olay)
  (fci-cacher #'fci-cache-string-make-sibs))

(defsubst fci-restore-strings (fci-other-olay)
  (fci-restorer #'fci-restore-string))

(defsubst fci-restore-strings-delete-sibs (fci-other-olay)
  (fci-restorer #'fci-restore-string-delete-sibs))

(defadvice hl-line-highlight (around fill-column-indicator)
  (if hl-line-overlay
      (overlay-put hl-line-overlay 'priority 1))
  (if hl-line-sticky-flag
      (progn
        (fci-restore-strings hl-line-overlay)
        ad-do-it
        (fci-cache-strings hl-line-overlay))
    (fci-restore-strings-delete-sibs hl-line-overlay)
    ad-do-it
    (fci-cache-strings-make-sibs hl-line-overlay)))

(defadvice hl-line-unhighlight (before fill-column-indicator)
  (if hl-line-sticky-flag
      (fci-restore-strings hl-line-overlay)
    (fci-restore-strings-delete-sibs hl-line-overlay)))

(defadvice global-hl-line-highlight (around fill-column-indicator)
  (if global-hl-line-overlay
      (overlay-put global-hl-line-overlay 'priority 1))
  (fci-restore-strings-delete-sibs global-hl-line-overlay)
  ad-do-it
  (fci-cache-strings-make-sibs global-hl-line-overlay))

(defadvice global-hl-line-unhighlight (before fill-column-indicator)
  (fci-restore-strings-delete-sibs global-hl-line-overlay))

(defadvice show-paren-function (around fill-column-indicator)
  (if (eq show-paren-style 'parenthesis) 
      ad-do-it
    (fci-restore-strings show-paren-overlay)
    ad-do-it         
    (fci-cache-strings show-paren-overlay))) 

(defadvice mic-paren-highlight (around fill-column-indicator)
  (if paren-sexp-mode  
      (progn
        (fci-restore-strings (aref mic-paren-overlays 0))
        (fci-restore-strings (aref mic-paren-overlays 2))
        ad-do-it
        (fci-cache-strings (aref mic-paren-overlays 0))
        (fci-cache-strings (aref mic-paren-overlays 2)))
    ad-do-it))

(provide 'fill-column-indicator)

;;; fill-column-indicator.el ends here