code.delx.au - gnu-emacs-elpa/blob - packages/auto-overlays/auto-overlay-self.el

   1 ;;; auto-overlay-self.el --- self-delimited automatic overlays
   2
   3
   4 ;; Copyright (C) 2005-2015  Free Software Foundation, Inc
   5
   6 ;; Author: Toby Cubitt <toby-predictive@dr-qubit.org>
   7 ;; Maintainer: Toby Cubitt <toby-predictive@dr-qubit.org>
   8 ;; URL: http://www.dr-qubit.org/emacs.php
   9 ;; Repository: http://www.dr-qubit.org/git/predictive.git
  10
  11 ;; This file is part of the Emacs.
  12 ;;
  13 ;; This file is free software: you can redistribute it and/or modify it under
  14 ;; the terms of the GNU General Public License as published by the Free
  15 ;; Software Foundation, either version 3 of the License, or (at your option)
  16 ;; any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  20 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  21 ;; more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License along
  24 ;; with this program.  If not, see <http://www.gnu.org/licenses/>.
  25
  26
  27 ;;; Code:
  28
  29 (require 'auto-overlays)
  30 (provide 'auto-overlay-self)
  31
  32 (defvar auto-o-pending-self-cascade nil)
  33
  34 ;; set self overlay parsing and suicide functions
  35 (put 'self 'auto-overlay-parse-function 'auto-o-parse-self-match)
  36 (put 'self 'auto-overlay-suicide-function 'auto-o-self-suicide)
  37
  38 ;; add initialisation and clear functions to hooks
  39 (add-hook 'auto-overlay-load-hook 'auto-o-self-load)
  40 (add-hook 'auto-overlay-unload-hook 'auto-o-self-unload)
  41
  42
  43
  44 (defun auto-o-self-load ()
  45   ;; Make sure `auto-o-perform-self-cascades' is in `before-change-functions',
  46   ;; so that any cascading that is required is performed before anything else
  47   ;; happens.
  48   (add-hook 'before-change-functions 'auto-o-perform-self-cascades
  49             nil t)
  50   ;; initialise variables
  51   (setq auto-o-pending-self-cascade nil)
  52 )
  53
  54
  55 (defun auto-o-self-unload ()
  56   ;; Remove `auto-o-perform-self-cascades' from `before-change-functions'.
  57   (remove-hook 'before-change-functions 'auto-o-perform-self-cascades t)
  58 )
  59
  60
  61
  62
  63 (defun auto-o-parse-self-match (o-match)
  64   ;; perform any necessary updates of auto overlays due to a match for a self
  65   ;; regexp
  66
  67   (let* ((overlay-list (auto-o-self-list o-match))
  68          (o (car overlay-list)))
  69
  70     (cond
  71      ;; if stack is empty, create a new end-unmatched overlay, adding it to
  72      ;; the list of unascaded overlays (avoids treating it as a special
  73      ;; case), and return it
  74      ((null overlay-list)
  75       (auto-o-make-self o-match nil))
  76
  77      ;; if new delimiter is inside the first existing overlay and existing one
  78      ;; is end-unmatched, just match it
  79      ((and (not (overlay-get o 'end))
  80            (>= (overlay-get o-match 'delim-start) (overlay-start o)))
  81       (auto-o-match-overlay o nil o-match 'no-props)
  82       ;; remove it from the list of uncascaded overlays
  83       (setq auto-o-pending-self-cascade (delq o auto-o-pending-self-cascade))
  84       ;; return nil since haven't created any new overlays
  85       nil)
  86
  87
  88      ;; otherwise...
  89      (t
  90       (let (o-new)
  91         ;; if the new match is outside existing overlays...
  92         (if (< (overlay-get o-match 'delim-end) (overlay-start o))
  93             ;; create overlay from new match till start of next match, and add
  94             ;; it to the list of uncascaded overlays
  95             (setq o-new (auto-o-make-self
  96                          o-match
  97                          (overlay-get (overlay-get o 'start) 'delim-start)))
  98
  99           ;; if the new match is inside an existing overlay...
 100           (setq o (pop overlay-list))
 101           ;; create overlay from end of existing one till start of the one
 102           ;; after (or end of buffer if there isn't one), and add it to the
 103           ;; list of uncascaded overlays
 104           (setq o-new (auto-o-make-self
 105                        (overlay-get o 'end)
 106                        (when overlay-list
 107                          (overlay-get (overlay-get (car overlay-list) 'start)
 108                                       'delim-start))))
 109           ;; match end of existing one with the new match, protecting its old
 110           ;; end match which is now matched with start of new one
 111           (auto-o-match-overlay o nil o-match 'no-props nil 'protect-match))
 112
 113       ;; return newly created overlay
 114       o-new))
 115      ))
 116 )
 117
 118
 119
 120
 121 (defun auto-o-self-suicide (o-self)
 122   ;; Called when match no longer matches. Unmatch the match overlay O-SELF, if
 123   ;; necessary deleting its parent overlay or cascading.
 124
 125   (let ((o-parent (overlay-get o-self 'parent)))
 126     (cond
 127      ;; if parent is end-unmatched, delete it from buffer and from list of
 128      ;; uncascaded overlays
 129      ((not (auto-o-end-matched-p o-parent))
 130       (auto-o-delete-overlay o-parent)
 131       (setq auto-o-pending-self-cascade
 132             (delq o-parent auto-o-pending-self-cascade)))
 133
 134      ;; if we match the end of parent...
 135      ((eq (overlay-get o-parent 'end) o-self)
 136       ;; unmatch ourselves from parent and extend parent till next overlay, or
 137       ;; end of buffer if there is none
 138       (let ((o (nth 1 (auto-o-self-list o-self))))
 139         (auto-o-match-overlay
 140          o-parent nil (if o (overlay-get (overlay-get o 'start) 'delim-start)
 141                         'unmatched)))
 142       ;; add parent to uncascaded overlay list
 143       (push o-parent auto-o-pending-self-cascade))
 144
 145      ;; if we match the start of parent...
 146      (t
 147       (let* ((o-end (overlay-get o-parent 'end))
 148              (o (nth 1 (auto-o-self-list o-end))))
 149         ;; unmatch ourselves from parent and "flip"
 150         (auto-o-match-overlay
 151          o-parent o-end
 152          (if o (overlay-get (overlay-get o 'start) 'delim-start)
 153            'unmatched)))
 154       ;; add parent to uncascaded overlay list
 155       (push o-parent auto-o-pending-self-cascade))
 156      ))
 157 )
 158
 159
 160
 161
 162 (defun auto-o-make-self (o-start &optional end)
 163   ;; Create a self overlay starting at match overlay O-START.
 164   ;; If END is a number or marker, the new overlay is end-unmatched and ends
 165   ;; at the buffer location specified by the number or marker.
 166   ;; If END is nil, the new overlay is end-unmatched and ends at the end of
 167   ;; the buffer.
 168   (let (o-new)
 169
 170     ;; create new overlay (location ensures right things happen when matched)
 171     (let (pos)
 172       (cond
 173        ((overlayp end) (setq pos (overlay-get end 'delim-start)))
 174        ((number-or-marker-p end) (setq pos end))
 175        (t (setq pos (point-max))))
 176       (setq o-new (make-overlay pos pos nil nil 'rear-advance)))
 177
 178     ;; give overlay some basic properties
 179     (overlay-put o-new 'auto-overlay t)
 180     (overlay-put o-new 'set-id (overlay-get o-start 'set-id))
 181     (overlay-put o-new 'definition-id (overlay-get o-start 'definition-id))
 182
 183     ;; if overlay is end-unmatched, add it to the list of uncascaded overlays
 184     (unless (overlayp end) (push o-new auto-o-pending-self-cascade))
 185
 186     ;; match the new overlay and return it
 187     (auto-o-match-overlay o-new o-start (if (overlayp end) end nil))
 188     o-new)
 189 )
 190
 191
 192
 193
 194 (defun auto-o-perform-self-cascades (beg end)
 195   ;; Perform any necessary self-overlay cascading before the text in the
 196   ;; buffer is modified. Called from `before-change-functions'.
 197
 198   ;; check all overlays waiting to be cascaded, from first in buffer to last
 199   (dolist (o (sort auto-o-pending-self-cascade
 200                    (lambda (a b) (< (overlay-start a) (overlay-start b)))))
 201     ;; if buffer modification occurs after the end of an overlay waiting to be
 202     ;; cascaded, cascade all overlays between it and the modified text
 203     (when (and (overlay-end o) (< (overlay-end o) end))
 204       (auto-o-self-cascade (auto-o-self-list (overlay-get o 'start) end))))
 205 )
 206
 207
 208
 209
 210 (defun auto-o-self-cascade (overlay-list)
 211   ;; "Flip" overlays down through buffer (assumes first overlay in list is
 212   ;; end-unmatched).
 213   (when (> (length overlay-list) 1)
 214     (let ((o (car overlay-list))
 215           (o1 (nth 1 overlay-list)))
 216
 217       ;; match first (presumably end-matched) overlay and remove it from list
 218       (pop overlay-list)
 219       (auto-o-match-overlay o nil (overlay-get o1 'start) 'no-props)
 220       ;; remove it from list of uncascaded overlays
 221       (setq auto-o-pending-self-cascade (delq o auto-o-pending-self-cascade))
 222       ;; if we've hit an end-unmatched overlay, we can stop cascading
 223       (if (not (auto-o-end-matched-p o1))
 224           (progn
 225             (auto-o-delete-overlay o1 nil 'protect-match)
 226             (setq auto-o-pending-self-cascade
 227                   (delq o1 auto-o-pending-self-cascade)))
 228
 229         ;; otherwise, cascade overlay list till one is left or we hit an
 230         ;; end-unmached overlay
 231         (unless
 232             (catch 'stop
 233               (dotimes (i (1- (length overlay-list)))
 234                 (setq o (nth i overlay-list))
 235                 (setq o1 (nth (1+ i) overlay-list))
 236                 (auto-o-match-overlay o (overlay-get o 'end)
 237                                       (overlay-get o1 'start)
 238                                       'no-props nil 'protect-match)
 239                 ;; if we hit an end-unmatched overlay, we can stop cascading
 240                 (when (not (auto-o-end-matched-p o1))
 241                   (throw 'stop (progn
 242                                  ;; delete the end-unmatched overlay
 243                                  (auto-o-delete-overlay o1 nil 'protect-match)
 244                                  ;; remove it from uncascaded overlays list
 245                                  (setq auto-o-pending-self-cascade
 246                                        (delq o1 auto-o-pending-self-cascade))
 247                                  ;; return t to indicate cascading ended early
 248                                  t)))))
 249
 250           ;; if there's an overlay left, "flip" it so it's end-unmatched and
 251           ;; extends to next overlay in buffer, and add it to the list of
 252           ;; unmatched overlays
 253           (let (pos)
 254             (setq o (car (last overlay-list)))
 255             (if (setq o1 (nth 1 (auto-o-self-list (overlay-get o 'end))))
 256                 (setq pos (overlay-get (overlay-get o1 'start) 'delim-start))
 257               (setq pos (point-max)))
 258             (auto-o-match-overlay o (overlay-get o 'end) pos
 259                                   'no-props nil 'protect-match))
 260           (push o auto-o-pending-self-cascade)))
 261       ))
 262 )
 263
 264
 265
 266
 267 ;; (defun auto-o-self-list (o-start &optional end)
 268 ;;   ;; Return list of self overlays ending at or after match overlay O-START and
 269 ;;   ;; starting before or at END, corresponding to same entry as O-START. If END
 270 ;;   ;; is null, all overlays after O-START are included.
 271
 272 ;;   (when (null end) (setq end (point-max)))
 273
 274 ;;   (let (overlay-list)
 275 ;;     ;; create list of all overlays corresponding to same entry between O-START
 276 ;;     ;; and END
 277 ;;     (mapc (lambda (o) (when (and (>= (overlay-end o)
 278 ;;                                   (overlay-get o-start 'delim-start))
 279 ;;                               (<= (overlay-start o) end))
 280 ;;                      (push o overlay-list)))
 281 ;;        (auto-overlays-in
 282 ;;         (point-min) (point-max)
 283 ;;         (list
 284 ;;          '(identity auto-overlay)
 285 ;;          (list 'eq 'set-id (overlay-get o-start 'set-id))
 286 ;;          (list 'eq 'definition-id (overlay-get o-start 'definition-id)))))
 287 ;;     ;; sort the list by start position, from first to last
 288 ;;     (sort overlay-list
 289 ;;        (lambda (a b) (< (overlay-start a) (overlay-start b)))))
 290 ;; )
 291
 292
 293
 294 (defun auto-o-self-list (o-start &optional end)
 295   ;; Return list of self overlays ending at or after match overlay O-START and
 296   ;; starting before or at END, corresponding to same entry as O-START. If END
 297   ;; is null, all overlays after O-START are included.
 298
 299   (when (null end) (setq end (point-max)))
 300
 301   (let (overlay-list)
 302     ;; create list of all overlays corresponding to same entry between O-START
 303     ;; and END
 304     (setq overlay-list
 305           ;; Note: We subtract 1 from start and add 1 to end to catch overlays
 306           ;;       that end at start or start at end. This seems to give the
 307           ;;       same results as the old version of `auto-o-self-list'
 308           ;;       (above) in all circumstances.
 309           (auto-overlays-in
 310            (1- (overlay-get o-start 'delim-start)) (1+ end)
 311            (list
 312             '(identity auto-overlay)
 313             (list 'eq 'set-id (overlay-get o-start 'set-id))
 314             (list 'eq 'definition-id (overlay-get o-start 'definition-id)))))
 315     ;; sort the list by start position, from first to last
 316     (sort overlay-list
 317           (lambda (a b) (< (overlay-start a) (overlay-start b)))))
 318 )
 319
 320
 321 ;;; auto-overlay-self.el ends here