1 ;;; mmm-cmds.el --- MMM Mode interactive commands and keymap
3 ;; Copyright (C) 2000 by Michael Abraham Shulman
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 $
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)
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.
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.
29 ;; This file contains the interactive commands for MMM Mode.
39 ;;{{{ Applying Predefined Classes
41 (defun mmm-ify-by-class (class)
42 "Add submode regions according to an existing submode class."
48 (mapcar #'(lambda (spec) (list (symbol-name (car spec))))
50 (remove-if #'(lambda (spec) (plist-get (cdr spec) :private))
52 (remove-if #'caddr mmm-autoloaded-classes)))
55 (unless (eq class (intern ""))
56 (mmm-apply-class class)
57 (mmm-add-to-history class)
58 (mmm-update-font-lock-buffer)))
61 ;;{{{ Applying by the Region
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))
73 ;;{{{ Applying Simple Regexps
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:
82 nOffset from Front 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))
94 ;; EDITING WITH REGIONS
95 ;;{{{ Re-parsing Areas
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."
102 (message "MMM-ifying buffer...")
104 (message "MMM-ifying buffer...done"))
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."
111 (message "MMM-ifying region...")
112 (mmm-apply-all :start start :stop stop)
113 (message "MMM-ifying region...done"))
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.
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'."
126 (message "MMM-ifying block...")
127 (destructuring-bind (start stop) (mmm-get-block lines)
129 (mmm-apply-all :start start :stop stop)))
130 (message "MMM-ifying block...done"))
132 (defun mmm-get-block (lines)
133 (let ((inhibit-point-motion-hooks t))
134 (list (save-excursion
135 (forward-line (- lines))
144 ;;{{{ Reparse Current Region
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."
150 (let ((ovl (mmm-overlay-at (point) 'all)))
152 (let ((beg (save-excursion
153 (goto-char (mmm-front-start ovl))
157 (goto-char (mmm-back-end ovl))
160 (mmm-parse-region beg end)))))
163 ;;{{{ Clear Submode Regions
165 ;; See also `mmm-clear-history' which is interactive.
167 (defun mmm-clear-current-region ()
168 "Deletes the submode region point is currently in, if any."
170 (delete-overlay (mmm-overlay-at (point) 'all)))
172 (defun mmm-clear-regions (start stop)
173 "Deletes all submode regions from START to STOP."
175 (mmm-clear-overlays start stop))
177 (defun mmm-clear-all-regions ()
178 "Deletes all submode regions in the current buffer."
180 (mmm-clear-overlays))
183 ;;{{{ End Current Region
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.
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."
197 (let ((ovl (mmm-overlay-at)))
199 (combine-after-change-calls
202 (when (mmm-match-back ovl)
205 (return-from mmm-end-current-region)))))
206 (let ((back (overlay-get ovl 'back)))
207 (cond ((stringp back)
209 (unless arg (goto-char (overlay-end ovl)))
210 (save-excursion (insert back))
211 (move-overlay ovl (overlay-start ovl) (point))))
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))))))
218 ;;{{{ Narrow to Region
220 (defun mmm-narrow-to-submode-region (&optional pos)
221 "Narrow to the submode region at point."
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)))
227 (narrow-to-region (overlay-start ovl) (overlay-end ovl)))))
229 ;; The inverse command is `widen', usually on `C-x n w'
234 ;;{{{ Insert regions by keystroke
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
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."
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)
254 (append (set-difference mods mmm-insert-modifiers)
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.
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)
270 (let ((after-change-functions nil)
271 (old-undo buffer-undo-list) undo)
272 ;; XEmacs' skeleton doesn't manage positions by itself, so we
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)))
286 (mmm-modename->function
288 (mmm-save-all (funcall match-submode front-form))
289 (plist-get class :submode))))
291 (cond ((functionp match-face)
293 (funcall match-face front-form)))
295 (cdr (assoc front-form match-face)))
297 (plist-get class :face))))
299 (cond ((plist-get class :skel-name)
300 ;; Optimize the name to the user-supplied str
301 ;; if we are so instructed.
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
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)
314 (mmm-format-matches match-name front-form))
316 ;; No, just use it as-is
322 :front front :back back
323 :match-front front-form :match-back back-form
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)))))))
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))
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)
364 ;;{{{ Help on Insertion
366 (defun mmm-insertion-help ()
367 "Display help on currently available MMM insertion commands."
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))))
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
387 (setcdr lastkey (list (cdr lastkey)))
388 (setq key (list key)))
389 ;; Get the spacing right
390 (store-substring str 0
392 (apply #'vector (append mmm-mode-prefix-key (list key)))))
394 ;; Now print the binding symbol
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."
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)))
411 :key #'(lambda (x) (cons (car x) (cadr x)))
416 ;;{{{ Auto Insertion (copied from interactive session);-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.
423 ;-COM-(define-skeleton mmm-see-inline
425 ;-COM- -1 @ " " _ " " @ "%>"
426 ;-COM- '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
428 ;-COM-(define-skeleton mmm-see-other
430 ;-COM- @ ";\n" _ "\n" @ "<%/" str ">"
431 ;-COM- '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
433 ;-COM-(make-local-hook 'after-change-functions)
434 ;-COM-(add-hook 'after-change-functions 'mmm-detect t)
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))))
446 ;;; mmm-cmds.el ends here