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

   1 ;;; auto-overlay-flat.el --- flat 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-flat)
  31
  32
  33 ;; set flat overlay parsing and suicide functions, and indicate class requires
  34 ;; separate start and end regexps
  35 (put 'flat 'auto-overlay-parse-function 'auto-o-parse-flat-match)
  36 (put 'flat 'auto-overlay-suicide-function 'auto-o-flat-suicide)
  37 (put 'flat 'auto-overlay-complex-class t)
  38
  39
  40
  41 (defun auto-o-parse-flat-match (o-match)
  42   ;; Perform any necessary updates of auto overlays due to a match for a flat
  43   ;; regexp.
  44
  45   (let (o-parent)
  46     (cond
  47
  48      ;; if match is for a start regexp...
  49      ((eq (auto-o-edge o-match) 'start)
  50       ;; if match is within an existing overlay, ignore match
  51       (unless (auto-overlays-at-point
  52                (overlay-get o-match 'delim-end)  ; FIXME: is this right?
  53                `((identity auto-overlay)
  54                  (eq set-id ,(overlay-get o-match 'set-id))
  55                  (eq definition-id ,(overlay-get o-match 'definition-id))))
  56
  57         ;; otherwise, look for next end-match...
  58         (let ((o-end (auto-o-next-flat-match o-match 'end)))
  59           (cond
  60            ;; if there is one that has a parent, steal start of the parent
  61            ;; overlay
  62            ((and o-end (overlay-get o-end 'parent))
  63             (auto-o-match-overlay (overlay-get o-end 'parent) o-match)
  64             nil)  ; return nil since haven't created any overlays
  65
  66            ;; if there is one but it's parentless, make a new overlay, match
  67            ;; it with O-MATCH and the next end-match, and return it
  68            (o-end
  69             (let ((pos (overlay-get o-match 'delim-end)))
  70               (setq o-parent (make-overlay pos pos nil nil 'rear-advance)))
  71             (overlay-put o-parent 'auto-overlay t)
  72             (overlay-put o-parent 'set-id (overlay-get o-match 'set-id))
  73             (overlay-put o-parent 'definition-id
  74                          (overlay-get o-match 'definition-id))
  75             (auto-o-match-overlay o-parent o-match o-end)
  76             o-parent)
  77
  78            (t ;; otherwise, make a new, end-unmatched overlay and return it
  79             (let ((pos (overlay-get o-match 'delim-end)))
  80               (setq o-parent (make-overlay pos pos nil nil 'read-advance))
  81               (overlay-put o-parent 'auto-overlay t)
  82               (overlay-put o-parent 'set-id (overlay-get o-match 'set-id))
  83               (overlay-put o-parent 'definition-id
  84                            (overlay-get o-match 'definition-id))
  85               (auto-o-match-overlay o-parent o-match 'unmatched)
  86               o-parent))
  87            ))))
  88
  89
  90      (t ;; if match is for an end regexp...
  91       ;; if match is within existing overlay with same set-d and definition-id...
  92       (when (setq o-parent
  93                 (car  ; FIXME: is this right?
  94                  (auto-overlays-at-point
  95                   (overlay-get o-match 'delim-start)  ; FIXME: is this right?
  96                   `((identity auto-overlay)
  97                     (eq set-id ,(overlay-get o-match 'set-id))
  98                     (eq definition-id ,(overlay-get o-match 'definition-id))))))
  99
 100         ;; if overlay can simply be re-matched with new end-match, do so
 101         (let ((o-end (overlay-get o-parent 'end))
 102               (o-start (auto-o-next-flat-match o-match 'start)))
 103           (if (not (and o-end o-start
 104                         (<= (overlay-get o-start 'delim-end)
 105                             (overlay-get o-end 'delim-start))))
 106               (progn (auto-o-match-overlay o-parent nil o-match) nil)
 107
 108             ;; if overlay was end-matched, and there's a start match within
 109             ;; existing overlay that will be "unmasked" when end is stolen,
 110             ;; create a new overlay between that start match and the end match
 111             ;; we're stealing from
 112             (auto-o-match-overlay o-parent nil o-match)
 113             (let ((pos (overlay-get o-start 'delim-end)))
 114               (setq o-parent (make-overlay pos pos nil nil 'read-advance))
 115               (overlay-put o-parent 'auto-overlay t)
 116               (overlay-put o-parent 'set-id (overlay-get o-match 'set-id))
 117               (overlay-put o-parent 'definition-id
 118                            (overlay-get o-match 'definition-id))
 119               (auto-o-match-overlay o-parent o-start o-end))
 120             o-parent))  ; return newly created overlay
 121         ))))
 122 )
 123
 124
 125
 126 (defun auto-o-flat-suicide (o-self)
 127   ;; Called when match no longer matches. Unmatch the match overlay O-SELF,
 128   ;; re-matching or deleting its parent overlay as necessary.
 129
 130   (let ((o-parent (overlay-get o-self 'parent)))
 131     (cond
 132      ;; if we have no parent, don't need to do anything
 133      ((null o-parent))
 134
 135      ;; if we're a start-match...
 136      ((eq (auto-o-edge o-self) 'start)
 137       ;; if parent is end-unmatched, delete parent
 138       (if (null (overlay-get o-parent 'end))
 139           (auto-o-delete-overlay o-parent)
 140
 141         ;; otherwise, look for next start match...
 142         (let ((o-start (auto-o-next-flat-match o-self 'start)))
 143           ;; if there is one, match parent with it
 144           (if o-start
 145               (auto-o-match-overlay o-parent o-start)
 146             ;; otherwise, delete parent
 147             (auto-o-delete-overlay o-parent)))))
 148
 149
 150      (t ;; if we're an end-match, look for next end-match...
 151       (let ((o-start (overlay-get o-parent 'start))
 152             (o-end (auto-o-next-flat-match o-self 'end)))
 153         (cond
 154          ;; if there is one, match parent with it
 155          (o-end
 156           ;; if end-match already has a parent, delete it as its now
 157           ;; superfluous (note: no need to parse, since parent overlay will be
 158           ;; extended to cover same region anyway)
 159           (when (overlay-get o-end 'parent)
 160             (auto-o-delete-overlay (overlay-get o-end 'parent) 'no-parse))
 161           (auto-o-match-overlay o-parent nil o-end))
 162
 163          (t ;; otherwise, make parent end-unmatched
 164           (auto-o-match-overlay o-parent nil 'unmatched)))))
 165      ))
 166 )
 167
 168
 169
 170 (defun auto-o-next-flat-match (o-match edge)
 171   ;; Find first match overlay for EDGE ('start of 'end) after match overlay
 172   ;; O-MATCH in buffer, with same set-id and definition-id as O-MATCH.
 173
 174   ;; get sorted list of matching overlays after O-MATCH
 175   (let ((o-list
 176          (sort (auto-overlays-in
 177                 (overlay-start o-match) (point-max)  ; FIXME: is start right?
 178                 `((identity auto-overlay-match)
 179                   (eq set-id ,(overlay-get o-match 'set-id))
 180                   (eq definition-id ,(overlay-get o-match 'definition-id))
 181                   (,(lambda (set-id definition-id regexp-id edge)
 182                       (eq (auto-o-entry-edge set-id definition-id regexp-id)
 183                           edge))
 184                    (set-id definition-id regexp-id) (,edge))))
 185                (lambda (a b) (<= (overlay-start a) (overlay-start b))))))
 186     ;; if searching for same EDGE as O-MATCH, first overlay in list is always
 187     ;; O-MATCH itself, so we drop it
 188     (if (eq (auto-o-edge o-match) edge) (nth 1 o-list) (car o-list)))
 189 )
 190
 191
 192
 193 ;;; auto-overlay-flat.el ends here