diff options
-rw-r--r-- | contrib/mmm/mmm-region.el | 816 |
1 files changed, 816 insertions, 0 deletions
diff --git a/contrib/mmm/mmm-region.el b/contrib/mmm/mmm-region.el new file mode 100644 index 00000000..c6c7a5af --- /dev/null +++ b/contrib/mmm/mmm-region.el @@ -0,0 +1,816 @@ +;;; mmm-region.el --- Manipulating and behavior of MMM submode regions + +;; Copyright (C) 2000 by Michael Abraham Shulman + +;; Author: Michael Abraham Shulman <viritrilbia@users.sourceforge.net> +;; Version: $Id$ + +;;{{{ GPL + +;; 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 2, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;}}} + +;;; Commentary: + +;; This file provides the functions and variables to create, delete, +;; and inspect submode regions, as well as functions that make them +;; behave like the submode with respect to syntax tables, local maps, +;; font lock, etc. + +;; See mmm-class.el for functions which scan the buffer and decide +;; where to create regions. + +;;; Code: + +(require 'cl) +(require 'font-lock) +(require 'mmm-compat) +(require 'mmm-utils) +(require 'mmm-auto) +(require 'mmm-vars) + +;; INSPECTION +;;{{{ Current Overlays + +;; Emacs counts an overlay starting at POS as "at" POS, but not an +;; overlay ending at POS. XEmacs is more sensible and uses beg- and +;; end-stickiness to determine whether an endpoint is within an +;; extent. Here we want to act like XEmacs does. + +(defsubst mmm-overlay-at (&optional pos type) + "Return the highest-priority MMM Mode overlay at POS. +See `mmm-included-p' for the values of TYPE." + (car (mmm-overlays-at pos type))) + +(defun mmm-overlays-at (&optional pos type) + "Return a list of the MMM overlays at POS, in decreasing priority. +See `mmm-included-p' for the values of TYPE." + (or pos (setq pos (point))) + (mmm-sort-overlays + (remove-if-not + #'(lambda (ovl) + (and (overlay-get ovl 'mmm) + (mmm-included-p ovl pos type))) + ;; XEmacs complains about positions outside the buffer + (overlays-in (max (1- pos) (point-min)) + (min (1+ pos) (point-max)))))) + +(defun mmm-included-p (ovl pos &optional type) + "Return true if the overlay OVL contains POS. + +If OVL strictly contains POS, always return true. If OVL starts or +ends at POS, return true or false based on the value of TYPE, which +should be one of nil, `beg', `end', `none', or `all'. +* If TYPE is nil, return true for an overlay starting at POS only if + it is beg-sticky, and for one ending at POS only if it is end-sticky. +* If TYPE is `beg', return true for any overlay starting at POS but + false for any ending at POS. +* If TYPE is `end', return true for any overlay ending at POS but + false for any starting at POS. +* If TYPE is `all', return true for any overlay starting or ending at POS. +* If TYPE is `none' \(or any other value), return false for any + overlay starting or ending at POS." + (let ((beg (overlay-start ovl)) + (end (overlay-end ovl))) + (cond ((and (= beg pos) (= end pos)) + ;; Do the Right Thing for zero-width overlays + (case type + ((nil) (and (overlay-get ovl 'beg-sticky) + (overlay-get ovl 'end-sticky))) + ((none) nil) + (t t))) + ((= beg pos) + (case type + ((nil) (overlay-get ovl 'beg-sticky)) + ((beg all) t) + (t nil))) + ((= end pos) + (case type + ((nil) (overlay-get ovl 'end-sticky)) + ((end all) t) + (t nil))) + ((and (> end pos) (< beg pos)) + t)))) + +;;; `mmm-overlays-in' has been retired as altogether too confusing a +;;; name, when what is really meant is one of the following three: + +(defun mmm-overlays-containing (start stop) + "Return all MMM overlays containing the region START to STOP. +The overlays are returned in order of decreasing priority. No +attention is paid to stickiness." + (mmm-sort-overlays + (remove-if-not + #'(lambda (ovl) + (and (overlay-get ovl 'mmm) + (<= (overlay-start ovl) start) + (>= (overlay-end ovl) stop))) + (overlays-in (max start (point-min)) + (min stop (point-max)))))) + +(defun mmm-overlays-contained-in (start stop) + "Return all MMM overlays entirely contained in START to STOP. +The overlays are returned in order of decreasing priority. No +attention is paid to stickiness." + (mmm-sort-overlays + (remove-if-not + #'(lambda (ovl) + (and (overlay-get ovl 'mmm) + (>= (overlay-start ovl) start) + (<= (overlay-end ovl) stop))) + (overlays-in (max start (point-min)) + (min stop (point-max)))))) + +(defun mmm-overlays-overlapping (start stop) + "Return all MMM overlays overlapping the region START to STOP. +The overlays are returned in order of decreasing priority. No +attention is paid to stickiness." + (mmm-sort-overlays + (remove-if-not + #'(lambda (ovl) + (overlay-get ovl 'mmm)) + (overlays-in (max start (point-min)) + (min stop (point-max)))))) + +(defun mmm-sort-overlays (overlays) + "Sort OVERLAYS in order of decreasing priority." + (sort (copy-list overlays) + #'(lambda (x y) (> (or (overlay-get x 'priority) 0) + (or (overlay-get y 'priority) 0))))) + +;;}}} +;;{{{ Current Submode + +(defvar mmm-current-overlay nil + "What submode region overlay we think we are currently in. +May be out of date; call `mmm-update-current-submode' to correct it.") +(make-variable-buffer-local 'mmm-current-overlay) + +(defvar mmm-previous-overlay nil + "What submode region overlay we were in just before this one. +Set by `mmm-update-current-submode'.") +(make-variable-buffer-local 'mmm-previous-overlay) + +(defvar mmm-current-submode nil + "What submode we think we are currently in. +May be out of date; call `mmm-update-current-submode' to correct it.") +(make-variable-buffer-local 'mmm-current-submode) + +(defvar mmm-previous-submode nil + "What submode we were in just before this one. +Set by `mmm-update-current-submode'.") +(make-variable-buffer-local 'mmm-previous-submode) + +(defun mmm-update-current-submode (&optional pos) + "Update current and previous position variables to POS, or point. +Return non-nil if the current region changed. + +Also deletes overlays that ought to evaporate because their delimiters +have disappeared." + (mapc #'delete-overlay + (remove-if #'(lambda (ovl) + (or (not (eq (overlay-get ovl 'mmm-evap) 'front)) + (overlay-buffer (overlay-get ovl 'front)))) + (mmm-overlays-at pos))) + (let ((ovl (mmm-overlay-at pos))) + (if (eq ovl mmm-current-overlay) + nil + (setq mmm-previous-overlay mmm-current-overlay + mmm-previous-submode mmm-current-submode) + (setq mmm-current-overlay ovl + mmm-current-submode (if ovl (overlay-get ovl 'mmm-mode))) + t))) + +;; This function is, I think, mostly for hacking font-lock. +(defun mmm-set-current-submode (mode &optional pos) + "Set the current submode to MODE and the current region to whatever +region of that mode is present at POS, or nil if none." + (setq mmm-previous-overlay mmm-current-overlay + mmm-previous-submode mmm-current-submode) + (setq mmm-current-submode mode + mmm-current-overlay + (find-if #'(lambda (ovl) + (eq (overlay-get ovl 'mmm-mode) mode)) + (mmm-overlays-at (or pos (point)) 'all)))) + +(defun mmm-submode-at (&optional pos type) + "Return the submode at POS \(or point), or NIL if none. +See `mmm-included-p' for values of TYPE." + (let ((ovl (mmm-overlay-at pos type))) + (if ovl (overlay-get ovl 'mmm-mode)))) + +;;}}} +;;{{{ Delimiter Matching and Boundaries + +(defun mmm-match-front (ovl) + "Return non-nil if the front delimiter of OVL matches as it should. +Sets the match data to the front delimiter, if it is a regexp. +Otherwise, calls it as a function with point at the beginning of the +front delimiter overlay \(i.e. where the front delimiter ought to +start) and one argument being the region overlay. The function should +return non-nil if the front delimiter matches correctly, and set the +match data appropriately." + (let* ((front-ovl (overlay-get ovl 'front)) + (front (if front-ovl (overlay-get front-ovl 'match)))) + (when front + (save-excursion + (goto-char (overlay-start front-ovl)) + (if (stringp front) + ;; It's a regexp + (looking-at front) + ;; It's a function + (funcall front ovl)))))) + +(defun mmm-match-back (ovl) + "Return non-nil if the back delimiter of OVL matches as it should. +Sets the match data to the back delimiter, if it is a regexp. +Otherwise, calls it as a function with point at the beginning of the +back delimiter overlay \(i.e. where the back delimiter ought to start) +and one argument being the region overlay. The function should return +non-nil if the back delimiter matches correctly, and set the match +data appropriately." + (let* ((back-ovl (overlay-get ovl 'back)) + (back (if back-ovl (overlay-get back-ovl 'match)))) + (when back + (save-excursion + (goto-char (overlay-start back-ovl)) + (if (stringp back) + ;; It's a regexp + (looking-at back) + ;; It's a function + (funcall back ovl)))))) + +(defun mmm-front-start (ovl) + "Return the position at which the front delimiter of OVL starts." + (let ((front (overlay-get ovl 'front))) + ;; Overlays which have evaporated become "overlays in no buffer" + (if (and front (overlay-buffer front)) + (overlay-start front) + (overlay-start ovl)))) + +(defun mmm-back-end (ovl) + "Return the position at which the back delimiter of OVL ends." + (let ((back (overlay-get ovl 'back))) + ;; Overlays which have evaporated become "overlays in no buffer" + (if (and back (overlay-buffer back)) + (overlay-end back) + (overlay-end ovl)))) + +;;}}} + +;; CREATION & DELETION +;;{{{ Make Submode Regions + +(defun mmm-valid-submode-region (submode beg end) + "Check if the region between BEG and END is valid for SUBMODE. +This region must be entirely contained within zero or more existing +submode regions, none of which start or end inside it, and it must be +a valid child of the highest-priority of those regions, if any. +Signals errors, returns `t' if no error." + ;; First check if the placement is valid. Every existing region + ;; that overlaps this one must contain it in its entirety. + (let ((violators (set-difference + (mmm-overlays-overlapping beg end) + (mmm-overlays-containing beg end)))) + (if violators + (signal 'mmm-subregion-invalid-placement + violators))) + ;; Now check if it is inside a valid parent + (let ((parent-mode (mmm-submode-at beg 'beg))) + (and parent-mode + ;; TODO: Actually check parents here. For present purposes, + ;; we just make sure we aren't putting a submode inside one + ;; of the same type. Actually, what we should really be + ;; doing is checking classes/names of regions, not just the + ;; submodes. + (eq submode parent-mode) + (signal 'mmm-subregion-invalid-parent + (list parent-mode)))) + t) + +(defun* mmm-make-region + (submode beg end &key face + front back (evaporation 'front) + delimiter-mode front-face back-face + display-name + (match-front "") (match-back "") + (beg-sticky t) (end-sticky t) + name creation-hook + ) + "Make a submode region from BEG to END of SUBMODE. + +BEG and END are buffer positions or markers with BEG <= END \(although +see EVAPORATION below). SUBMODE is a major mode function or a valid +argument to `mmm-modename->function'. FACE is a valid display face. + +FRONT and BACK specify the positions of the front and back delimiters +for this region, if any. If FRONT is a buffer position or marker, the +front delimiter runs from it to BEG. FRONT can also be a two-element +list \(FRONT-BEG FRONT-END) specifying the exact position of the front +delimiter. One must have FRONT-BEG < FRONT-END <= BEG. + +Similarly, BACK may be a buffer position or marker, in which case the +back delimiter runs from END to BACK. BACK can also be a two-element +list \(BACK-BEG BACK-END) specifying the exact position, in which case +we must have END <= BACK-BEG < BACK-END. + +EVAPORATION specifies under what conditions this submode region should +disappear. +* If `nil', the region never disappears. This can cause serious + problems when using cut-and-paste and is not recommended. +* If the value is t, the region disappears whenever it has zero + length. This is recommended for manually created regions used for + temporary editing convenience. +* If the value is `front', the region will disappear whenever the text + in its front delimiter disappears, that is, whenever the overlay + which marks its front delimiter has zero width. +The default value is `front'. However, if the parameter FRONT is nil, +then this makes no sense, so the default becomes `t'. Note that if +EVAPORATION is `t', then an error is signalled if BEG = END. + +MATCH-FRONT \(resp. MATCH-BACK) is a regexp or function to match the +correct delimiters, see `mmm-match-front' \(resp. `mmm-match-back'). +It is ignored if FRONT \(resp. BACK) is nil. At present these are not +used much. + +DELIMITER-MODE specifies the major mode to use for delimiter regions. +A `nil' value means they remain in the primary mode. + +FACE, FRONT-FACE, and BACK-FACE, are faces to use for the region, the +front delimiter, and the back delimiter, respectively, under high +decoration \(see `mmm-submode-decoration-level'). + +BEG-STICKY and END-STICKY determine whether the front and back of the +region, respectively, are sticky with respect to new insertion. The +default is yes. + +NAME is a string giving the \"name\" of this submode region. Submode +regions with the same name are considered part of the same code +fragment and formatted accordingly. + +DISPLAY-NAME is a string to display in the mode line when point is in +this submode region. If nil or not given, the name associated with +SUBMODE is used. In delimiter regions, \"--\" is shown. + +CREATION-HOOK should be a function to run after the region is created, +with point at the start of the new region." + ;; Check placement of region and delimiters + (unless (if (eq evaporation t) + (< beg end) + (<= beg end)) + (signal 'mmm-subregion-invalid-placement (list beg end))) + (when front + (unless (listp front) + (setq front (list front beg))) + (unless (and (< (car front) (cadr front)) + (<= (cadr front) beg)) + (signal 'mmm-subregion-invalid-placement front))) + (when back + (unless (listp back) + (setq back (list end back))) + (unless (and (< (car back) (cadr back)) + (<= end (car back))) + (signal 'mmm-subregion-invalid-placement back))) + (setq submode (mmm-modename->function submode)) + ;; Check embedding in existing regions + (mmm-valid-submode-region submode beg end) + (mmm-mode-on) + (when submode + (mmm-update-mode-info submode)) + (and (not front) (eq evaporation 'front) (setq evaporation t)) + (let ((region-ovl + (mmm-make-overlay submode beg end name face beg-sticky end-sticky + (or (eq evaporation t) nil) display-name))) + ;; Save evaporation type for checking later + (overlay-put region-ovl 'mmm-evap evaporation) + ;; Calculate priority to supersede anything already there. + (overlay-put region-ovl 'priority (length (mmm-overlays-at beg))) + ;; Make overlays for the delimiters, with appropriate pointers. + (when front + (let ((front-ovl + (mmm-make-overlay delimiter-mode (car front) (cadr front) + nil front-face nil nil t "--" t))) + (overlay-put region-ovl 'front front-ovl) + (overlay-put front-ovl 'region region-ovl) + (overlay-put front-ovl 'match match-front))) + (when back + (let ((back-ovl + (mmm-make-overlay delimiter-mode (car back) (cadr back) + nil back-face nil nil t "--" t))) + (overlay-put region-ovl 'back back-ovl) + (overlay-put back-ovl 'region region-ovl) + (overlay-put back-ovl 'match match-back))) + ;; Update everything and run all the hooks + (mmm-save-all + (goto-char (overlay-start region-ovl)) + (mmm-set-current-submode submode) + (mmm-set-local-variables submode) + (mmm-run-submode-hook submode) + (when creation-hook + (funcall creation-hook)) + (mmm-save-changed-local-variables region-ovl submode)) + (setq mmm-previous-submode submode + mmm-previous-overlay region-ovl) + (mmm-update-submode-region) + region-ovl)) + +(defun mmm-make-overlay (submode beg end name face beg-sticky end-sticky evap + &optional display-name delim) + "Internal function to make submode overlays. +Does not handle delimiters. Use `mmm-make-region'." + (let ((ovl (make-overlay beg end nil (not beg-sticky) end-sticky))) + (mapc + #'(lambda (pair) (overlay-put ovl (car pair) (cadr pair))) + `((mmm t) ; Mark all submode overlays + (mmm-mode ,submode) + ,@(if delim '((delim t)) nil) + (mmm-local-variables + ;; Have to be careful to make new list structure here + ,(list* (list 'font-lock-cache-state nil) + (list 'font-lock-cache-position (make-marker)) + (copy-tree + (cdr (assq submode mmm-region-saved-locals-defaults))))) + (name ,name) + (display-name ,display-name) + ;; Need to save these, because there's no way of accessing an + ;; overlay's official "front-advance" parameter once it's created. + (beg-sticky ,beg-sticky) + (end-sticky ,end-sticky) + ;; These have special meaning to Emacs + (,mmm-evaporate-property ,evap) + (face ,(mmm-get-face face submode delim)) + )) + ovl)) + +(defun mmm-get-face (face submode &optional delim) + (cond ((= mmm-submode-decoration-level 0) nil) + ((and (= mmm-submode-decoration-level 2) face) face) + (delim 'mmm-delimiter-face) + (submode 'mmm-default-submode-face))) + +;;}}} +;;{{{ Clear Overlays + +;; See also `mmm-clear-current-region'. + +(defun mmm-clear-overlays (&optional start stop strict) + "Clears all MMM overlays overlapping START and STOP. +If STRICT, only clear those entirely included in that region." + (mapc #'delete-overlay + (if strict + (mmm-overlays-contained-in (or start (point-min)) + (or stop (point-max))) + (mmm-overlays-overlapping (or start (point-min)) + (or stop (point-max))))) + (mmm-update-submode-region)) + +;;}}} + +;; BASIC UPDATING +;;{{{ Submode Info + +(defun mmm-update-mode-info (mode &optional force) + "Save the global-saved and buffer-saved variables for MODE. +Global saving is done on properties of the symbol MODE and buffer +saving in `mmm-buffer-saved-locals'. This function must be called for +both the dominant mode and all submodes, in each file. Region-saved +variables are initialized from `mmm-region-saved-locals-defaults', +which is set here as well. See `mmm-save-local-variables'. If FORCE +is non-nil, don't quit if the info is already there." + (let ((buffer-entry (assq mode mmm-buffer-saved-locals)) + (region-entry (assq mode mmm-region-saved-locals-defaults)) + global-vars buffer-vars region-vars + ;; kludge for XEmacs 20 + (html-helper-build-new-buffer nil)) + (unless (and (not force) + (get mode 'mmm-local-variables) + buffer-entry + region-entry) + (save-excursion + (let ((filename (buffer-file-name))) + ;; On errors, the temporary buffers don't get deleted, so here + ;; we get rid of any old ones that may be hanging around. + (when (buffer-live-p (get-buffer mmm-temp-buffer-name)) + (with-current-buffer (get-buffer mmm-temp-buffer-name) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)))) + ;; Now make a new temporary buffer. + (set-buffer (mmm-make-temp-buffer (current-buffer) + mmm-temp-buffer-name)) + ;; Handle stupid modes that need the file name set + (if (memq mode mmm-set-file-name-for-modes) + (setq buffer-file-name filename))) + (funcall mode) + (when (featurep 'font-lock) + ;; XEmacs doesn't have global-font-lock-mode (or rather, it + ;; has nothing but global-font-lock-mode). + (when (or mmm-xemacs + ;; Code copied from font-lock.el to detect when font-lock + ;; should be on via global-font-lock-mode. + (and (or font-lock-defaults + (with-no-warnings + (assq major-mode font-lock-defaults-alist)) + (assq major-mode font-lock-keywords-alist)) + (or (eq font-lock-global-modes t) + (if (eq (car-safe font-lock-global-modes) 'not) + (not (memq major-mode + (cdr font-lock-global-modes))) + (memq major-mode font-lock-global-modes))))) + ;; Don't actually fontify in the temp buffer, but note + ;; that we should fontify when we use this mode. + (put mode 'mmm-font-lock-mode t)) + ;; Get the font-lock variables + (when mmm-font-lock-available-p + ;; To fool `font-lock-add-keywords' + (let ((font-lock-mode t)) + (mmm-set-font-lock-defaults))) + ;; These can't be in the local variables list, because we + ;; replace their actual values, but we want to use their + ;; original values elsewhere. + (unless (and mmm-xemacs (= emacs-major-version 20)) + ;; XEmacs 20 doesn't have this variable. This effectively + ;; prevents the MMM font-lock support from working, but we + ;; just ignore it and go on, to prevent an error message. + (put mode 'mmm-fontify-region-function + font-lock-fontify-region-function)) + (put mode 'mmm-beginning-of-syntax-function + font-lock-beginning-of-syntax-function)) + ;; Get variables + (setq global-vars (mmm-get-locals 'global) + buffer-vars (mmm-get-locals 'buffer) + region-vars (mmm-get-locals 'region)) + (put mode 'mmm-mode-name mode-name) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (put mode 'mmm-local-variables global-vars) + (if buffer-entry + (setcdr buffer-entry buffer-vars) + (push (cons mode buffer-vars) mmm-buffer-saved-locals)) + (if region-entry + (setcdr region-entry region-vars) + (push (cons mode region-vars) + mmm-region-saved-locals-defaults))))) + +;;}}} +;;{{{ Updating Hooks + +(defun mmm-update-submode-region () + "Update all MMM properties correctly for the current position. +This function and those it calls do the actual work of setting the +different keymaps, syntax tables, local variables, etc. for submodes." + (when (mmm-update-current-submode) + (mmm-save-changed-local-variables mmm-previous-overlay + mmm-previous-submode) + (let ((mode (or mmm-current-submode mmm-primary-mode))) + (mmm-update-mode-info mode) + (mmm-set-local-variables mode) + (mmm-enable-font-lock mode)) + (mmm-set-mode-line) + (dolist (func (if mmm-current-overlay + (overlay-get mmm-current-overlay 'entry-hook) + mmm-primary-mode-entry-hook)) + (ignore-errors (funcall func))))) + +(defun mmm-add-hooks () + (add-hook 'post-command-hook 'mmm-update-submode-region nil 'local)) + +(defun mmm-remove-hooks () + (remove-hook 'post-command-hook 'mmm-update-submode-region 'local)) + +;;}}} +;;{{{ Local Variables + +(defun mmm-get-local-variables-list (type mode) + "Filter `mmm-save-local-variables' to match TYPE and MODE. +Return a list \(VAR ...). In some cases, VAR will be a cons cell +\(GETTER . SETTER) -- see `mmm-save-local-variables'." + (mapcan #'(lambda (element) + (and (if (and (consp element) + (cdr element) + (cadr element)) + (eq (cadr element) type) + (eq type 'global)) + (if (and (consp element) + (cddr element) + (not (eq (caddr element) t))) + (if (functionp (caddr element)) + (funcall (caddr element)) + (member mode (caddr element))) + t) + (list (if (consp element) (car element) element)))) + mmm-save-local-variables)) + +(defun mmm-get-locals (type) + "Get the local variables and values for TYPE from this buffer. +Return \((VAR VALUE) ...). In some cases, VAR will be of the form +\(GETTER . SETTER) -- see `mmm-save-local-variables'." + (mapcan #'(lambda (var) + (if (consp var) + `((,var ,(funcall (car var)))) + (and (boundp var) + ;; This seems logical, but screws things up. + ;;(local-variable-p var) + `((,var ,(symbol-value var)))))) + (mmm-get-local-variables-list type major-mode))) + +(defun mmm-get-saved-local (mode var) + "Get the value of the local variable VAR saved for MODE, if any." + (cadr (assq var (mmm-get-saved-local-variables mode)))) + +(defun mmm-set-local-variables (mode) + "Set all the local variables saved for MODE. +Looks up both global, buffer, and region saves." + (mapcar #'(lambda (var) + ;; (car VAR) may be (GETTER . SETTER) + (if (consp (car var)) + (funcall (cdar var) (cadr var)) + (make-local-variable (car var)) + (set (car var) (cadr var)))) + (mmm-get-saved-local-variables mode))) + +(defun mmm-get-saved-local-variables (mode) + (append (get mode 'mmm-local-variables) + (cdr (assq mode mmm-buffer-saved-locals)) + (let ((ovl (mmm-overlay-at (point)))) + (if ovl + (overlay-get ovl 'mmm-local-variables) + mmm-region-saved-locals-for-dominant)))) + +(defun mmm-save-changed-local-variables (ovl mode) + "Save by-buffer and by-region variables for OVL and MODE. +Called when we move to a new submode region, with OVL and MODE the +region and mode for the previous position." + (let ((buffer-vars (cdr (assq (or mode mmm-primary-mode) + mmm-buffer-saved-locals))) + (region-vars (if ovl + (overlay-get ovl 'mmm-local-variables) + mmm-region-saved-locals-for-dominant)) + (set-local-value + #'(lambda (var) + (setcar (cdr var) + ;; (car VAR) may be (GETTER . SETTER) + (if (consp (car var)) + (funcall (caar var)) + (symbol-value (car var))))))) + (mapc set-local-value buffer-vars) + (mapc set-local-value region-vars))) + +(defun mmm-clear-local-variables () + "Clear all buffer- and region-saved variables for current buffer." + (setq mmm-buffer-saved-locals () + mmm-region-saved-locals-defaults () + mmm-region-saved-locals-for-dominant ())) + +;;}}} + +;; FONT LOCK +;;{{{ Enable Font Lock + +(defun mmm-enable-font-lock (mode) + "Turn on font lock if it is not already on and MODE enables it." + (mmm-update-mode-info mode) + (and mmm-font-lock-available-p + (not font-lock-mode) + (get mode 'mmm-font-lock-mode) + (font-lock-mode 1))) + +(defun mmm-update-font-lock-buffer () + "Turn on font lock iff any mode in the buffer enables it." + (when mmm-font-lock-available-p + (if (some #'(lambda (mode) + (get mode 'mmm-font-lock-mode)) + (cons mmm-primary-mode + (mapcar #'(lambda (ovl) + (overlay-get ovl 'mmm-mode)) + (mmm-overlays-overlapping + (point-min) (point-max))))) + (font-lock-mode 1) + (font-lock-mode 0)))) + +(defun mmm-refontify-maybe (&optional start stop) + "Re-fontify from START to STOP, or entire buffer, if enabled." + (and font-lock-mode + (if (or start stop) + (font-lock-fontify-region (or start (point-min)) + (or stop (point-max))) + (font-lock-fontify-buffer)))) + +;;}}} +;;{{{ Get Submode Regions + +;;; In theory, these are general functions that have nothing to do +;;; with font-lock, but they aren't used anywhere else, so we might as +;;; well have them close. + +(defun mmm-submode-changes-in (start stop) + "Return a list of all submode-change positions from START to STOP. +The list is sorted in order of increasing buffer position." + (sort (remove-duplicates + (list* start stop + (mapcan #'(lambda (ovl) + `(,(overlay-start ovl) + ,(overlay-end ovl))) + (mmm-overlays-overlapping start stop)))) + #'<)) + +(defun mmm-regions-in (start stop &optional flag delim) + "Return a list of regions of the form (MODE BEG END) whose disjoint +union covers the region from START to STOP, including delimiters." + (let ((regions + (maplist #'(lambda (pos-list) + (if (cdr pos-list) + (list (or (mmm-submode-at (car pos-list) 'beg) + mmm-primary-mode) + (car pos-list) (cadr pos-list)))) + (mmm-submode-changes-in start stop)))) + (setcdr (last regions 2) nil) + regions)) + + +(defun mmm-regions-alist (start stop) + "Return a list of lists of the form \(MODE . REGIONS) where REGIONS +is a list of elements of the form \(BEG END). The disjoint union all +of the REGIONS covers START to STOP." + (let ((regions (mmm-regions-in start stop))) + (mapcar #'(lambda (mode) + (cons mode + (mapcan #'(lambda (region) + (if (eq mode (car region)) + (list (cdr region)))) + regions))) + ;; All the modes + (remove-duplicates (mapcar #'car regions))))) + +;;}}} +;;{{{ Fontify Regions + +(defun mmm-fontify-region (start stop &optional loudly) + "Fontify from START to STOP keeping track of submodes correctly." + (when loudly + (message "Fontifying %s with submode regions..." (buffer-name))) + ;; Necessary to catch changes in font-lock cache state and position. + (mmm-save-changed-local-variables + mmm-current-overlay mmm-current-submode) + ;; For some reason `font-lock-fontify-block' binds this to nil, thus + ;; preventing `mmm-beginning-of-syntax' from doing The Right Thing. + ;; I don't know why it does this, but let's undo it here. + (let ((font-lock-beginning-of-syntax-function 'mmm-beginning-of-syntax)) + (mapc #'(lambda (elt) + (when (get (car elt) 'mmm-font-lock-mode) + (mmm-fontify-region-list (car elt) (cdr elt)))) + (mmm-regions-alist start stop))) + ;; With jit-lock, this causes blips in the mode line and menus. + ;; Shouldn't be necessary here, since it's in post-command-hook too. + ;;(mmm-update-submode-region) + (when loudly (message nil))) + +(defun mmm-fontify-region-list (mode regions) + "Fontify REGIONS, each like \(BEG END), in mode MODE." + (save-excursion + (let (;(major-mode mode) + (func (get mode 'mmm-fontify-region-function))) + (mapc #'(lambda (reg) + (goto-char (car reg)) + ;; Here we do the same sort of thing that + ;; `mmm-update-submode-region' does, but we force it + ;; to use a specific mode, and don't save anything, + ;; fontify, or change the mode line. + (mmm-set-current-submode mode) + (mmm-set-local-variables mode) + (funcall func (car reg) (cadr reg) nil) + ;; Catch changes in font-lock cache. + (mmm-save-changed-local-variables + mmm-current-overlay mmm-current-submode)) + regions)))) + +;;}}} +;;{{{ Beginning of Syntax + +(defun mmm-beginning-of-syntax () + (goto-char + (let ((ovl (mmm-overlay-at (point))) + (func (get (or mmm-current-submode mmm-primary-mode) + 'mmm-beginning-of-syntax-function))) + (max (if ovl (overlay-start ovl) (point-min)) + (if func (progn (funcall func) (point)) (point-min)) + (point-min))))) + +;;}}} + +(provide 'mmm-region) + +;;; mmm-region.el ends here
\ No newline at end of file |