;;; auto-overlay-flat.el --- flat start/end-delimited automatic overlays -*- lexical-binding: t; -*- ;; Copyright (C) 2005-2020 Free Software Foundation, Inc ;; Author: Toby Cubitt ;; Maintainer: Toby Cubitt ;; URL: http://www.dr-qubit.org/emacs.php ;; Repository: http://www.dr-qubit.org/git/predictive.git ;; This file is part of the Emacs. ;; ;; This file 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. ;; ;; This program 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 this program. If not, see . ;;; Code: (provide 'auto-overlay-flat) (require 'auto-overlays) ;; set flat overlay parsing and suicide functions, and indicate class requires ;; separate start and end regexps (put 'flat 'auto-overlay-parse-function #'auto-o-parse-flat-match) (put 'flat 'auto-overlay-suicide-function #'auto-o-flat-suicide) (put 'flat 'auto-overlay-complex-class t) (defun auto-o-parse-flat-match (o-match) ;; Perform any necessary updates of auto overlays due to a match for a flat ;; regexp. (let (o-parent) (cond ;; if match is for a start regexp... ((eq (auto-o-edge o-match) 'start) ;; if match is within an existing overlay, ignore match (unless (auto-overlays-at-point (overlay-get o-match 'delim-end) ; FIXME: is this right? `(eq set-id ,(overlay-get o-match 'set-id)) `(eq definition-id ,(overlay-get o-match 'definition-id))) ;; otherwise, look for next end-match... (let ((o-end (auto-o-next-flat-match o-match 'end))) (cond ;; if there is one that has a parent, steal start of the parent ;; overlay ((and o-end (overlay-get o-end 'parent)) (auto-o-match-overlay (overlay-get o-end 'parent) o-match) nil) ; return nil since haven't created any overlays ;; if there is one but it's parentless, make a new overlay, match ;; it with O-MATCH and the next end-match, and return it (o-end (let ((pos (overlay-get o-match 'delim-end))) (setq o-parent (make-overlay pos pos nil nil 'rear-advance))) (overlay-put o-parent 'auto-overlay t) (overlay-put o-parent 'set-id (overlay-get o-match 'set-id)) (overlay-put o-parent 'definition-id (overlay-get o-match 'definition-id)) (auto-o-match-overlay o-parent o-match o-end) o-parent) (t ;; otherwise, make a new, end-unmatched overlay and return it (let ((pos (overlay-get o-match 'delim-end))) (setq o-parent (make-overlay pos pos nil nil 'read-advance)) (overlay-put o-parent 'auto-overlay t) (overlay-put o-parent 'set-id (overlay-get o-match 'set-id)) (overlay-put o-parent 'definition-id (overlay-get o-match 'definition-id)) (auto-o-match-overlay o-parent o-match 'unmatched) o-parent)) )))) (t ;; if match is for an end regexp... ;; if match is within existing overlay with same set-d and definition-id... (when (setq o-parent (car ; FIXME: is this right? (sort (auto-overlays-at-point (overlay-get o-match 'delim-start) ; FIXME: is this right? `(eq set-id ,(overlay-get o-match 'set-id)) `(eq definition-id ,(overlay-get o-match 'definition-id))) #'auto-overlay-<))) ;; if overlay can simply be re-matched with new end-match, do so (let ((o-end (overlay-get o-parent 'end)) (o-start (auto-o-next-flat-match o-match 'start))) (if (not (and o-end o-start (<= (overlay-get o-start 'delim-end) (overlay-get o-end 'delim-start)))) (progn (auto-o-match-overlay o-parent nil o-match) nil) ;; if overlay was end-matched, and there's a start match within ;; existing overlay that will be "unmasked" when end is stolen, ;; create a new overlay between that start match and the end match ;; we're stealing from (auto-o-match-overlay o-parent nil o-match) (let ((pos (overlay-get o-start 'delim-end))) (setq o-parent (make-overlay pos pos nil nil 'read-advance)) (overlay-put o-parent 'auto-overlay t) (overlay-put o-parent 'set-id (overlay-get o-match 'set-id)) (overlay-put o-parent 'definition-id (overlay-get o-match 'definition-id)) (auto-o-match-overlay o-parent o-start o-end)) o-parent)) ; return newly created overlay )))) ) (defun auto-o-flat-suicide (o-self) ;; Called when match no longer matches. Unmatch the match overlay O-SELF, ;; re-matching or deleting its parent overlay as necessary. (let ((o-parent (overlay-get o-self 'parent))) (cond ;; if we have no parent, don't need to do anything ((null o-parent)) ;; if we're a start-match... ((eq (auto-o-edge o-self) 'start) ;; if parent is end-unmatched, delete parent (if (null (overlay-get o-parent 'end)) (auto-o-delete-overlay o-parent) ;; otherwise, look for next start match... (let ((o-start (auto-o-next-flat-match o-self 'start))) ;; if there is one, match parent with it (if o-start (auto-o-match-overlay o-parent o-start) ;; otherwise, delete parent (auto-o-delete-overlay o-parent))))) (t ;; if we're an end-match, look for next end-match... (let ((o-end (auto-o-next-flat-match o-self 'end))) (cond ;; if there is one, match parent with it (o-end ;; if end-match already has a parent, delete it as its now ;; superfluous (note: no need to parse, since parent overlay will be ;; extended to cover same region anyway) (when (overlay-get o-end 'parent) (auto-o-delete-overlay (overlay-get o-end 'parent) 'no-parse)) (auto-o-match-overlay o-parent nil o-end)) (t ;; otherwise, make parent end-unmatched (auto-o-match-overlay o-parent nil 'unmatched))))) )) ) (defun auto-o-next-flat-match (o-match edge) ;; Find first match overlay for EDGE ('start of 'end) after match overlay ;; O-MATCH in buffer, with same set-id and definition-id as O-MATCH. ;; get sorted list of matching overlays after O-MATCH (let ((o-list (sort (auto-overlays-in (overlay-start o-match) (point-max) ; FIXME: is start right? '(identity auto-overlay-match) `(eq set-id ,(overlay-get o-match 'set-id)) `(eq definition-id ,(overlay-get o-match 'definition-id)) (list (lambda (set-id definition-id regexp-id edge) (eq (auto-o-regexp-edge set-id definition-id regexp-id) edge)) '(set-id definition-id regexp-id) (list edge))) #'auto-overlay-<))) ;; if searching for same EDGE as O-MATCH, first overlay in list is always ;; O-MATCH itself, so we drop it (if (eq (auto-o-edge o-match) edge) (nth 1 o-list) (car o-list)))) ;;; auto-overlay-flat.el ends here