-;; allout-widgets.el --- Show allout outline structure with graphical widgets.
+;; allout-widgets.el --- Visually highlight allout outline structure.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer
+;; Copyright (C) 2005-2012 Free Software Foundation, Inc.
-;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
-;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
+;; Author: Ken Manheimer <ken dot manheimer at gmail...>
+;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...>
;; Version: 1.0
;; Created: Dec 2005
-;; Version: 1.0
;; Keywords: outlines
-;; Website: http://myriadicity.net/Sundry/EmacsAllout
+;; Website: http://myriadicity.net/software-and-systems/craft/emacs-allout
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; systematically couple overlays, graphics, and other features with
;; allout-governed text.
-;;;_: Code (structured with comments that delinieate an allout outline)
+;;;_: Code (structured with comments that delineate an allout outline)
;;;_ : General Environment
(require 'allout)
;;;_ > allout-widgets-setup (varname value)
;;;###autoload
(defun allout-widgets-setup (varname value)
- "Commission or decommision allout-widgets-mode along with allout-mode.
+ "Commission or decommission allout-widgets-mode along with allout-mode.
Meant to be used by customization of `allout-widgets-auto-activation'."
(set-default varname value)
you want allout widgets operation.
See `allout-widgets-mode' for allout widgets mode features."
+ :version "24.1"
:type 'boolean
:group 'allout-widgets
:set 'allout-widgets-setup
)
;; ;;;_ = allout-widgets-allow-unruly-edits
;; (defcustom allout-widgets-allow-unruly-edits nil
-;; "*Control whether manual edits are restricted to maintain outline integrity.
+;; "Control whether manual edits are restricted to maintain outline integrity.
;; When nil, manual edits must either be within an item's body or encompass
;; one or more items completely - eg, killing topics as entities, rather than
;;;_ = allout-widgets-icons-dark-subdir
(defcustom allout-widgets-icons-dark-subdir "icons/allout-widgets/dark-bg/"
"Directory on `image-load-path' holding allout icons for dark backgrounds."
+ :version "24.1"
:type 'string
:group 'allout-widgets)
;;;_ = allout-widgets-icons-light-subdir
(defcustom allout-widgets-icons-light-subdir "icons/allout-widgets/light-bg/"
"Directory on `image-load-path' holding allout icons for light backgrounds."
+ :version "24.1"
:type 'string
:group 'allout-widgets)
;;;_ = allout-widgets-icon-types
(defcustom allout-widgets-icon-types '(xpm png)
"File extensions for the icon graphic format types, in order of preference."
+ :version "24.1"
:type '(repeat symbol)
:group 'allout-widgets)
;;;_ = allout-widgets-theme-dark-background
(defcustom allout-widgets-theme-dark-background "allout-dark-bg"
"Identify the outline's icon theme to use with a dark background."
+ :version "24.1"
:type '(string)
:group 'allout-widgets)
;;;_ = allout-widgets-theme-light-background
(defcustom allout-widgets-theme-light-background "allout-light-bg"
"Identify the outline's icon theme to use with a light background."
+ :version "24.1"
:type '(string)
:group 'allout-widgets)
;;;_ = allout-widgets-item-image-properties-emacs
(defcustom allout-widgets-item-image-properties-emacs
'(:ascent center :mask (heuristic t))
- "*Default properties item widget images in mainline Emacs."
+ "Default properties item widget images in mainline Emacs."
+ :version "24.1"
:type 'plist
:group 'allout-widgets)
;;;_ = allout-widgets-item-image-properties-xemacs
(defcustom allout-widgets-item-image-properties-xemacs
nil
- "*Default properties item widget images in XEmacs."
+ "Default properties item widget images in XEmacs."
+ :version "24.1"
:type 'plist
:group 'allout-widgets)
;;;_ . Developer
;;;_ = allout-widgets-run-unit-tests-on-load
(defcustom allout-widgets-run-unit-tests-on-load nil
- "*When non-nil, unit tests will be run at end of loading allout-widgets.
+ "When non-nil, unit tests will be run at end of loading allout-widgets.
Generally, allout widgets code developers are the only ones who'll want to
set this.
compilation.)
See `allout-widgets-run-unit-tests' to see what's run."
+ :version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
;;;_ = allout-widgets-time-decoration-activity
(defcustom allout-widgets-time-decoration-activity nil
- "*Retain timing info of the last cooperative redecoration.
+ "Retain timing info of the last cooperative redecoration.
The details are retained as the value of
`allout-widgets-last-decoration-timing'.
Generally, allout widgets code developers are the only ones who'll want to
set this."
+ :version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
;;;_ = allout-widgets-hook-error-post-time 0
(defcustom allout-widgets-hook-error-post-time 0
- "*Amount of time to sit showing hook error messages.
+ "Amount of time to sit showing hook error messages.
0 is minimal, or nil to not post to the message area.
This is for debugging purposes."
+ :version "24.1"
:type 'integer
:group 'allout-widgets-developer)
;;;_ = allout-widgets-maintain-tally nil
(defcustom allout-widgets-maintain-tally nil
- "*If non-nil, maintain a collection of widgets, `allout-widgets-tally'.
+ "If non-nil, maintain a collection of widgets, `allout-widgets-tally'.
This is for debugging purposes.
The tally shows the total number of item widgets in the current
buffer, and tracking increases as new widgets are added and
decreases as obsolete widgets are garbage collected."
+ :version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
(defvar allout-widgets-tally nil
The table contents will be out of sync if any widgets are created
or deleted while this variable is nil.")
(make-variable-buffer-local 'allout-widgets-tally)
+(defvar allout-widgets-mode-inhibit) ; defined below
;;;_ > allout-widgets-tally-string
(defun allout-widgets-tally-string ()
"Return a string giving the number of tracked widgets, or empty string if not tracking.
The number varies according to the evanescence of objects on a
hash table with weak keys, so tracking of widget erasures is often delayed."
- (when (and allout-widgets-maintain-tally (not allout-widgets-mode-inhibit))
+ (when (and allout-widgets-maintain-tally
+ (not allout-widgets-mode-inhibit)
+ allout-widgets-tally)
(format ":%s" (hash-table-count allout-widgets-tally))))
;;;_ = allout-widgets-track-decoration nil
(defcustom allout-widgets-track-decoration nil
- "*If non-nil, show cursor position of each item decoration.
+ "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\)."
+ :version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
(make-variable-buffer-local 'allout-widgets-track-decoration)
enhancements, directly.")
;;;###autoload
(put 'allout-widgets-mode-inhibit 'safe-local-variable
- (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+ (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
(make-variable-buffer-local 'allout-widgets-mode-inhibit)
;;;_ = allout-inhibit-body-modification-hook
(defvar allout-inhibit-body-modification-hook nil
;;;_ , Widget-specific outline text format
;;;_ = allout-escaped-prefix-regexp
(defvar allout-escaped-prefix-regexp ""
- "*Regular expression for body text that would look like an item prefix if
+ "Regular expression for body text that would look like an item prefix if
not altered with an escape sequence.")
(make-variable-buffer-local 'allout-escaped-prefix-regexp)
;;;_ , Widget element formatting
;;;_ > define-minor-mode allout-widgets-mode (arg)
;;;###autoload
(define-minor-mode allout-widgets-mode
- "Allout-mode extension, providing graphical decoration of outline structure.
-
-This is meant to operate along with allout-mode, via `allout-mode-hook'.
+ "Toggle Allout Widgets mode.
+With a prefix argument ARG, enable Allout Widgets mode if ARG is
+positive, and disable it otherwise. If called from Lisp, enable
+the mode if ARG is omitted or nil.
-If optional argument ARG is greater than 0, enable.
-If optional argument ARG is less than 0, disable.
-Anything else, toggle between active and inactive.
+Allout Widgets mode is an extension of Allout mode that provides
+graphical decoration of outline structure. It is meant to
+operate along with `allout-mode', via `allout-mode-hook'.
The graphics include:
'allout-widgets-shifts-recorder nil 'local)
(add-hook 'allout-after-copy-or-kill-hook
'allout-widgets-after-copy-or-kill-function nil 'local)
+ (add-hook 'allout-post-undo-hook
+ 'allout-widgets-after-undo-function nil 'local)
(add-hook 'before-change-functions 'allout-widgets-before-change-handler
nil 'local)
(message replaced-message)
(message "")))))
- ;; Detect undecorated items, eg during isearch into previously
- ;; unexposed topics, and decorate "economically". Some
- ;; undecorated stuff is often exposed, to reduce lag, but the
- ;; item containing the cursor is decorated. We constrain
- ;; recursion to avoid being trapped by unexpectedly undecoratable
- ;; items.
- (when (and (not recursing)
- (not (allout-current-decorated-p))
- (or (not (equal (allout-depth) 0))
- (not allout-container-item-widget)))
- (let ((buffer-undo-list t))
- (allout-widgets-exposure-change-recorder
- allout-recent-prefix-beginning allout-recent-prefix-end nil)
- (allout-widgets-post-command-business 'recursing)))
+ ;; alas, decorated intermediate matches are not easily undecorated
+ ;; when they're automatically rehidden by isearch, so we're
+ ;; dropping this nicety.
+ ;; ;; Detect undecorated items, eg during isearch into previously
+ ;; ;; unexposed topics, and decorate "economically". Some
+ ;; ;; undecorated stuff is often exposed, to reduce lag, but the
+ ;; ;; item containing the cursor is decorated. We constrain
+ ;; ;; recursion to avoid being trapped by unexpectedly undecoratable
+ ;; ;; items.
+ ;; (when (and (not recursing)
+ ;; (not (allout-current-decorated-p))
+ ;; (or (not (equal (allout-depth) 0))
+ ;; (not allout-container-item-widget)))
+ ;; (let ((buffer-undo-list t))
+ ;; (allout-widgets-exposure-change-recorder
+ ;; allout-recent-prefix-beginning allout-recent-prefix-end nil)
+ ;; (allout-widgets-post-command-business 'recursing)))
;; Detect and rectify fouled outline structure - decorated item
;; not at beginning of line.
(forward-char -1)))))))
(error
- ;; zero work list so we don't get stuck futily retrying.
+ ;; zero work list so we don't get stuck futilely retrying.
;; error recording done by allout-widgets-hook-error-handler.
(setq allout-widgets-changes-record nil))))
;;;_ , major change handlers:
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."
+ (save-excursion
+ (if (allout-goto-prefix)
+ (allout-redecorate-item (allout-get-or-create-item-widget)))))
;;;_ > allout-widgets-exposure-undo-recorder (widget from-state)
(defun allout-widgets-exposure-undo-recorder (widget)
(defun allout-range-overlaps (from to ranges)
"Return a pair indicating overlap of FROM and TO subtree range in RANGES.
-First element of result indicates whether candadate range FROM, TO
+First element of result indicates whether candidate range FROM, TO
overlapped any of the existing ranges.
Second element of result is a new version of RANGES incorporating the
:from nil ; item beginning - marker
:to nil ; item end - marker
- :span-overlay nil ; overlay by which actual postion is determined
+ :span-overlay nil ; overlay by which actual position is determined
;; also serves as guide-end:
:icon-start nil
(set-buffer-modified-p was-modified)
(goto-char steady-point)
- ;; must null the marker or the buffer gets clogged with impedence:
+ ;; must null the marker or the buffer gets clogged with impedance:
(set-marker steady-point nil)
item-widget)))
(defun allout-redecorate-item (item-widget)
"Resituate ITEM-WIDGET decorations, disregarding context.
-Use this to redecorate only the item, when you know that it's
+Use this to redecorate only the item, when you know that its
situation with respect to siblings, parent, and offspring is
unchanged from its last decoration. Use
`allout-decorate-item-and-context' instead to reassess and adjust
-relevent context, when suitable."
+relevant context, when suitable."
(if (not (equal (widget-get item-widget :last-decorated-tick)
allout-command-counter))
(let ((was-modified (buffer-modified-p))
;; item body), to bias the registered values.
;;
;; This is not necessary/useful when the item is being decorated, because
- ;; that always must be preceeded by a fresh item parse.
+ ;; that always must be preceded by a fresh item parse.
(if (not (eq field :body-end))
(widget-get item-widget :from)
(cond ((not overlay) (when start
(setq overlay (make-overlay start end nil t nil))
(overlay-put overlay 'button item-widget)
+ (overlay-put overlay 'evaporate t)
(widget-put item-widget :span-overlay overlay)
t))
;; report:
(defun allout-elapsed-time-seconds (end start)
"Return seconds between `current-time' style time START/END triples."
(let ((elapsed (time-subtract end start)))
- (+ (* (car elapsed) (expt 2.0 16))
- (cadr elapsed)
- (/ (caddr elapsed) (expt 10.0 6)))))
+ (float-time elapsed)))
;;;_ > allout-frame-property (frame property)
(defalias 'allout-frame-property
(cond ((fboundp 'frame-parameter)
(while (consp list) (push (pop list) res))
(prog1 (nreverse res) (setcdr res list)))
(car list)))
+;;;_ . allout-widgets-count-buttons-in-region (start end)
+(defun allout-widgets-count-buttons-in-region (start end)
+ "Debugging/diagnostic tool - count overlays with 'button' property in region."
+ (interactive "r")
+ (setq start (or start (point-min))
+ end (or end (point-max)))
+ (if (> start end) (let ((interim start)) (setq start end end interim)))
+ (let ((button-overlays (delq nil
+ (mapcar (function (lambda (o)
+ (if (overlay-get o 'button)
+ o)))
+ (overlays-in start end)))))
+ (length button-overlays)))
;;;_ : Run unit tests:
(defun allout-widgets-run-unit-tests ()
HCoop / bpt / emacs.git / blobdiff