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

   1 ;;; auto-overlay-common.el --- general overlay functions
   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 (provide 'auto-overlay-common)
  30
  31
  32 ;;;###autoload
  33 (defun auto-overlays-at-point (&optional point prop-test inactive)
  34   "Return overlays overlapping POINT
  35 (or the point, if POINT is null). If PROP-TEST is supplied, it
  36 should be a list which specifies a property test with one of the
  37 following forms (or a list of such lists if more than one
  38 property test is required):
  39
  40   (FUNCTION PROPERTY)
  41
  42   (FUNCTION PROPERTY VALUE)
  43
  44   (FUNCTION (PROPERTY1 PROPERTY2 ...) (VALUE1 VALUE2 ...))
  45
  46 where PROPERTY indicates an overlay property name (a symbol), and
  47 VALUE indicates an arbitrary value or lisp expression.
  48
  49 For each overlay overlapping POINT, first the values
  50 corresponding to the property names are retrieved from the
  51 overlay, then FUNCTION is called with the properties values
  52 followed by the other values as its arguments. The test is
  53 satisfied if the result is non-nil, otherwise it fails. Tests are
  54 evaluated in order, but only up to the first failure. Only
  55 overlays that satisfy all property tests are returned.
  56
  57 If INACTIVE is non-nil, both active and inactive overlays are
  58 returned (usually inactive ones are ignored).
  59
  60 Note that this function returns any overlay. If you want to
  61 restrict it to auto overlays, include (identity auto-overlay) in
  62 PROP-TEST."
  63   (when (null point) (setq point (point)))
  64
  65   (let (overlay-list)
  66     ;; get overlays overlapping POINT and zero-length overlays at POINT
  67     (setq overlay-list
  68           (auto-overlays-in point point prop-test nil inactive))
  69     ;; get overlays that end at POINT
  70     (dolist (o (auto-overlays-in (1- point) point prop-test nil inactive))
  71       (when (and (< (overlay-start o) point)
  72                  (= (overlay-end o) point))
  73         (push o overlay-list)))
  74     ;; get overlays that start at POINT
  75     (dolist (o (auto-overlays-in point (1+ point) prop-test nil inactive))
  76       (when (and (> (overlay-end o) point)
  77                  (= (overlay-start o) point))
  78         (push o overlay-list)))
  79
  80     overlay-list))
  81
  82
  83
  84 ;;;###autoload
  85 (defun auto-overlays-in (start end &optional prop-test within inactive)
  86 ;; FIXME: get rid of INACTIVE argument?
  87   "Return auto overlays overlapping region between START and END.
  88
  89 If PROP-TEST is supplied, it should be a list which specifies a
  90 property test with one of the following forms (or a list of such
  91 lists if more than one property test is required):
  92
  93   (FUNCTION PROPERTY)
  94
  95   (FUNCTION PROPERTY VALUE)
  96
  97   (FUNCTION (PROPERTY1 PROPERTY2 ...) (VALUE1 VALUE2 ...))
  98
  99 where PROPERTY indicates an overlay property name (a symbol), and
 100 VALUE indicates an arbitrary value or lisp expression.
 101
 102 For each overlay between START and END, first the values
 103 corresponding to the property names are retrieved from the
 104 overlay, then FUNCTION is called with the properties values
 105 followed by the other values as its arguments. The test is
 106 satisfied if the result is non-nil, otherwise it fails. Tests are
 107 evaluated in order, but only up to the first failure. Only
 108 overlays that satisfy all property tests are returned.
 109
 110 If WITHIN is non-nil, only overlays entirely within START and END
 111 are returned. If INACTIVE is non-nil, both active and inactive
 112 overlays are returned (usually inactive ones are ignored).
 113
 114 Note that this function returns any overlay. If you want to
 115 restrict it to auto overlays, include (identity auto-overlay) in
 116 PROP-TEST."
 117
 118   ;; make sure prop-test is a list of lists, even if there's only one, and
 119   ;; exclude inactive overlays unless told not to
 120   (cond
 121    ((null prop-test)
 122     (unless inactive (setq prop-test '((null inactive)))))
 123    ((functionp (car prop-test))
 124     (if inactive
 125         (setq prop-test (list prop-test))
 126       (setq prop-test (list '(null inactive) prop-test))))
 127    (t
 128     (unless inactive (setq prop-test (push '(null inactive) prop-test)))))
 129
 130   (let (overlay-list function prop-list value-list result)
 131     ;; check properties of each overlay in region
 132     (dolist (o (overlays-in start end))
 133       ;; check overlay is entirely within region
 134       (if (and within
 135                (or (< (overlay-start o) start) (> (overlay-end o) end)))
 136           (setq result nil)
 137
 138         ;; if it is, or we don't care
 139         (setq result t)
 140         (catch 'failed
 141           ;; check if properties match
 142           (dolist (test prop-test)
 143             ;; (Note: the whole thing would be neater with something like
 144             ;; (apply 'and (map ...)) but 'and is a special form, not a
 145             ;; function, so can't be applied)
 146             (setq function (nth 0 test))
 147             (unless (listp (setq prop-list (nth 1 test)))
 148               (setq prop-list (list prop-list)))
 149             (setq value-list nil)
 150             (unless (or (< (length test) 3)
 151                         (and (setq value-list (nth 2 test))  ; nil isn't list
 152                              (listp value-list)))
 153               (setq value-list (list value-list)))
 154
 155             ;; apply the test
 156             (setq result
 157                   (and result
 158                        (apply function
 159                               (append (mapcar (lambda (p) (overlay-get o p))
 160                                               prop-list)
 161                                       value-list))))
 162             (when (null result) (throw 'failed nil)))))
 163
 164       ;; add overlay to result list if its properties matched
 165       (when result (push o overlay-list)))
 166     ;; return result list
 167     overlay-list))
 168
 169
 170
 171 ;;;###autoload
 172 (defun auto-overlay-highest-priority-at-point (&optional point proptest)
 173   "Return highest priority overlay at POINT (defaults to the point).
 174
 175 If two overlays have the same priority, the innermost one takes
 176 precedence (i.e. the one that begins later, or if they begin at
 177 the same point the one that ends earlier).
 178
 179 See `auto-overlays-at' for ane explanation of the PROPTEST argument."
 180
 181   (unless point (setq point (point)))
 182
 183   ;; get all overlays at point with a non-nil SYMBOL property
 184   (let* ((overlay-list (auto-overlays-at-point point proptest))
 185          (overlay (pop overlay-list))
 186          p p1)
 187
 188     ;; find the highest priority, innermost overlay
 189     (dolist (o1 overlay-list)
 190       (setq p (overlay-get overlay 'priority))
 191       (setq p1 (overlay-get o1 'priority))
 192       (when (or (and (null p) p1)
 193                 (and p p1 (> p1 p))
 194                 (and (equal p1 p)
 195                      (or (> (overlay-start o1) (overlay-start overlay))
 196                          (and (= (overlay-start o1) (overlay-start overlay))
 197                               (< (overlay-end o1) (overlay-end o1))))))
 198         (setq overlay o1)))
 199
 200     ;; return the overlay
 201     overlay))
 202
 203
 204
 205 ;;;###autoload
 206 (defun auto-overlay-local-binding (symbol &optional point only-overlay)
 207   "Return \"overlay local \" binding of SYMBOL at POINT,
 208 or the current local binding if there is no overlay binding. If
 209 there is no overlay binding and SYMBOL is not bound, return
 210 nil. POINT defaults to the point.
 211
 212 If ONLY-OVERLAY is non-nil, only overlay bindings are
 213 returned. If none exists at POINT, nil is returned
 214
 215 An \"overlay local\" binding is created by giving an overlay a
 216 non-nil value for a property named SYMBOL. If more than one
 217 overlay at POINT has a non-nil SYMBOL property, the value from
 218 the highest priority overlay is returned.
 219
 220 See `auto-overlay-highest-priority-at-point' for a definition of
 221 \"highest priority\"."
 222
 223   (let ((overlay (auto-overlay-highest-priority-at-point
 224                   point `(identity ,symbol))))
 225     (if overlay
 226         (overlay-get overlay symbol)
 227       (and (not only-overlay) (boundp symbol) (symbol-value symbol)))))
 228
 229 ;; auto-overlay-common.el ends here