mmm-mode-0.4.8/mmm-cmds.el

   1 ;;; mmm-cmds.el --- MMM Mode interactive commands and keymap
   2
   3 ;; Copyright (C) 2000 by Michael Abraham Shulman
   4
   5 ;; Author: Michael Abraham Shulman <viritrilbia@users.sourceforge.net>
   6 ;; Version: $Id: mmm-cmds.el,v 1.18 2003/03/25 21:48:33 viritrilbia 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 the interactive commands for MMM Mode.
  30
  31 ;;; Code:
  32
  33 (require 'font-lock)
  34 (require 'mmm-compat)
  35 (require 'mmm-vars)
  36 (require 'mmm-class)
  37
  38 ;; APPLYING CLASSES
  39 ;;{{{ Applying Predefined Classes
  40
  41 (defun mmm-ify-by-class (class)
  42   "Add submode regions according to an existing submode class."
  43   (interactive
  44    (list (intern
  45           (completing-read
  46            "Submode Class: "
  47            (remove-duplicates
  48             (mapcar #'(lambda (spec) (list (symbol-name (car spec))))
  49                     (append
  50                      (remove-if #'(lambda (spec) (plist-get (cdr spec) :private))
  51                                 mmm-classes-alist)
  52                      (remove-if #'caddr mmm-autoloaded-classes)))
  53             :test #'equal)
  54            nil t))))
  55   (unless (eq class (intern ""))
  56     (mmm-apply-class class)
  57     (mmm-add-to-history class)
  58     (mmm-update-font-lock-buffer)))
  59
  60 ;;}}}
  61 ;;{{{ Applying by the Region
  62
  63 (defun mmm-ify-region (submode front back)
  64   "Add a submode region for SUBMODE coinciding with current region."
  65   (interactive "aSubmode: \nr")
  66   (mmm-ify :submode submode :front front :back back)
  67   (setq front (mmm-make-marker front t nil)
  68         back (mmm-make-marker back nil nil))
  69   (mmm-add-to-history `(:submode ,submode :front ,front :back ,back))
  70   (mmm-enable-font-lock submode))
  71
  72 ;;}}}
  73 ;;{{{ Applying Simple Regexps
  74
  75 (defun mmm-ify-by-regexp
  76   (submode front front-offset back back-offset save-matches)
  77   "Add SUBMODE regions to the buffer delimited by FRONT and BACK.
  78 With prefix argument, prompts for all additional keywords arguments.
  79 See `mmm-classes-alist'."
  80   (interactive "aSubmode:
  81 sFront Regexp:
  82 nOffset from Front Regexp:
  83 sBack Regexp:
  84 nOffset from Back Regexp:
  85 nNumber of matched substrings to save: ")
  86   (let ((args (mmm-save-keywords submode front back front-offset
  87                                  back-offset save-matches)))
  88     (apply #'mmm-ify args)
  89     (mmm-add-to-history args))
  90   (mmm-enable-font-lock submode))
  91
  92 ;;}}}
  93
  94 ;; EDITING WITH REGIONS
  95 ;;{{{ Re-parsing Areas
  96
  97 (defun mmm-parse-buffer ()
  98   "Re-apply all applicable submode classes to current buffer.
  99 Clears all current submode regions, reapplies all past interactive
 100 mmm-ification, and applies `mmm-classes' and mode-extension classes."
 101   (interactive)
 102   (message "MMM-ifying buffer...")
 103   (mmm-apply-all)
 104   (message "MMM-ifying buffer...done"))
 105
 106 (defun mmm-parse-region (start stop)
 107   "Re-apply all applicable submode classes between START and STOP.
 108 Clears all current submode regions, reapplies all past interactive
 109 mmm-ification, and applies `mmm-classes' and mode-extension classes."
 110   (interactive "r")
 111   (message "MMM-ifying region...")
 112   (mmm-apply-all :start start :stop stop)
 113   (message "MMM-ifying region...done"))
 114
 115 (defun mmm-parse-block (&optional lines)
 116   "Re-parse LINES lines before and after point \(default 1).
 117 Clears all current submode regions, reapplies all past interactive
 118 mmm-ification, and applies `mmm-classes' and mode-extension classes.
 119
 120 This command is intended for use when you have just typed what should
 121 be the delimiters of a submode region and you want to create the
 122 region. However, you may want to look into the various types of
 123 delimiter auto-insertion that MMM Mode provides. See, for example,
 124 `mmm-insert-region'."
 125   (interactive "p")
 126   (message "MMM-ifying block...")
 127   (destructuring-bind (start stop) (mmm-get-block lines)
 128     (when (< start stop)
 129       (mmm-apply-all :start start :stop stop)))
 130   (message "MMM-ifying block...done"))
 131
 132 (defun mmm-get-block (lines)
 133   (let ((inhibit-point-motion-hooks t))
 134     (list (save-excursion
 135             (forward-line (- lines))
 136             (beginning-of-line)
 137             (point))
 138           (save-excursion
 139             (forward-line lines)
 140             (end-of-line)
 141             (point)))))
 142
 143 ;;}}}
 144 ;;{{{ Reparse Current Region
 145
 146 (defun mmm-reparse-current-region ()
 147   "Clear and reparse the area of the current submode region.
 148 Use this command if a submode region's boundaries have become wrong."
 149   (interactive)
 150   (let ((ovl (mmm-overlay-at (point) 'all)))
 151     (when ovl
 152       (let ((beg (save-excursion
 153                    (goto-char (mmm-front-start ovl))
 154                    (forward-line -1)
 155                    (point)))
 156             (end (save-excursion
 157                    (goto-char (mmm-back-end ovl))
 158                    (forward-line 1)
 159                    (point))))
 160         (mmm-parse-region beg end)))))
 161
 162 ;;}}}
 163 ;;{{{ Clear Submode Regions
 164
 165 ;; See also `mmm-clear-history' which is interactive.
 166
 167 (defun mmm-clear-current-region ()
 168   "Deletes the submode region point is currently in, if any."
 169   (interactive)
 170   (delete-overlay (mmm-overlay-at (point) 'all)))
 171
 172 (defun mmm-clear-regions (start stop)
 173   "Deletes all submode regions from START to STOP."
 174   (interactive "r")
 175   (mmm-clear-overlays start stop))
 176
 177 (defun mmm-clear-all-regions ()
 178   "Deletes all submode regions in the current buffer."
 179   (interactive)
 180   (mmm-clear-overlays))
 181
 182 ;;}}}
 183 ;;{{{ End Current Region
 184
 185 (defun* mmm-end-current-region (&optional arg)
 186   "End current submode region.
 187 If ARG is nil, end it at the most appropriate place, usually its
 188 current back boundary. If ARG is non-nil, end it at point. If the
 189 current region is correctly bounded, the first does nothing, but the
 190 second deletes that delimiter as well.
 191
 192 If the region's BACK property is a string, it is inserted as above and
 193 the overlay moved if necessary. If it is a function, it is called with
 194 two arguments--the overlay, and \(if ARG 'middle t)--and must do the
 195 entire job of this function."
 196   (interactive "P")
 197   (let ((ovl (mmm-overlay-at)))
 198     (when ovl
 199       (combine-after-change-calls
 200         (save-match-data
 201           (save-excursion
 202             (when (mmm-match-back ovl)
 203               (if arg
 204                   (replace-match "")
 205                 (return-from mmm-end-current-region)))))
 206         (let ((back (overlay-get ovl 'back)))
 207           (cond ((stringp back)
 208                  (save-excursion
 209                    (unless arg (goto-char (overlay-end ovl)))
 210                    (save-excursion (insert back))
 211                    (move-overlay ovl (overlay-start ovl) (point))))
 212                 ((functionp back)
 213                  (funcall back ovl (if arg 'middle t))))))
 214       (mmm-refontify-maybe (save-excursion (forward-line -1) (point))
 215                            (save-excursion (forward-line 1) (point))))))
 216
 217 ;;}}}
 218 ;;{{{ Narrow to Region
 219
 220 (defun mmm-narrow-to-submode-region (&optional pos)
 221   "Narrow to the submode region at point."
 222   (interactive)
 223   ;; Probably don't use mmm-current-overlay here, because this is
 224   ;; sometimes called from inside messy functions.
 225   (let ((ovl (mmm-overlay-at pos)))
 226     (when ovl
 227       (narrow-to-region (overlay-start ovl) (overlay-end ovl)))))
 228
 229 ;; The inverse command is `widen', usually on `C-x n w'
 230
 231 ;;}}}
 232
 233 ;; INSERTING REGIONS
 234 ;;{{{ Insert regions by keystroke
 235
 236 ;; This is the "default" binding in the MMM Mode keymap. Keys defined
 237 ;; by classes should be control keys, to avoid conflicts with MMM
 238 ;; commands.
 239 (defun mmm-insert-region (arg)
 240   "Insert a submode region based on last character in invoking keys.
 241 Keystrokes after `mmm-mode-prefix-key' which are not bound to an MMM
 242 Mode command \(see `mmm-command-modifiers') are passed on to this
 243 function. If they have the modifiers `mmm-insert-modifiers', then they
 244 are looked up, sans those modifiers, in all current submode classes to
 245 find an insert skeleton. For example, in Mason, `p' \(with appropriate
 246 prefix and modifiers) will insert a <%perl>...</%perl> region."
 247   (interactive "P")
 248   (let* ((seq (this-command-keys))
 249          (event (aref seq (1- (length seq))))
 250          (mods (event-modifiers event))
 251          (key (mmm-event-key event)))
 252     (if (subsetp mmm-insert-modifiers mods)
 253         (mmm-insert-by-key
 254          (append (set-difference mods mmm-insert-modifiers)
 255                  key)
 256          arg))))
 257
 258 (defun mmm-insert-by-key (key &optional arg)
 259   "Insert a submode region based on event KEY.
 260 Inspects all the classes of the current buffer to find a matching
 261 :insert key sequence. See `mmm-classes-alist'. ARG, if present, is
 262 passed on to `skeleton-proxy-new' to control wrapping.
 263
 264 KEY must be a list \(MODIFIERS... . BASIC-KEY) where MODIFIERS are
 265 symbols such as shift, control, etc. and BASIC-KEY is a character code
 266 or a symbol such as tab, return, etc. Note that if there are no
 267 MODIFIERS, the dotted list becomes simply BASIC-KEY."
 268   (multiple-value-bind (class skel str) (mmm-get-insertion-spec key)
 269     (when skel
 270       (let ((after-change-functions nil)
 271             (old-undo buffer-undo-list) undo)
 272         ;; XEmacs' skeleton doesn't manage positions by itself, so we
 273         ;; have to do it.
 274         (if mmm-xemacs (setq skeleton-positions nil))
 275         (skeleton-proxy-new skel str arg)
 276         (destructuring-bind (back end beg front) skeleton-positions
 277           ;; TODO: Find a way to trap invalid-parent signals from
 278           ;; make-region and undo the skeleton insertion.
 279           (let ((match-submode (plist-get class :match-submode))
 280                 (match-face (plist-get class :match-face))
 281                 (match-name (plist-get class :match-name))
 282                 (front-form (regexp-quote (buffer-substring front beg)))
 283                 (back-form (regexp-quote (buffer-substring end back)))
 284                 submode face name)
 285             (setq submode
 286                   (mmm-modename->function
 287                    (if match-submode
 288                        (mmm-save-all (funcall match-submode front-form))
 289                      (plist-get class :submode))))
 290             (setq face
 291                   (cond ((functionp match-face)
 292                          (mmm-save-all
 293                           (funcall match-face front-form)))
 294                         (match-face
 295                          (cdr (assoc front-form match-face)))
 296                         (t
 297                          (plist-get class :face))))
 298             (setq name
 299                   (cond ((plist-get class :skel-name)
 300                          ;; Optimize the name to the user-supplied str
 301                          ;; if we are so instructed.
 302                          str)
 303                         ;; Call it if it is a function
 304                         ((functionp match-name)
 305                          (mmm-save-all (funcall match-name front-form)))
 306                         ;; Now we know it's a string, does it need to
 307                         ;; be formatted?
 308                         ((plist-get class :save-name)
 309                          ;; Yes.  Haven't done a match before, so
 310                          ;; match the front regexp against the given
 311                          ;; form to format the string
 312                          (string-match (plist-get class :front)
 313                                        front-form)
 314                          (mmm-format-matches match-name front-form))
 315                         (t
 316                          ;; No, just use it as-is
 317                          match-name)))
 318             (mmm-make-region
 319              submode beg end
 320              :face face
 321              :name name
 322              :front front :back back
 323              :match-front front-form :match-back back-form
 324              :evaporation 'front
 325 ;;;             :beg-sticky (plist-get class :beg-sticky)
 326 ;;;             :end-sticky (plist-get class :end-sticky)
 327              :beg-sticky t :end-sticky t
 328              :creation-hook (plist-get class :creation-hook))
 329             (mmm-enable-font-lock submode)))
 330         ;; Now get rid of intermediate undo boundaries, so that the entire
 331         ;; insertion can be undone as one action.  This should really be
 332         ;; skeleton's job, but it doesn't do it.
 333         (setq undo buffer-undo-list)
 334         (while (not (eq (cdr undo) old-undo))
 335           (when (eq (cadr undo) nil)
 336             (setcdr undo (cddr undo)))
 337           (setq undo (cdr undo)))))))
 338
 339 (defun mmm-get-insertion-spec (key &optional classlist)
 340   "Get the insertion info for KEY from all classes in CLASSLIST.
 341 Return \(CLASS SKEL STR) where CLASS is the class spec a match was
 342 found in, SKEL is the skeleton to insert, and STR is the argument.
 343 CLASSLIST defaults to the return value of `mmm-get-all-classes',
 344 including global classes."
 345   (loop for classname in (or classlist (mmm-get-all-classes t))
 346         for class = (mmm-get-class-spec classname)
 347         for inserts = (plist-get class :insert)
 348         for skel = (cddr (assoc key inserts))
 349         with str
 350         ;; If SKEL is a dotted pair, it means call another key's
 351         ;; insertion spec with an argument.
 352         unless (consp (cdr skel))
 353         do (setq str (cdr skel)
 354                  skel (cddr (assoc (car skel) inserts)))
 355         if skel return (list class skel str)
 356         ;; If we have a group class, recurse.
 357         if (plist-get class :classes)
 358            if (mmm-get-insertion-spec key it)
 359               return it
 360            else
 361               return nil))
 362
 363 ;;}}}
 364 ;;{{{ Help on Insertion
 365
 366 (defun mmm-insertion-help ()
 367   "Display help on currently available MMM insertion commands."
 368   (interactive)
 369   (with-output-to-temp-buffer "*Help*"
 370     (princ "Available MMM Mode Insertion Commands:\n")
 371     (princ "Key             Inserts\n")
 372     (princ "---             -------\n\n")
 373     (mapcar #'mmm-display-insertion-key
 374             (mmm-get-all-insertion-keys))))
 375
 376 (defun mmm-display-insertion-key (spec)
 377   "Print an insertion binding to standard output.
 378 SPEC should be \(KEY NAME ...) where KEY is an insertion key and NAME
 379 is a symbol naming the insertion."
 380   (let* ((str (make-string 16 ?\ ))
 381          ;; This gets us a dotted list, because of the way insertion
 382          ;; keys are specified.
 383          (key (append mmm-insert-modifiers (car spec)))
 384          (lastkey (nthcdr (max (1- (safe-length key)) 0) key)))
 385     ;; Now we make it a true list
 386     (if (consp key)
 387         (setcdr lastkey (list (cdr lastkey)))
 388       (setq key (list key)))
 389     ;; Get the spacing right
 390     (store-substring str 0
 391       (key-description
 392        (apply #'vector (append mmm-mode-prefix-key (list key)))))
 393     (princ str)
 394     ;; Now print the binding symbol
 395     (princ (cadr spec))
 396     (princ "\n")))
 397
 398 (defun mmm-get-all-insertion-keys (&optional classlist)
 399   "Return an alist of all currently available insertion keys.
 400 Elements look like \(KEY NAME ...) where KEY is an insertion key and
 401 NAME is a symbol naming the insertion."
 402   (remove-duplicates
 403    (loop for classname in (or classlist (mmm-get-all-classes t))
 404          for class = (mmm-get-class-spec classname)
 405          append (plist-get class :insert) into keys
 406          ;; If we have a group class, recurse.
 407          if (plist-get class :classes)
 408          do (setq keys (append keys (mmm-get-all-insertion-keys it)))
 409          finally return keys)
 410    :test #'equal
 411    :key #'(lambda (x) (cons (car x) (cadr x)))
 412    :from-end t))
 413
 414 ;;}}}
 415
 416 ;;{{{ Auto Insertion (copied from interactive session);-COM-
 417 ;-COM-
 418 ;-COM-;; Don't use `mmm-ify-region' of course. And rather than having
 419 ;-COM-;; classes define their own functions, we should have them pass a
 420 ;-COM-;; skeleton as an attribute. Then our insert function can turn off
 421 ;-COM-;; after-change hooks and add the submode region afterward.
 422 ;-COM-
 423 ;-COM-(define-skeleton mmm-see-inline
 424 ;-COM-  "" nil
 425 ;-COM-  -1 @ " " _ " " @ "%>"
 426 ;-COM-  '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
 427 ;-COM-
 428 ;-COM-(define-skeleton mmm-see-other
 429 ;-COM-  "" nil
 430 ;-COM-  @ ";\n" _ "\n" @ "<%/" str ">"
 431 ;-COM-  '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
 432 ;-COM-
 433 ;-COM-(make-local-hook 'after-change-functions)
 434 ;-COM-(add-hook 'after-change-functions 'mmm-detect t)
 435 ;-COM-
 436 ;-COM-(defun mmm-detect (beg end length)
 437 ;-COM-  (when (mmm-looking-back-at "<% ")
 438 ;-COM-    (mmm-see-inline))
 439 ;-COM-  (when (mmm-looking-back-at "<%\\(\\w+\\)>")
 440 ;-COM-    (mmm-see-other (match-string 1))))
 441 ;-COM-
 442 ;;}}}
 443
 444 (provide 'mmm-cmds)
 445
 446 ;;; mmm-cmds.el ends here