mmm-mode-0.4.8/mmm-class.el

   1 ;;; mmm-class.el --- MMM submode class variables and functions
   2
   3 ;; Copyright (C) 2000, 2004 by Michael Abraham Shulman
   4
   5 ;; Author: Michael Abraham Shulman <viritrilbia@users.sourceforge.net>
   6 ;; Version: $Id: mmm-class.el,v 1.19 2004/06/11 00:31:07 alanshutko Exp $
   7
   8 ;;{{{ GPL
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;}}}
  26
  27 ;;; Commentary:
  28
  29 ;; This file contains variable and function definitions for
  30 ;; manipulating and applying MMM submode classes. See `mmm-vars.el'
  31 ;; for variables that list classes.
  32
  33 ;;; Code:
  34
  35 (require 'cl)
  36 (require 'mmm-vars)
  37 (require 'mmm-region)
  38
  39 ;;; CLASS SPECIFICATIONS
  40 ;;{{{ Get Class Specifications
  41
  42 (defun mmm-get-class-spec (class)
  43   "Get the class specification for CLASS.
  44 CLASS can be either a symbol to look up in `mmm-classes-alist' or a
  45 class specifier itself."
  46   (cond ((symbolp class)        ; A symbol must be looked up
  47          (or (cdr (assq class mmm-classes-alist))
  48              (and (cadr (assq class mmm-autoloaded-classes))
  49                   (load (cadr (assq class mmm-autoloaded-classes)))
  50                   (cdr (assq class mmm-classes-alist)))
  51              (signal 'mmm-invalid-submode-class (list class))))
  52         ((listp class)          ; A list must be a class spec
  53          class)
  54         (t (signal 'mmm-invalid-submode-class (list class)))))
  55
  56 ;;}}}
  57 ;;{{{ Get and Set Class Parameters
  58
  59 (defun mmm-get-class-parameter (class param)
  60   "Get the value of the parameter PARAM for CLASS, or nil if none."
  61   (cadr (member param (mmm-get-class-spec class))))
  62
  63 (defun mmm-set-class-parameter (class param value)
  64   "Set the value of the parameter PARAM for CLASS to VALUE.
  65 Creates a new parameter if one is not present."
  66   (let* ((spec (mmm-get-class-spec class))
  67          (current (member param spec)))
  68     (if current
  69         (setcar (cdr current) value)
  70       (nconc spec (list param value)))))
  71
  72 ;;}}}
  73 ;;{{{ Apply Classes
  74
  75 (defun* mmm-apply-class
  76     (class &optional (start (point-min)) (stop (point-max)) face)
  77   "Apply the submode class CLASS from START to STOP in FACE.
  78 If FACE is nil, the face for CLASS is used, or the default face if
  79 none is specified by CLASS."
  80   ;; The "special" class t means do nothing. It is used to turn on
  81   ;; MMM Mode without applying any classes.
  82   (unless (eq class t)
  83     (apply #'mmm-ify :start start :stop stop
  84            (append (mmm-get-class-spec class)
  85                   (list :face face)))
  86     (mmm-run-class-hook class)
  87     ;; Hack in case class hook sets mmm-buffer-mode-display-name etc.
  88     (mmm-set-mode-line)))
  89
  90 (defun* mmm-apply-classes
  91     (classes &key (start (point-min)) (stop (point-max)) face)
  92   "Apply all submode classes in CLASSES, in order.
  93 All classes are applied regardless of any errors that may occur in
  94 other classes. If any errors occur, `mmm-apply-classes' exits with an
  95 error once all classes have been applied."
  96   (let (invalid-classes)
  97     (dolist (class classes)
  98       (condition-case err
  99           (mmm-apply-class class start stop face)
 100         (mmm-invalid-submode-class
 101          ;; Save the name of the invalid class, so we can report them
 102          ;; all together at the end.
 103          (add-to-list 'invalid-classes (second err)))))
 104     (when invalid-classes
 105       (signal 'mmm-invalid-submode-class invalid-classes))))
 106
 107 ;;}}}
 108 ;;{{{ Apply All Classes
 109
 110 (defun* mmm-apply-all (&key (start (point-min)) (stop (point-max)))
 111   "MMM-ify from START to STOP by all submode classes.
 112 The classes come from mode/ext, `mmm-classes', `mmm-global-classes',
 113 and interactive history."
 114   (mmm-clear-overlays start stop 'strict)
 115   (mmm-apply-classes (mmm-get-all-classes t) :start start :stop stop)
 116   (mmm-update-submode-region)
 117   (mmm-refontify-maybe start stop))
 118
 119 ;;}}}
 120
 121 ;;; BUFFER SCANNING
 122 ;;{{{ Scan for Regions
 123
 124 (defun* mmm-ify
 125     (&rest all &key classes handler
 126            submode match-submode
 127            (start (point-min)) (stop (point-max))
 128            front back save-matches (case-fold-search t)
 129            (beg-sticky (not (number-or-marker-p front)))
 130            (end-sticky (not (number-or-marker-p back)))
 131            include-front include-back
 132            (front-offset 0) (back-offset 0)
 133            (front-delim nil) (back-delim nil)
 134            (delimiter-mode mmm-delimiter-mode)
 135            front-face back-face
 136            front-verify back-verify
 137            front-form back-form
 138            creation-hook
 139            face match-face
 140            save-name match-name
 141            (front-match 0) (back-match 0)
 142            end-not-begin
 143            ;insert private
 144            &allow-other-keys
 145            )
 146   "Create submode regions from START to STOP according to arguments.
 147 If CLASSES is supplied, it must be a list of valid CLASSes. Otherwise,
 148 the rest of the arguments are for an actual class being applied. See
 149 `mmm-classes-alist' for information on what they all mean."
 150   ;; Make sure we get the default values in the `all' list.
 151   (setq all (append
 152              all
 153              (list :start start :stop stop
 154                    :beg-sticky beg-sticky :end-sticky end-sticky
 155                    :front-offset front-offset :back-offset back-offset
 156                    :front-delim front-delim :back-delim back-delim
 157                    :front-match 0 :back-match 0
 158                    )))
 159   (cond
 160    ;; If we have a class list, apply them all.
 161    (classes
 162     (mmm-apply-classes classes :start start :stop stop :face face))
 163    ;; Otherwise, apply this class.
 164    ;; If we have a handler, call it.
 165    (handler
 166     (apply handler all))
 167    ;; Otherwise, we search from START to STOP for submode regions,
 168    ;; continuining over errors, until we don't find any more. If FRONT
 169    ;; and BACK are number-or-markers, this should only execute once.
 170    (t
 171     (mmm-save-all
 172      (goto-char start)
 173      (loop for (beg end front-pos back-pos matched-front matched-back
 174                     matched-submode matched-face matched-name
 175                     invalid-resume ok-resume) =
 176                     (apply #'mmm-match-region :start (point) all)
 177            while beg
 178            if end              ; match-submode, if present, succeeded.
 179            do
 180            (condition-case nil
 181                (progn
 182                  (mmm-make-region
 183                   (or matched-submode submode) beg end
 184                   :face (or matched-face face)
 185                   :front front-pos :back back-pos
 186                   :evaporation 'front
 187                   :match-front matched-front :match-back matched-back
 188                   :beg-sticky beg-sticky :end-sticky end-sticky
 189                   :name matched-name
 190                   :delimiter-mode delimiter-mode
 191                   :front-face front-face :back-face back-face
 192                   :creation-hook creation-hook
 193                   )
 194                  (goto-char ok-resume))
 195              ;; If our region is invalid, go back to the end of the
 196              ;; front match and continue on.
 197              (mmm-error (goto-char invalid-resume)))
 198            ;; If match-submode was unable to find a match, go back to
 199            ;; the end of the front match and continue on.
 200            else do (goto-char invalid-resume)
 201            )))))
 202
 203 ;;}}}
 204 ;;{{{ Match Regions
 205
 206 (defun* mmm-match-region
 207     (&key start stop front back front-verify back-verify
 208           include-front include-back front-offset back-offset
 209           front-form back-form save-matches match-submode match-face
 210           front-match back-match end-not-begin
 211           save-name match-name
 212           &allow-other-keys)
 213   "Find the first valid region between point and STOP.
 214 Return \(BEG END FRONT-POS BACK-POS FRONT-FORM BACK-FORM SUBMODE FACE
 215 NAME INVALID-RESUME OK-RESUME) specifying the region.  See
 216 `mmm-match-and-verify' for the valid values of FRONT and BACK
 217 \(markers, regexps, or functions).  A nil value for END means that
 218 MATCH-SUBMODE failed to find a valid submode.  INVALID-RESUME is the
 219 point at which the search should continue if the region is invalid,
 220 and OK-RESUME if the region is valid."
 221   (when (mmm-match-and-verify front start stop front-verify)
 222     (let ((beg (mmm-match->point include-front front-offset front-match))
 223           (front-pos (if front-delim
 224                          (mmm-match->point t front-delim front-match)
 225                        nil))
 226           (invalid-resume (match-end front-match))
 227           (front-form (mmm-get-form front-form)))
 228       (let ((submode (if match-submode
 229                          (condition-case nil
 230                              (mmm-save-all
 231                               (funcall match-submode front-form))
 232                            (mmm-no-matching-submode
 233                             (return-from
 234                                 mmm-match-region
 235                               (values beg nil nil nil nil nil nil nil nil
 236                                       invalid-resume nil))))
 237                        nil))
 238             (name (cond ((functionp match-name)
 239                          (mmm-save-all (funcall match-name front-form)))
 240                         ((stringp match-name)
 241                          (if save-name
 242                              (mmm-format-matches match-name)
 243                            match-name))))
 244             (face (cond ((functionp match-face)
 245                          (mmm-save-all
 246                           (funcall match-face front-form)))
 247                         (match-face
 248                          (cdr (assoc front-form match-face))))))
 249         (when (mmm-match-and-verify
 250                (if save-matches
 251                    (mmm-format-matches back)
 252                  back)
 253                beg stop back-verify)
 254           (let* ((end (mmm-match->point (not include-back)
 255                                         back-offset back-match))
 256                  (back-pos (if back-delim
 257                                (mmm-match->point nil back-delim back-match)
 258                              nil))
 259                  (back-form (mmm-get-form back-form))
 260                  (ok-resume (if end-not-begin
 261                                 (match-end back-match)
 262                               end)))
 263             (values beg end front-pos back-pos front-form back-form
 264                     submode face name
 265                     invalid-resume ok-resume)))))))
 266
 267 (defun mmm-match->point (beginp offset match)
 268   "Find a point of starting or stopping from the match data.  If
 269 BEGINP, start at \(match-beginning MATCH), else \(match-end MATCH),
 270 and move OFFSET.  Handles all values of OFFSET--see `mmm-classes-alist'."
 271   (save-excursion
 272     (goto-char (if beginp
 273                    (match-beginning front-match)
 274                  (match-end back-match)))
 275     (dolist (spec (if (listp offset) offset (list offset)))
 276       (if (numberp spec)
 277           (forward-char (or spec 0))
 278         (funcall spec)))
 279     (point)))
 280
 281 (defun mmm-match-and-verify (pos start stop &optional verify)
 282   "Find first match for POS between point and STOP satisfying VERIFY.
 283 Return non-nil if a match was found, and set match data. POS can be a
 284 number-or-marker, a regexp, or a function.
 285
 286 If POS is a number-or-marker, it is used as-is. If it is a string, it
 287 is searched for as a regexp until VERIFY returns non-nil. If it is a
 288 function, it is called with argument STOP and must return non-nil iff
 289 a match is found, and set the match data. Note that VERIFY is ignored
 290 unless POS is a regexp."
 291   (cond
 292    ;; A marker can be used as-is, but only if it's in bounds.
 293    ((and (number-or-marker-p pos) (>= pos start) (<= pos stop))
 294     (goto-char pos)
 295     (looking-at ""))            ; Set the match data
 296    ;; Strings are searched for as regexps.
 297    ((stringp pos)
 298     (loop always (re-search-forward pos stop 'limit)
 299           until (or (not verify) (mmm-save-all (funcall verify)))))
 300    ;; Otherwise it must be a function.
 301    ((functionp pos)
 302     (funcall pos stop))))
 303
 304 ;;}}}
 305 ;;{{{ Get Delimiter Forms
 306
 307 (defun mmm-get-form (form)
 308   "Return the delimiter form specified by FORM.
 309 If FORM is nil, call `mmm-default-get-form'. If FORM is a string,
 310 return it. If FORM is a function, call it. If FORM is a list, return
 311 its `car' \(usually in this case, FORM is a one-element list
 312 containing a function to be used as the delimiter form."
 313   (cond ((stringp form) form)
 314         ((not form) (mmm-default-get-form))
 315         ((functionp form) (mmm-save-all (funcall form)))
 316         ((listp form) (car form))))
 317
 318 (defun mmm-default-get-form ()
 319   (regexp-quote (match-string 0)))
 320
 321 ;;}}}
 322
 323 (provide 'mmm-class)
 324
 325 ;;; mmm-class.el ends here