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

   1 ;;; auto-overlay-nested.el --- nested start/end-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-nested)
  31
  32
  33 ;; set nested overlay parsing and suicide functions, and indicate class
  34 ;; requires separate start and end regexps
  35 (put 'nested 'auto-overlay-parse-function 'auto-o-parse-nested-match)
  36 (put 'nested 'auto-overlay-suicide-function 'auto-o-nested-suicide)
  37 (put 'nested 'auto-overlay-complex-class t)
  38
  39
  40
  41 (defun auto-o-parse-nested-match (o-match)
  42   ;; Perform any necessary updates of auto overlays due to a match for a
  43   ;; nested regexp.
  44
  45   (let* ((overlay-stack (auto-o-nested-stack o-match))
  46          (o (car overlay-stack)))
  47     (cond
  48      ;; if the stack is empty, just create and return a new unmatched overlay
  49      ((null overlay-stack)
  50       (auto-o-make-nested o-match 'unmatched))
  51
  52      ;; if appropriate edge of innermost overlay is unmatched, just match it
  53      ((or (and (eq (auto-o-edge o-match) 'start)
  54                (not (auto-o-start-matched-p o)))
  55           (and (eq (auto-o-edge o-match) 'end)
  56                (not (auto-o-end-matched-p o))))
  57       (auto-o-match-overlay o o-match)
  58       ;; return nil since haven't created any new overlays
  59       nil)
  60
  61      ;; otherwise...
  62      (t
  63       ;; create new innermost overlay and add it to the overlay stack
  64       (push (auto-o-make-nested o-match) overlay-stack)
  65       ;; sort out the overlay stack
  66       (auto-o-nested-stack-cascade overlay-stack)
  67       ;; return newly created overlay
  68       (car overlay-stack)))
  69     ))
  70
  71
  72
  73
  74 (defun auto-o-nested-suicide (o-self)
  75   ;; Called when match no longer matches. Unmatch the match overlay O-SELF, if
  76   ;; necessary deleting its parent overlay or cascading the stack.
  77
  78   (let* ((overlay-stack (auto-o-nested-stack o-self))
  79         (o-parent (car overlay-stack)))
  80
  81     (cond
  82      ;; if other end of parent is unmatched, just delete parent
  83      ((not (auto-o-edge-matched-p
  84             o-parent
  85             (if (eq (auto-o-edge o-self) 'start) 'end 'start)))
  86       (auto-o-delete-overlay o-parent))
  87
  88      ;; if parent is the only overlay in the stack...
  89      ((= (length overlay-stack) 1)
  90       ;; if we're a start match, make parent start-unmatched
  91       (if (eq (auto-o-edge o-self) 'start)
  92           (auto-o-match-overlay o-parent 'unmatched nil)
  93             ;; if we're an end match, make parent end-unmatched
  94         (auto-o-match-overlay o-parent nil 'unmatched)))
  95
  96       ;; otherwise, unmatch ourselves from parent and cascade the stack
  97      (t
  98       (overlay-put o-parent (auto-o-edge o-self) nil)
  99       (overlay-put o-self 'parent nil)
 100       (auto-o-nested-stack-cascade overlay-stack))
 101      )))
 102
 103
 104
 105
 106 (defun auto-o-make-nested (o-match &optional unmatched)
 107   ;; Create a nested overlay for match overlay O-MATCH.
 108   ;; If UNMATCHED is nil, overlay will start and end at O-MATCH.
 109   ;; If non-nil, overlay will start or end from O-MATCH (depending on whether
 110   ;; O-MATCH is a 'start or 'end match) and stretch till end or beginning of
 111   ;; buffer.
 112
 113   (let (o-new pos)
 114     ;; create new nested overlay and match it with O-MATCH
 115     (cond
 116      ((eq (auto-o-edge o-match) 'start)
 117       (setq pos (overlay-get o-match 'delim-end))
 118       (setq o-new (make-overlay pos pos nil nil 'rear-advance))
 119       (overlay-put o-new 'auto-overlay t)
 120       (overlay-put o-new 'set-id (overlay-get o-match 'set-id))
 121       (overlay-put o-new 'definition-id (overlay-get o-match 'definition-id))
 122       (auto-o-match-overlay o-new o-match 'unmatched))
 123
 124      ((eq (auto-o-edge o-match) 'end)
 125       (setq pos (overlay-get o-match 'delim-start))
 126       (setq o-new (make-overlay pos pos nil nil 'rear-advance))
 127       (overlay-put o-new 'auto-overlay t)
 128       (overlay-put o-new 'set-id (overlay-get o-match 'set-id))
 129       (overlay-put o-new 'definition-id (overlay-get o-match 'definition-id))
 130       (auto-o-match-overlay o-new 'unmatched o-match)))
 131
 132     ;; return the new overlay
 133     o-new))
 134
 135
 136
 137 (defun auto-o-nested-stack-cascade (overlay-stack)
 138   ;; Cascade the ends of the overlays in OVERLAY-STACK up or down the stack,
 139   ;; so as to re-establish a valid stack. It assumes that only the innermost
 140   ;; is incorrect.
 141
 142   (let ((o (car overlay-stack)) o1)
 143     (cond
 144
 145      ;; if innermost overlay is start-matched (and presumably
 146      ;; end-unmatched)...
 147      ((auto-o-start-matched-p o)
 148       ;; cascade overlay end matches up through stack until one is left
 149       (dotimes (i (- (length overlay-stack) 1))
 150         (setq o (nth i overlay-stack))
 151         (setq o1 (nth (+ i 1) overlay-stack))
 152         (auto-o-match-overlay o nil
 153                               (if (overlay-get o1 'end)
 154                                     (overlay-get o1 'end)
 155                                 'unmatched)
 156                               nil nil 'protect-match))
 157       ;; if final overlay is start-matched, make it end-unmatched, otherwise
 158       ;; delete it
 159       (if (auto-o-start-matched-p o1)
 160           ;; FIXME: could postpone re-parsing here in case it can be avoided
 161           (auto-o-match-overlay o1 nil 'unmatch nil nil 'protect-match)
 162         (auto-o-delete-overlay o1 nil 'protect-match)))
 163
 164
 165      ;; if innermost overlay is end-matched (and presumably
 166      ;; start-unmatched)...
 167      ((auto-o-end-matched-p o)
 168       ;; cascade overlay start matches up through stack until one is left
 169       (dotimes (i (- (length overlay-stack) 1))
 170         (setq o (nth i overlay-stack))
 171         (setq o1 (nth (+ i 1) overlay-stack))
 172         (auto-o-match-overlay o (if (overlay-get o1 'start)
 173                                     (overlay-get o1 'start)
 174                                   'unmatched)
 175                               nil nil nil 'protect-match))
 176       ;; if final overlay is end-matched, make it start-unmatched, otherwise
 177       ;; delete it
 178       (if (auto-o-end-matched-p o1)
 179           ;; FIXME: could postpone re-parsing here in case it can be avoided
 180           (auto-o-match-overlay o1 'unmatch nil nil nil 'protect-match)
 181         (auto-o-delete-overlay o1 nil 'protect-match))))
 182     )
 183 )
 184
 185
 186
 187
 188 (defun auto-o-nested-stack (o-match)
 189   ;; Return a list of the overlays that overlap and correspond to same entry
 190   ;; as match overlay O-MATCH, ordered from innermost to outermost. (Assumes
 191   ;; overlays are correctly stacked.) The parent of O-MATCH is guaranteed to
 192   ;; come before any other overlay that has exactly the same length (which
 193   ;; implies they cover identical regions if overlays are correctly
 194   ;; stacked). For other overlays with identical lengths, the order is
 195   ;; undefined.
 196
 197   ;; find overlays corresponding to same entry overlapping O-MATCH
 198   (let ((overlay-stack (auto-overlays-at-point
 199                         (if (eq (auto-o-edge o-match) 'start)
 200                             (overlay-get o-match 'delim-end)
 201                           (overlay-get o-match 'delim-start))
 202                         (list '(eq auto-overlay t)
 203                               (list 'eq 'set-id (overlay-get o-match 'set-id))
 204                               (list 'eq 'definition-id
 205                                     (overlay-get o-match 'definition-id)))))
 206         (o-parent (overlay-get o-match 'parent)))
 207     ;; sort the list by overlay length, i.e. from innermost to outermose
 208     (sort overlay-stack
 209           (lambda (a b)
 210             (let ((len-a (- (overlay-end a) (overlay-start a)))
 211                   (len-b (- (overlay-end b) (overlay-start b))))
 212               ;; parent of O-MATCH comes before any other overlay with
 213               ;; identical length, otherwise sort by length
 214               (if (= len-a len-b) (eq o-parent a) (< len-a len-b)))))
 215     )
 216 )
 217
 218
 219 ;; auto-overlay-nested.el ends here