Function: allout-decorate-item-guides

allout-decorate-item-guides is a byte-compiled function defined in allout-widgets.el.gz.

Signature

(allout-decorate-item-guides ITEM-WIDGET &optional PARENT-WIDGET HAS-SUCCESSOR)

Documentation

Add ITEM-WIDGET guide icon-prefix descender and connector text properties.

Optional arguments provide context for deriving the guides. In their absence, the current guide column flags are used.

Optional PARENT-WIDGET is the widget for the item's parent item.

Optional HAS-SUCCESSOR is true if the item is followed by a sibling.

We also hide the header-prefix string.

Guides are established according to the item-widget's :guide-column-flags, when different from :was-guide-column-flags. Changing that property and reapplying this method will rectify the glyphs.

Source Code

;; Defined in /usr/src/emacs/lisp/allout-widgets.el.gz
;;;_   > allout-decorate-item-guides (item-widget
;;;                                  &optional parent-widget has-successor)
(defun allout-decorate-item-guides (item-widget
                                    &optional parent-widget has-successor)
  "Add ITEM-WIDGET guide icon-prefix descender and connector text properties.

Optional arguments provide context for deriving the guides.
In their absence, the current guide column flags are used.

Optional PARENT-WIDGET is the widget for the item's parent item.

Optional HAS-SUCCESSOR is true if the item is followed by a sibling.

We also hide the header-prefix string.

Guides are established according to the item-widget's :guide-column-flags,
when different from :was-guide-column-flags.  Changing that property and
reapplying this method will rectify the glyphs."

  (when (not (widget-get item-widget :is-container))
    (let* ((depth (widget-get item-widget :depth))
           ;; (parent-depth (and parent-widget
           ;;                    (widget-get parent-widget :depth)))
           (parent-flags (and parent-widget
                              (widget-get parent-widget :guide-column-flags)))
           (parent-flags-depth (length parent-flags))
           (extender-length (- depth (+ parent-flags-depth 2)))
           (flags (or (and (> depth 1)
                           parent-widget
                           (widget-put item-widget :guide-column-flags
                                       (append (list has-successor)
                                               (if (< 0 extender-length)
                                                   (make-list extender-length
                                                              '-))
                                               parent-flags)))
                      (widget-get item-widget :guide-column-flags)))
           (was-flags (widget-get item-widget :was-guide-column-flags))
           (guides-start (widget-get item-widget :from))
           (guides-end (widget-get item-widget :icon-start))
           (position guides-start)
           (increment (length allout-header-prefix))
           reverse-flags
           guide-name
           extenders
           (inhibit-read-only t))

      (when (not (equal was-flags flags))

        (setq reverse-flags (reverse flags))
        (while reverse-flags
          (setq guide-name
                (cond ((null (cdr reverse-flags))
                       (if (car reverse-flags)
                           'mid-connector
                         'end-connector))
                      ((eq (car reverse-flags) '-)
                       ;; accumulate extenders tally, to be painted on next
                       ;; non-extender flag, according to the flag type.
                       (setq extenders (1+ (or extenders 0)))
                       nil)
                      ((car reverse-flags)
                       'through-descender)
                      (t 'skip-descender)))
          (when guide-name
            (put-text-property position (setq position (+ position increment))
                               'display (allout-fetch-icon-image guide-name))
            (if (> increment 1) (setq increment 1))
            (when extenders
              ;; paint extenders after a connector, else leave spaces.
              (dotimes (_ extenders)
                (put-text-property
                 position (setq position (1+ position))
                 'display (allout-fetch-icon-image
                           (if (memq guide-name '(mid-connector end-connector))
                               'extender-connector
                             'skip-descender))))
              (setq extenders nil)))
          (setq reverse-flags (cdr reverse-flags)))
        (widget-put item-widget :was-guide-column-flags flags))

      (allout-item-element-span-is item-widget :guides-span
                                guides-start guides-end))))