;; allout-widgets.el --- Visually highlight allout outline structure.
-;; Copyright (C) 2005-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2014 Free Software Foundation, Inc.
;; Author: Ken Manheimer <ken dot manheimer at gmail...>
;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...>
;;;_ : USER CUSTOMIZATION VARIABLES and incidental functions:
;;;_ > defgroup allout-widgets
-;;;###autoload
(defgroup allout-widgets nil
"Allout extension that highlights outline structure graphically.
(defvar allout-widgets-tally nil
"Hash-table of existing allout widgets, for debugging.
-Table is maintained iff `allout-widgets-maintain-tally' is non-nil.
+Table is maintained only if `allout-widgets-maintain-tally' is non-nil.
The table contents will be out of sync if any widgets are created
or deleted while this variable is nil.")
"If non-nil, show cursor position of each item decoration.
This is for debugging purposes, and generally set at need in a
-buffer rather than as a prevailing configuration \(but it's handy
-to publicize it by making it a customization variable\)."
+buffer rather than as a prevailing configuration (but it's handy
+to publicize it by making it a customization variable)."
:version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
"Cache allout icon images, as an association list.
`allout-fetch-icon-image' uses this cache transparently, keying
-images with lists containing the name of the icon directory \(as
+images with lists containing the name of the icon directory (as
found on the `load-path') and the icon name.
Set this variable to `nil' to empty the cache, and have it replenish from the
- encryption '~'
- numbering '#'
- indirect reference '@'
- - distinctive bullets - see `allout-distinctive-bullets-string'.\)")
+ - distinctive bullets - see `allout-distinctive-bullets-string'.)")
;;;_ = allout-span-to-category
(defvar allout-span-to-category
'((:guides-span . allout-guides-span-category)
The bullet-icon and guide line graphics provide keybindings and mouse
bindings for easy outline navigation and exposure control, extending
-outline hot-spot navigation \(see `allout-mode')."
+outline hot-spot navigation (see `allout-mode')."
:lighter nil
:keymap nil
(set-buffer-modified-p was-modified))))
;;;_ > allout-widgets-mode-off
(defun allout-widgets-mode-off ()
- "Explicitly disable allout-widgets-mode."
+ "Explicitly disable `allout-widgets-mode'."
(allout-widgets-mode -1))
;;;_ > allout-widgets-mode-off
(defun allout-widgets-mode-on ()
- "Explicitly disable allout-widgets-mode."
+ "Explicitly enable `allout-widgets-mode'."
(allout-widgets-mode 1))
;;;_ > allout-setup-text-properties ()
(defun allout-setup-text-properties ()
(defvar allout-container-item-widget nil
"A widget for the current outline's overarching container as an item.
-The item has settings \(of the file/connection\) and maybe a body, but no
+The item has settings (of the file/connection) and maybe a body, but no
icon/bullet.")
(make-variable-buffer-local 'allout-container-item-widget)
;;;_ . Hooks and hook helpers
;;;_ , major command-loop business:
;;;_ > allout-widgets-pre-command-business (&optional recursing)
-(defun allout-widgets-pre-command-business (&optional recursing)
- "Handle actions pending before allout-mode activity."
+(defun allout-widgets-pre-command-business (&optional _recursing)
+ "Handle actions pending before `allout-mode' activity."
)
;;;_ > allout-widgets-post-command-business (&optional recursing)
-(defun allout-widgets-post-command-business (&optional recursing)
- "Handle actions pending after any allout-mode commands.
+(defun allout-widgets-post-command-business (&optional _recursing)
+ "Handle actions pending after any `allout-mode' commands.
Optional RECURSING is for internal use, to limit recursion."
;; - check changed text for nesting discontinuities and escape anything
;; that's: (1) asterisks at bol or (2) excessively nested.
- (condition-case failure
+ (condition-case nil
(when (and (boundp 'allout-mode) allout-mode)
(goto-char (widget-get this-widget :from))
(not (bolp)))
(if (not
- (condition-case err
+ (condition-case nil
(yes-or-no-p
(concat "Misplaced item won't be recognizable "
" as part of outline - rectify? "))
(error
(substitute-command-keys allout-structure-unruly-deletion-message)))))
;;;_ > allout-widgets-after-change-handler
-(defun allout-widgets-after-change-handler (beg end prelength)
+(defun allout-widgets-after-change-handler (_beg _end _prelength)
"Reconcile what needs to be reconciled for allout widgets after edits."
)
;;;_ > allout-current-decorated-p ()
;; have to distinguish between concealing and exposing so that, eg,
;; `allout-expose-topic's mix is handled properly.
handled-expose
- handled-conceal
covered
deactivate-mark)
(defun allout-widgets-after-copy-or-kill-function ()
"Do allout-widgets processing of text just placed in the kill ring.
-Intended for use on allout-after-copy-or-kill-hook."
+Intended for use on `allout-after-copy-or-kill-hook'."
(if (car kill-ring)
(setcar kill-ring (allout-widgets-undecorate-text (car kill-ring)))))
;;;_ > allout-widgets-after-undo-function ()
(defun allout-widgets-after-undo-function ()
"Do allout-widgets processing of text after an undo.
-Intended for use on allout-post-undo-hook."
+Intended for use on `allout-post-undo-hook'."
(save-excursion
(if (allout-goto-prefix)
(allout-redecorate-item (allout-get-or-create-item-widget)))))
(let* ((allout-undo-exposure-in-progress t)
;; inhibit undo recording while twiddling exposure to track undo:
(widgets allout-widgets-undo-exposure-record)
- widget widget-start-marker widget-end-marker
+ widget-start-marker widget-end-marker
from-state icon-start-point to-state
handled covered)
(setq allout-widgets-undo-exposure-record nil)
(list (if included-from t) new-ranges)))
;;;_ > allout-test-range-overlaps ()
(defun allout-test-range-overlaps ()
- "allout-range-overlaps unit tests."
+ "`allout-range-overlaps' unit tests."
(let* (ranges
got
(try (lambda (from to)
;; (time-trial
;; '(let ((size 10000)
;; doing)
-;; (random t)
;; (dotimes (count size)
;; (setq doing (random size))
;; (funcall try doing (+ doing (random 5)))
;;;_ > allout-decorate-item-and-context (item-widget &optional redecorate
;;; blank-container parent)
(defun allout-decorate-item-and-context (item-widget &optional redecorate
- blank-container parent)
+ blank-container _parent)
"Create or adjust widget decorations for ITEM-WIDGET and neighbors at point.
The neighbors include its siblings and parent.
-ITEM-WIDGET can be a created or converted allout-item-widget.
+ITEM-WIDGET can be a created or converted `allout-item-widget'.
If you're only trying to get or create a widget for an item, use
`allout-get-or-create-item-widget'. If you have the item-widget, applying
Optional BLANK-CONTAINER is for internal use. It is used to fabricate a
container widget for an empty-bodied container, in the course of decorating
-a proper \(non-container\) item which starts at the beginning of the file.
+a proper (non-container) item which starts at the beginning of the file.
Optional REDECORATE causes redecoration of the item-widget and
its siblings, even if already decorated in this cycle of the command loop.
steady-point))
(parent (and (not is-container)
(allout-get-or-create-parent-widget)))
- parent-flags parent-depth
successor-sibling
- body
doing-item
- sub-item-widget
- depth
reverse-siblings-chart
(buffer-undo-list t))
;; `allout-goto-prefix' will go to first non-container item:
(allout-goto-prefix)
(allout-next-heading))
- (setq depth (allout-recent-depth))
(setq reverse-siblings-chart (list allout-recent-prefix-beginning))
(while (allout-next-sibling)
(push allout-recent-prefix-beginning reverse-siblings-chart)))
(pending-chart (or chart (allout-chart-subtree nil 'visible)))
item-widget
previous-sibling-point
- previous-sibling
recent-sibling-point)
(setq pending-chart (nreverse pending-chart))
(dolist (sibling-point pending-chart)
the item prefix.
If optional BLANK-CONTAINER is true, then the parameters of a container
-which has an empty body are set. \(Though the body is blank, the object
-may have subitems.\)"
+which has an empty body are set. (Though the body is blank, the object
+may have subitems.)"
;; Uncomment this sit-for to notice where decoration is happening:
;; (sit-for .1)
(icon-start (1- icon-end))
body-start
body-end
- bullet
has-subitems
- (contents-depth (1+ depth))
)
(widget-put item-widget :depth depth)
(if is-container
;; cue area:
(setq body-start icon-end)
- (widget-put item-widget :bullet (setq bullet (allout-get-bullet)))
+ (widget-put item-widget :bullet (allout-get-bullet))
(if (equal (char-after body-start) ? )
(setq body-start (1+ body-start)))
(widget-put item-widget :body-start body-start)
;; has a subsequent item:
(not (= body-end (point-max)))
;; subsequent item is deeper:
- (< depth (setq contents-depth (allout-recent-depth))))))
+ (< depth (allout-recent-depth)))))
;; note :expanded - true if widget item's content is currently visible?
(widget-put item-widget :expanded
(and has-subitems
(goto-char allout-recent-prefix-beginning)
(not (allout-hidden-p)))))))
;;;_ > allout-set-boundary-marker (boundary position &optional current-marker)
-(defun allout-set-boundary-marker (boundary position &optional current-marker)
+(defun allout-set-boundary-marker (_boundary position &optional current-marker)
"Set or create item widget BOUNDARY type marker at POSITION.
Optional CURRENT-MARKER is the marker currently being used for
&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 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 iff the item is followed by a sibling.
+Optional HAS-SUCCESSOR is true if the item is followed by a sibling.
We also hide the header-prefix string.
(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-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))
(increment (length allout-header-prefix))
reverse-flags
guide-name
- extenders paint-extenders
+ extenders
(inhibit-read-only t))
(when (not (equal was-flags flags))
(let* ((cue-start (or (widget-get item-widget :distinctive-end)
(widget-get item-widget :icon-end)))
(body-start (widget-get item-widget :body-start))
- (expanded (widget-get item-widget :expanded))
- (has-subitems (widget-get item-widget :has-subitems))
+ ;(expanded (widget-get item-widget :expanded))
+ ;(has-subitems (widget-get item-widget :has-subitems))
(inhibit-read-only t))
(allout-item-element-span-is item-widget :cue-span cue-start body-start)
(let* ((allout-inhibit-body-modification-hook t)
(body-start (widget-get item-widget :body-start))
(body-end (widget-get item-widget :body-end))
- (body-text-end body-end)
(inhibit-read-only t))
(allout-item-element-span-is item-widget :body-span
When the START and END are passed, return the distance that the
start of the item moved. We return 0 if the span was not
previously established or is not moved."
- (let ((overlay (widget-get item-widget :span-overlay))
- was-start was-end
- changed)
+ (let ((overlay (widget-get item-widget :span-overlay)))
(cond ((not overlay) (when start
(setq overlay (make-overlay start end nil t nil))
(overlay-put overlay 'button item-widget)
Optional BLANK-CONTAINER is for internal use, to fabricate a
meta-container item with an empty body when the first proper
-\(non-container\) item starts at the beginning of the file.
+\(non-container) item starts at the beginning of the file.
Optional REDECORATE, if non-nil, means to redecorate the widget
if it already exists."
of the buffer."
;; use existing widget, if there, else establish it
(if (or (bobp) (and (not (allout-ascend))
- (looking-at allout-regexp)))
+ (looking-at-p allout-regexp)))
(allout-get-or-create-item-widget redecorate 'blank-container)
(allout-get-or-create-item-widget redecorate)))
;;;_ : X- Item ancillaries
;;;_ >X allout-body-modification-handler (beg end)
-(defun allout-body-modification-handler (beg end)
+(defun allout-body-modification-handler (_beg _end)
"Do routine processing of body text before and after modification.
Operation is inhibited by `allout-inhibit-body-modification-handler'."
;; - removal and replacement of the settings
;; - maintenance of beginning-of-line guide lines
;;
-;; ?? Escapes removal \(before changes\) is not done when edits span multiple
+;; ?? Escapes removal (before changes) is not done when edits span multiple
;; items, recognizing that item structure is being preserved, including
;; escaping of item-prefix-like text within bodies. See
;; `allout-before-modification-handler' and
;; operation.
(cond (allout-inhibit-body-modification-hook nil)))
;;;_ >X allout-graphics-modification-handler (beg end)
-(defun allout-graphics-modification-handler (beg end)
+(defun allout-graphics-modification-handler (beg _end)
"Protect against incoherent deletion of decoration graphics.
-Deletes allowed only when inhibit-read-only is t."
+Deletes allowed only when `inhibit-read-only' is t."
(cond
(undo-in-progress (when (eq (get-text-property beg 'category)
'allout-icon-span-category)
HCoop / bpt / emacs.git / blobdiff