allout-widgets.el

;;; allout-widgets.el --- Visually highlight allout outline structure.  -*- lexical-binding: t; -*-

;; Copyright (C) 2005-2025 Free Software Foundation, Inc.

;; Author: Ken Manheimer <ken dot manheimer at gmail...>
;; Version: 1.0
;; Created: Dec 2005
;; Keywords: outlines
;; Website: https://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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This is an allout outline-mode add-on that highlights outline structure
;; with graphical widgets.
;;
;; To activate, customize `allout-widgets-auto-activation'.  You can also
;; invoke allout-widgets-mode in a particular allout buffer.  When
;; auto-enabled, you can inhibit widget operation in particular allout
;; buffers by setting the variable `allout-widgets-mode-inhibit' non-nil in
;; that file's buffer.  Use Emacs *file local variables* to generally
;; inhibit for a file.
;;
;; See the `allout-widgets-mode' docstring for more details.
;;
;; Info about allout and allout-widgets development are available at
;; https://myriadicity.net/software-and-systems/craft/emacs-allout
;;
;; The graphics include:
;;
;; - icons for item bullets, varying to distinguish whether the item either
;;   lacks any subitems, the subitems are currently collapsed within the
;;   item, or the item is currently expanded.
;;
;; - guide lines connecting item bullet-icons with those of their subitems.
;;
;; - cue area between the bullet-icon and the start of the body headline,
;;   for item numbering, encryption indicator, and distinctive bullets.
;;
;; 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' docstring for details).
;;
;; Developers note: Our use of Emacs widgets is unconventional.  We
;; decorate existing text rather than substituting for it, to
;; piggy-back on existing allout operation.  This employs the C-coded
;; efficiencies of widget-apply, widget-get, and widget-put, along
;; with the basic object-oriented organization of widget-create, to
;; systematically couple overlays, graphics, and other features with
;; allout-governed text.

;;; Code:

;;;_ : General Environment
(require 'allout)
(require 'widget)
(require 'wid-edit)
(eval-when-compile (require 'cl-lib))

;;;_ : internal variables needed before user-customization variables
;; In order to enable activation of allout-widgets-mode via customization,
;; allout-widgets-auto-activation uses a setting function.  That function
;; is invoked when the customization variable definition is evaluated,
;; during file load, so the involved code must reside above that
;; definition in the file.
;;;_  = allout-widgets-mode
(defvar-local allout-widgets-mode nil
  "Allout mode enhanced with graphical widgets.")

;;;_ : USER CUSTOMIZATION VARIABLES and incidental functions:
;;;_  > defgroup allout-widgets
(defgroup allout-widgets nil
  "Allout extension that highlights outline structure graphically.

Customize `allout-widgets-auto-activation' to activate allout-widgets
with `allout-mode'."
  :group 'allout)
;;;_  > defgroup allout-widgets-developer
(defgroup allout-widgets-developer nil
  "Settings for development of allout widgets extension."
  :group 'allout-widgets)
;;;_  ; some functions a bit early, for allout-auto-activation dependency:
;;;_  > allout-widgets-mode-enable
(defun allout-widgets-mode-enable ()
  "Enable `allout-widgets-mode' in `allout-mode' buffers.

See `allout-widgets-mode-inhibit' for per-file/per-buffer
inhibition of `allout-widgets-mode'."
  (add-hook 'allout-mode-off-hook #'allout-widgets-mode-off)
  (add-hook 'allout-mode-on-hook #'allout-widgets-mode-on)
  t)
;;;_  > allout-widgets-mode-disable
(defun allout-widgets-mode-disable ()
  "Disable `allout-widgets-mode' in `allout-mode' buffers.

See `allout-widgets-mode-inhibit' for per-file/per-buffer
inhibition of `allout-widgets-mode'."
  (remove-hook 'allout-mode-off-hook #'allout-widgets-mode-off)
  (remove-hook 'allout-mode-on-hook #'allout-widgets-mode-on)
  t)
;;;_  > allout-widgets-setup (varname value)
;;;###autoload
(defun allout-widgets-setup (varname value)
  "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)
  (if allout-widgets-auto-activation
      (allout-widgets-mode-enable)
    (allout-widgets-mode-disable)))
;;;_  = allout-widgets-auto-activation
;;;###autoload
(defcustom allout-widgets-auto-activation nil
  "Activate to enable allout icon graphics wherever allout mode is active.

Also enable `allout-auto-activation' for this to take effect upon
visiting an outline.

When this is set you can disable allout widgets in select files
by setting `allout-widgets-mode-inhibit'.

Instead of setting `allout-widgets-auto-activation' you can
explicitly invoke `allout-widgets-mode' in allout buffers where
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.

;; 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
;; deleting from the middle of one to the middle of another.

;; If you only occasionally need to make unrestricted change, you can set this
;; variable in the specific buffer using set-variable, or just deactivate
;; `allout-mode' temporarily.  You can customize this to always allow unruly
;; edits, but you will be able to create outlines that are unnavigable in
;; principle, and not just for allout's navigation and exposure mechanisms."
;;   :type 'boolean
;;   :group allout-widgets)
;; (make-variable-buffer-local 'allout-widgets-allow-unruly-edits)
;;;_  = allout-widgets-auto-activation - below, for eval-order dependencies
;;;_  = 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)

;;;_  . Decoration format
;;;_   = 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."
  :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."
  :version "24.1"
  :type 'plist
  :group 'allout-widgets)
(make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1")
;;;_  . Developer
;;;_   = allout-widgets-time-decoration-activity
(defcustom allout-widgets-time-decoration-activity nil
  "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.

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'.

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-local allout-widgets-tally nil
  "Hash-table of existing allout widgets, for debugging.

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.")
(defvar allout-widgets-mode-inhibit)    ; defined below
;;;_   > allout-widgets-tally-string
(defun allout-widgets-tally-string ()
  "Return a string with number of tracked widgets, or empty string if not tracking.

The string is formed for appending to the `allout-mode' mode-line
lighter.

An empty string is also returned if tracking is inhibited or
widgets are locally inhibited.

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)
             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.

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
  :local t
  :group 'allout-widgets-developer)

;;;_ : Mode context - variables, hookup, and hooks
;;;_  . internal mode variables
;;;_   , Mode activation and environment
;;;_    = allout-widgets-version
(defvar allout-widgets-version "1.0"
  "Version of currently loaded allout-widgets extension.")
;;;_    > allout-widgets-version
(defun allout-widgets-version (&optional here)
  "Return string describing the loaded outline version."
  (interactive "P")
  (let ((msg (concat "Allout Outline Widgets Extension v "
                     allout-widgets-version)))
    (if here (insert msg))
    (message "%s" msg)
    msg))
;;;_    = allout-widgets-mode-inhibit
(defvar-local allout-widgets-mode-inhibit nil
  "Inhibit `allout-widgets-mode' from activating widgets.

This also inhibits automatic adjustment of widgets to track allout outline
changes.

You can use this as a file local variable setting to disable
allout widgets enhancements in selected buffers while generally
enabling widgets by customizing `allout-widgets-auto-activation'.

In addition, you can invoke `allout-widgets-mode' in `allout-mode'
buffers where this is set to enable and disable widget enhancements,
directly.")
;;;###autoload
(put 'allout-widgets-mode-inhibit 'safe-local-variable #'booleanp)
;;;_    = allout-inhibit-body-modification-hook
(defvar-local allout-inhibit-body-modification-hook nil
  "Override de-escaping of text-prefixes in item bodies during specific changes.

This is used by `allout-body-modification-handler' to signal such changes
to `allout-body-modification-handler', and is always reset by
`allout-post-command-business'.")
;;;_    = allout-widgets-icons-cache
(defvar allout-widgets-icons-cache nil
  "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
found on the `load-path') and the icon name.

Set this variable to nil to empty the cache, and have it replenish from the
filesystem.")
;;;_    = allout-widgets-unset-inhibit-read-only
(defvar allout-widgets-unset-inhibit-read-only nil
  "Tell `allout-widgets-post-command-business' to unset `inhibit-read-only'.

Used by `allout-graphics-modification-handler'")
;;;_    = allout-widgets-reenable-before-change-handler
(defvar allout-widgets-reenable-before-change-handler nil
  "Tell `allout-widgets-post-command-business' to reequip the handler.

Necessary because the handler sometimes deliberately raises an
error, causing it to be disabled.")
;;;_   , State for hooks
;;;_    = allout-unresolved-body-mod-workroster
(defvar allout-unresolved-body-mod-workroster (make-hash-table :size 16)
  "List of body-overlays that did before-change business but not after-change.

See `allout-post-command-business' and `allout-body-modification-handler'.")
;;;_    = allout-structure-unruly-deletion-message
(defvar allout-structure-unruly-deletion-message
  "Unruly edit prevented --
To change the bullet character: \\[allout-rebullet-current-heading]
To promote this item: \\[allout-shift-out]
To demote it: \\[allout-shift-in]
To delete it and offspring: \\[allout-kill-topic]
See \\[describe-mode] for many more options."
  "Informative message presented on improper editing of outline structure.

The structure includes the guides lines, bullet, and bullet cue.")
;;;_    = allout-widgets-changes-record
(defvar-local allout-widgets-changes-record nil
  "Record outline changes for processing by post-command hook.

Entries on the list are lists whose first element is a symbol indicating
the change type and subsequent elements are data specific to that change
type.  For example:

  (exposure ALLOUT-EXPOSURE-FROM ALLOUT-EXPOSURE-TO ALLOUT-EXPOSURE-FLAG)

The changes are recorded in reverse order, with new values pushed
onto the front.")
;;;_    = allout-widgets-undo-exposure-record
(defvar-local allout-widgets-undo-exposure-record nil
  "Record outline undo traces for processing by post-command hook.

The changes are recorded in reverse order, with new values pushed
onto the front.")
;;;_    = allout-widgets-last-hook-error
(defvar allout-widgets-last-hook-error nil
  "String holding last error string, for debugging purposes.")
;;;_    = allout-widgets-adjust-message-length-threshold 100
(defvar allout-widgets-adjust-message-length-threshold 100
  "Display \"Adjusting widgets\" message above this number of pending changes."
 )
;;;_    = allout-widgets-adjust-message-size-threshold 10000
(defvar allout-widgets-adjust-message-size-threshold 10000
  "Display \"Adjusting widgets\" message above this size of pending changes."
 )
;;;_    = allout-doing-exposure-undo-processor nil
(defvar allout-undo-exposure-in-progress nil
  "Maintained true during `allout-widgets-exposure-undo-processor'.")
;;;_   , Widget-specific outline text format
;;;_    = allout-escaped-prefix-regexp
(defvar-local allout-escaped-prefix-regexp ""
  "Regular expression for body text that would look like an item prefix if
not altered with an escape sequence.")
;;;_   , Widget element formatting
;;;_    = allout-item-icon-keymap
(defvar-local allout-item-icon-keymap
  (let ((km (make-sparse-keymap))
        (as-parent (if (current-local-map)
                       (make-composed-keymap (current-local-map)
                                             (current-global-map))
                     (current-global-map))))
    ;; The keymap parent is reset on the each local var when mode starts.
    (set-keymap-parent km as-parent)
    (dolist (digit '("0" "1" "2" "3"
                     "4" "5" "6" "7" "8" "9"))
      (define-key km digit #'digit-argument))
    (define-key km "-" #'negative-argument)
    ;; Override underlying mouse-1 and mouse-2 bindings in icon territory:
    (define-key km [(mouse-1)] #'ignore)
    (define-key km [(mouse-2)] #'ignore)

    ;; Catchall, handles actual keybindings, dynamically doing keymap lookups:
    (define-key km [t] #'allout-item-icon-key-handler)

    km)
  "General tree-node key bindings.")
;;;_    = allout-item-body-keymap
(defvar-local allout-item-body-keymap
  (let ((km (make-sparse-keymap))
        (as-parent (if (current-local-map)
                       (make-composed-keymap (current-local-map)
                                             (current-global-map))
                     (current-global-map))))
    ;; The keymap parent is reset on the each local var when mode starts.
    (set-keymap-parent km as-parent)
    km)
  "General key bindings for the text content of outline items.")
;;;_    = allout-body-span-category
(defvar allout-body-span-category nil
  "Symbol carrying allout body-text overlay properties.")
;;;_    = allout-cue-span-keymap
(defvar-local allout-cue-span-keymap
  (let ((km (make-sparse-keymap)))
    (set-keymap-parent km allout-item-icon-keymap)
    km)
  "Keymap used in the item cue area - the space between the icon and headline.")
;;;_    = allout-escapes-category
(defvar allout-escapes-category nil
  "Symbol for category of text property used to hide escapes of prefix-like
text in allout item bodies.")
;;;_    = allout-guides-category
(defvar allout-guides-category nil
  "Symbol carrying allout icon-guides overlay properties.")
;;;_    = allout-guides-span-category
(defvar allout-guides-span-category nil
  "Symbol carrying allout icon and guide lines overlay properties.")
;;;_    = allout-icon-span-category
(defvar allout-icon-span-category nil
  "Symbol carrying allout icon and guide lines overlay properties.")
;;;_    = allout-cue-span-category
(defvar allout-cue-span-category nil
  "Symbol carrying common properties of the space following the outline icon.

\(That space is used to convey selected cues indicating body qualities,
including things like:
 - encryption `~'
 - numbering `#'
 - indirect reference `@'
 - distinctive bullets - see `allout-distinctive-bullets-string'.)")
;;;_    = allout-span-to-category
(defvar allout-span-to-category
  '((:guides-span . allout-guides-span-category)
    (:cue-span . allout-cue-span-category)
    (:icon-span . allout-icon-span-category)
    (:body-span . allout-body-span-category))
  "Association list mapping span identifier to category identifier.")
;;;_    = allout-trailing-category
(defvar allout-trailing-category nil
  "Symbol carrying common properties of an overlay's trailing newline.")
;;;_   , Developer
(defvar-local allout-widgets-last-decoration-timing nil
  "Timing details for the last cooperative decoration action.

This is maintained when `allout-widgets-time-decoration-activity' is set.

The value is a list containing two elements:
  - the elapsed time as a number of seconds
  - the list of changes processed, a la `allout-widgets-changes-record'.

When active, the value is revised each time automatic decoration activity
happens in the buffer.")
;;;_  . mode hookup
;;;_   > define-minor-mode allout-widgets-mode (arg)
;;;###autoload
(define-minor-mode allout-widgets-mode
  "Toggle Allout Widgets mode.

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:

- guide lines connecting item bullet-icons with those of their subitems.

- icons for item bullets, varying to indicate whether or not the item
  has subitems, and if so, whether or not the item is expanded.

- cue area between the bullet-icon and the start of the body headline,
  for item numbering, encryption indicator, and distinctive bullets.

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')."

  :lighter nil
  :keymap nil

  ;; define-minor-mode handles any provided argument according to emacs
  ;; minor-mode conventions - '(elisp) Minor Mode Conventions' - and sets
  ;; allout-widgets-mode accordingly *before* running the body code, so we
  ;; cue on that.
  (if allout-widgets-mode
      ;; Activating:
      (progn
        (allout-add-resumptions
         ;; XXX user may need say in line-truncation/hscrolling - an option
         ;;     that abstracts mode.
         ;; truncate text lines to keep guide lines intact:
         '(truncate-lines t)
         ;; and enable autoscrolling to ease view of text
         '(auto-hscroll-mode t)
         '(line-move-ignore-fields t)
         '(widget-push-button-prefix "")
         '(widget-push-button-suffix "")
         ;; allout-escaped-prefix-regexp depends on allout-regexp:
         (list 'allout-escaped-prefix-regexp (concat "\\(\\\\\\)"
                                                     "\\(" allout-regexp "\\)")))
        (allout-add-resumptions
         (list 'allout-widgets-tally allout-widgets-tally)
         (list 'allout-widgets-escapes-sanitization-regexp-pair
               (list (concat "\\(\n\\|\\`\\)"
                             allout-escaped-prefix-regexp
                             )
                     ;; Include everything but the escape symbol.
                     "\\1\\3"))
         )

        (add-hook 'after-change-functions #'allout-widgets-after-change-handler
                  nil t)

        (allout-setup-text-properties)
        (add-to-invisibility-spec '(allout-torso . t))
        (add-to-invisibility-spec 'allout-escapes)

        (let ((as-parent (if (current-local-map)
                             (make-composed-keymap (current-local-map)
                                                   (current-global-map))
                           (current-global-map))))
          (set-keymap-parent allout-item-body-keymap as-parent)
          ;; allout-cue-span-keymap uses allout-item-icon-keymap as parent.
          (set-keymap-parent allout-item-icon-keymap as-parent))

        (add-hook 'allout-exposure-change-functions
                  #'allout-widgets-exposure-change-recorder nil 'local)
        (add-hook 'allout-structure-added-functions
                  #'allout-widgets-additions-recorder nil 'local)
        (add-hook 'allout-structure-deleted-functions
                  #'allout-widgets-deletions-recorder nil 'local)
        (add-hook 'allout-structure-shifted-functions
                  #'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)
        (add-hook 'post-command-hook #'allout-widgets-post-command-business
                  nil 'local)
        (add-hook 'pre-command-hook #'allout-widgets-pre-command-business
                  nil 'local)

        ;; init the widgets tally for debugging:
        (if (not allout-widgets-tally)
            (setq allout-widgets-tally (make-hash-table
                                        :test 'eq :weakness 'key)))
        ;; add tally count display on minor-mode-alist just after
        ;; allout-mode entry.
        ;; (we use ternary condition form to keep condition simple for deletion.)
        (let* ((mode-line-entry '(allout-widgets-mode-inhibit ""
                                                              (:eval (allout-widgets-tally-string))))
               (associated (assoc (car mode-line-entry) minor-mode-alist))
               ;; need location for it only if not already present:
               (after (and (not associated)
                           (memq (assq 'allout-mode minor-mode-alist) minor-mode-alist))))
          (if after
              (rplacd after (cons mode-line-entry (cdr after)))))
        (allout-widgets-prepopulate-buffer)
        t)
    ;; Deactivating:
    (let ((inhibit-read-only t)
          (was-modified (buffer-modified-p)))

      (allout-widgets-undecorate-region (point-min)(point-max))
      (remove-from-invisibility-spec '(allout-torso . t))
      (remove-from-invisibility-spec 'allout-escapes)

      (remove-hook 'after-change-functions
                   #'allout-widgets-after-change-handler 'local)
      (remove-hook 'allout-exposure-change-functions
                   #'allout-widgets-exposure-change-recorder 'local)
      (remove-hook 'allout-structure-added-functions
                   #'allout-widgets-additions-recorder 'local)
      (remove-hook 'allout-structure-deleted-functions
                   #'allout-widgets-deletions-recorder 'local)
      (remove-hook 'allout-structure-shifted-functions
                   #'allout-widgets-shifts-recorder 'local)
      (remove-hook 'allout-after-copy-or-kill-hook
                   #'allout-widgets-after-copy-or-kill-function 'local)
      (remove-hook 'before-change-functions
                   #'allout-widgets-before-change-handler 'local)
      (remove-hook 'post-command-hook
                   #'allout-widgets-post-command-business 'local)
      (remove-hook 'pre-command-hook
                   #'allout-widgets-pre-command-business 'local)
      (setq minor-mode-alist
            (assq-delete-all 'allout-widgets-mode-inhibit minor-mode-alist))
      (set-buffer-modified-p was-modified))))
;;;_   > allout-widgets-mode-off
(defun allout-widgets-mode-off ()
  "Explicitly disable `allout-widgets-mode'."
  (allout-widgets-mode -1))
;;;_   > allout-widgets-mode-off
(defun allout-widgets-mode-on ()
  "Explicitly enable `allout-widgets-mode'."
  (allout-widgets-mode 1))
;;;_   > allout-setup-text-properties ()
(defun allout-setup-text-properties ()
  "Configure category and literal text properties."

  ;; XXX body - before-change, entry, keymap

  (setplist 'allout-guides-span-category nil)
  (put 'allout-guides-span-category
       'modification-hooks '(allout-graphics-modification-handler))
  (put 'allout-guides-span-category 'local-map allout-item-icon-keymap)
  (put 'allout-guides-span-category 'mouse-face widget-button-face)
  (put 'allout-guides-span-category 'field 'structure)
;;  (put 'allout-guides-span-category 'face 'widget-button)

  (setplist 'allout-icon-span-category
            (allout-widgets-copy-list (symbol-plist
                                       'allout-guides-span-category)))
  (put 'allout-icon-span-category 'field 'structure)

  ;; XXX for body text we're instead going to use the buffer-wide
  ;;     resources, like before/after-change-functions hooks and the
  ;;     buffer's key map.  that way we won't have to do painful provisions
  ;;     to fixup things after edits, catch outlier interstitial
  ;;     characters, like newline and empty lines after hidden subitems,
  ;;     etc.
  (setplist 'allout-body-span-category nil)
  (put 'allout-body-span-category 'evaporate t)
  (put 'allout-body-span-category 'local-map allout-item-body-keymap)
  ;;(put 'allout-body-span-category
  ;;     'modification-hooks '(allout-body-modification-handler))
  ;;(put 'allout-body-span-category 'field 'body)

  (setplist 'allout-cue-span-category nil)
  (put 'allout-cue-span-category 'evaporate t)
  (put 'allout-cue-span-category
       'modification-hooks '(allout-graphics-modification-handler))
  (put 'allout-cue-span-category 'local-map allout-cue-span-keymap)
  (put 'allout-cue-span-category 'mouse-face widget-button-face)
  (put 'allout-cue-span-category 'pointer 'arrow)
  (put 'allout-cue-span-category 'field 'structure)

  (setplist 'allout-trailing-category nil)
  (put 'allout-trailing-category 'evaporate t)
  (put 'allout-trailing-category 'local-map allout-item-body-keymap)

  (setplist 'allout-escapes-category nil)
  (put 'allout-escapes-category 'invisible 'allout-escapes)
  (put 'allout-escapes-category 'evaporate t))
;;;_   > allout-widgets-prepopulate-buffer ()
(defun allout-widgets-prepopulate-buffer ()
  "Step over the current buffers exposed items to do initial widgetizing."
  (if (not allout-widgets-mode-inhibit)
      (save-excursion
        (goto-char (point-min))
        (while (allout-next-visible-heading 1)
          (when (not (widget-at (point)))
            (allout-get-or-create-item-widget))))))
;;;_  . settings context
;;;_   = allout-container-item
(defvar-local 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
icon/bullet.")
;;;_  . 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."
)
;;;_    > allout-widgets-post-command-business (&optional recursing)
(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 nil

      (when (and (boundp 'allout-mode) allout-mode)

        (if allout-widgets-unset-inhibit-read-only
            (setq inhibit-read-only nil
                  allout-widgets-unset-inhibit-read-only nil))

        (when allout-widgets-reenable-before-change-handler
          (add-hook 'before-change-functions
                    #'allout-widgets-before-change-handler
                    nil 'local)
          (setq allout-widgets-reenable-before-change-handler nil))

        (when (or allout-widgets-undo-exposure-record
                  allout-widgets-changes-record)
          (let* ((debug-on-signal t)
                 (debug-on-error t)
                 ;; inhibit recording new undo records when processing
                 ;; effects of undo-exposure:
                 (debugger 'allout-widgets-hook-error-handler)
                 (adjusting-message " Adjusting widgets...")
                 (replaced-message (allout-widgets-adjusting-message
                                    adjusting-message))
                 (start-time (current-time)))

            (if allout-widgets-undo-exposure-record
                ;; inhibit undo recording iff undoing exposure stuff.
                ;; XXX we might need to inhibit per respective
                ;;     change-record, rather than assuming that some undo
                ;;     activity during a command is all undo activity.
                (let ((buffer-undo-list t))
                  (allout-widgets-exposure-undo-processor)
                  (allout-widgets-changes-dispatcher))
              (allout-widgets-exposure-undo-processor)
              (allout-widgets-changes-dispatcher))

            (if allout-widgets-time-decoration-activity
                (setq allout-widgets-last-decoration-timing
                      (list (allout-elapsed-time-seconds nil start-time)
                            allout-widgets-changes-record)))

            (setq allout-widgets-changes-record nil)

            (if replaced-message
                (if (stringp replaced-message)
                    (message replaced-message)
                  (message "")))))

        ;; 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.
        (let ((this-widget (or (widget-at (point))
                               ;; XXX we really should be checking across
                               ;; edited span, not just point and point+1
                               (and (not (eq (point) (point-max)))
                                    (widget-at (1+ (point))))))
              inserted-at)
          (save-excursion
            (if (and this-widget
                     (goto-char (widget-get this-widget :from))
                     (not (bolp)))
                (if (not
                     (condition-case nil
                         (yes-or-no-p
                          (concat "Misplaced item won't be recognizable "
                                  " as part of outline - rectify? "))
                       (quit nil)))
                    (progn
                      (if (allout-hidden-p (max (1- (point)) 1))
                          (save-excursion
                            (goto-char (max (1- (point)) 1))
                            (allout-show-to-offshoot)))
                      (allout-widgets-undecorate-item this-widget))
                  ;; expose any hidden intervening items, so resulting
                  ;; position is clear:
                  (setq inserted-at (point))
                  (allout-unprotected (insert-before-markers "\n"))
                  (forward-char -1)
                  ;; ensure the inserted newline is visible:
                  (allout-flag-region inserted-at (1+ inserted-at) nil)
                  (allout-widgets-post-command-business 'recursing)
                  (message (concat "outline structure corrected - item"
                                   " moved to beginning of new line"))
                  ;; preserve cursor position in some cases:
                  (if (and inserted-at
                           (> (point) inserted-at))
                      (forward-char -1)))))))

    (error
     ;; 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:
;;;_    > allout-widgets-before-change-handler
(defun allout-widgets-before-change-handler (beg end)
  "Business to be done before changes in a widgetized allout outline."
  ;; protect against unruly edits to structure:
  (cond
   (undo-in-progress (when (eq (get-text-property beg 'category)
                               'allout-icon-span-category)
                       (save-excursion
                         (goto-char beg)
                         (let* ((item-widget (allout-get-item-widget)))
                           (if item-widget
                               (allout-widgets-exposure-undo-recorder
                                item-widget))))))
   (inhibit-read-only t)
   ((not  (and (boundp 'allout-mode) allout-mode)) t)
   ((equal this-command 'quoted-insert) t)
   ((not (text-property-any beg (if (equal end beg)
                                    (min (1+ beg) (point-max))
                                  end)
                            'field 'structure))
    t)
   ((yes-or-no-p "Unruly edit of outline structure - allow? ")
    (setq allout-widgets-unset-inhibit-read-only (not inhibit-read-only)
          inhibit-read-only t))
   (t
    ;; tell the allout-widgets-post-command-business to reestablish the hook:
    (setq allout-widgets-reenable-before-change-handler t)
    ;; and raise an error to prevent the edit (and disable the hook):
    (error "%s"
     (substitute-command-keys allout-structure-unruly-deletion-message)))))
;;;_    > allout-widgets-after-change-handler
(defun allout-widgets-after-change-handler (_beg _end _prelength)
  "Reconcile what needs to be reconciled for allout widgets after edits."
  )
;;;_   > allout-current-decorated-p ()
(defun allout-current-decorated-p ()
  "True if the current item is not decorated."
  (save-excursion
    (if (allout-back-to-current-heading)
        (if (> allout-recent-depth 0)
            (and (allout-get-item-widget) t)
          allout-container-item-widget))))

;;;_   > allout-widgets-hook-error-handler
(defun allout-widgets-hook-error-handler (mode args)
  "Process errors which occurred in the course of command hook operation.

We store a backtrace of the error information in the variable,
`allout-widgets-last-hook-error', unset the error handlers, and
reraise the error, so that processing continues to the
encompassing `condition-case'."
  ;; first deconstruct special error environment so errors here propagate
  ;; to encompassing condition-case:
  (setq debugger 'debug
        debug-on-error nil
        debug-on-signal nil)
  (let* ((bt (with-output-to-string (backtrace)))
         (this "allout-widgets-hook-error-handler")
         (header
          (format "allout-widgets-last-hook-error stored, %s/%s %s %s"
                  this mode args
                  (format-time-string "%e-%b-%Y %r"))))
    ;; post to *Messages* then immediately replace with more compact notice:
    (message "%s" (setq allout-widgets-last-hook-error
                        (format "%s:\n%s" header bt)))
    (message header) (sit-for allout-widgets-hook-error-post-time)
    ;; reraise the error, or one concerning this function if unexpected:
    (if (equal mode 'error)
        (apply #'signal args)
      (error "%s: Unexpected mode, %s %s" this mode args))))
;;;_   > allout-widgets-changes-exceed-threshold-p ()
(defun allout-widgets-adjusting-message (message)
  "Post MESSAGE when pending are likely to make a big enough delay.

If posting of the MESSAGE is warranted and there already is a
`current-message' in the minibuffer, the MESSAGE is appended to
the current one, and the previously pending `current-message' is
returned for later posting on completion.

If posting of the MESSAGE is warranted, but no `current-message'
is pending, then t is returned to indicate that case.

If posting of the MESSAGE is not warranted, then nil is returned.

See `allout-widgets-adjust-message-length-threshold',
`allout-widgets-adjust-message-size-threshold' for message
posting threshold criteria."
  (if (or (> (length allout-widgets-changes-record)
             allout-widgets-adjust-message-length-threshold)
          ;; for size, use distance from start of first to end of last:
          (let ((min (point-max))
                (max 0)
                first second)
            (mapc (lambda (entry)
                    (if (eq :undone-exposure (car entry))
                        nil
                      (setq first (cadr entry)
                            second (caddr entry))
                      (if (< (min first second) min)
                          (setq min (min first second)))
                      (if (> (max first second) max)
                          (setq max (max first second)))))
                    allout-widgets-changes-record)
            (> (- max min) allout-widgets-adjust-message-size-threshold)))
      (let ((prior (current-message)))
        (message (if prior (concat prior " - " message) message))
        (or prior t))))
;;;_   > allout-widgets-changes-dispatcher ()
(defun allout-widgets-changes-dispatcher ()
  "Dispatch CHANGES-RECORD items to respective widgets change processors."

  (if (not allout-widgets-mode-inhibit)
      (let* ((changes-record allout-widgets-changes-record)
             (changes-pending (and changes-record t))
             entry
             exposures
             additions
             deletions
             shifts)

        (when changes-pending
          (while changes-record
            (setq entry (pop changes-record))
            (pcase (car entry)
              (:exposed (push entry exposures))
              (:added (push entry additions))
              (:deleted (push entry deletions))
              (:shifted (push entry shifts))))

          (if exposures
              (allout-widgets-exposure-change-processor exposures))
          (if additions
              (allout-widgets-additions-processor additions))
          (if deletions
              (allout-widgets-deletions-processor deletions))
          (if shifts
              (allout-widgets-shifts-processor shifts))))
    (when (not (equal allout-widgets-mode-inhibit 'undecorated))
      (allout-widgets-undecorate-region (point-min)(point-max))
      (setq allout-widgets-mode-inhibit 'undecorated))))
;;;_   > allout-widgets-exposure-change-recorder (from to flag)
(defun allout-widgets-exposure-change-recorder (from to flag)
  "Record allout exposure changes for tracking during post-command processing.

Records changes in `allout-widgets-changes-record'."
  (push (list :exposed from to flag) allout-widgets-changes-record))
;;;_   > allout-widgets-exposure-change-processor (changes)
(defun allout-widgets-exposure-change-processor (changes)
  "Widgetize and adjust item widgets tracking allout outline exposure changes.

Generally invoked via `allout-exposure-change-functions'."

  (let ((changes (sort changes (lambda (this next)
                                 (< (cadr this) (cadr next)))))
        ;; 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)

    (dolist (change changes)
      (let ((from (cadr change))
            bucket
            (to (caddr change))
            (flag (cadddr change))
            parent)

        ;; swap from and to:
        (if (< to from) (setq bucket to
                              to from
                              from bucket))

        ;; have we already handled exposure changes in this region?
        (cl-callf (lambda (x)
                    (let ((got (allout-range-overlaps from to x)))
                      (setq covered (car got))
                      (cadr got)))
            (if flag handled-conceal handled-expose))

        (when (not covered)
          (save-excursion
            (goto-char from)
            (cond