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