mmm-mode / mmm-cmds.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
;;; mmm-cmds.el --- MMM Mode interactive commands and keymap

;; 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 contains the interactive commands for MMM Mode.

;;; Code:

(require 'font-lock)
(require 'mmm-compat)
(require 'mmm-vars)
(require 'mmm-class)

;; XEmacs change: we don't have combine-after-change-calls.
(eval-when-compile
  (unless (fboundp 'combine-after-change-calls)
    (defmacro combine-after-change-calls (&rest body)
      "Execute `body'."
      `(progn ,@body))))

(defmacro mmm-destructuring-bind (args expr &rest body)
  "Like `destructuring-bind', but don't error if ARGS don't fit EXPR."
  `(loop for ,args = ,expr return (progn ,@body)))

;; APPLYING CLASSES
;;{{{ Applying Predefined Classes

(defun mmm-ify-by-class (class)
  "Add submode regions according to an existing submode class."
  (interactive
   (list (intern
          (completing-read
           "Submode Class: "
           (remove-duplicates
            (mapcar #'(lambda (spec) (list (symbol-name (car spec))))
                    (append
                     (remove-if #'(lambda (spec) (plist-get (cdr spec) :private))
                                mmm-classes-alist)
                     (remove-if #'caddr mmm-autoloaded-classes)))
            :test #'equal)
           nil t))))
  (unless (eq class (intern ""))
    (mmm-apply-class class)
    (mmm-add-to-history class)
    (mmm-update-font-lock-buffer)))

;;}}}
;;{{{ Applying by the Region

(defun mmm-ify-region (submode front back)
  "Add a submode region for SUBMODE coinciding with current region."
  (interactive "aSubmode: \nr")
  (mmm-ify :submode submode :front front :back back)
  (setq front (mmm-make-marker front t nil)
        back (mmm-make-marker back nil nil))
  (mmm-add-to-history `(:submode ,submode :front ,front :back ,back))
  (mmm-enable-font-lock submode))

;;}}}
;;{{{ Applying Simple Regexps

(defun mmm-ify-by-regexp
  (submode front front-offset back back-offset save-matches)
  "Add SUBMODE regions to the buffer delimited by FRONT and BACK.
With prefix argument, prompts for all additional keywords arguments.
See `mmm-classes-alist'."
  (interactive "aSubmode: 
sFront Regexp: 
nOffset from Front Regexp: 
sBack Regexp: 
nOffset from Back Regexp: 
nNumber of matched substrings to save: ")
  (let ((args (mmm-save-keywords submode front back front-offset
                                 back-offset save-matches)))
    (apply #'mmm-ify args)
    (mmm-add-to-history args))
  (mmm-enable-font-lock submode))

;;}}}

;; EDITING WITH REGIONS
;;{{{ Re-parsing Areas

(defun mmm-parse-buffer ()
  "Re-apply all applicable submode classes to current buffer.
Clears all current submode regions, reapplies all past interactive
mmm-ification, and applies `mmm-classes' and mode-extension classes."
  (interactive)
  (message "MMM-ifying buffer...")
  (mmm-apply-all)
  (message "MMM-ifying buffer...done"))

(defun mmm-parse-region (start stop)
  "Re-apply all applicable submode classes between START and STOP.
Clears all current submode regions, reapplies all past interactive
mmm-ification, and applies `mmm-classes' and mode-extension classes."
  (interactive "r")
  (message "MMM-ifying region...")
  (mmm-apply-all :start start :stop stop)
  (message "MMM-ifying region...done"))

(defun mmm-parse-block (&optional lines)
  "Re-parse LINES lines before and after point \(default 1).
Clears all current submode regions, reapplies all past interactive
mmm-ification, and applies `mmm-classes' and mode-extension classes.

This command is intended for use when you have just typed what should
be the delimiters of a submode region and you want to create the
region. However, you may want to look into the various types of
delimiter auto-insertion that MMM Mode provides. See, for example,
`mmm-insert-region'."
  (interactive "p")
  (message "MMM-ifying block...")
  (destructuring-bind (start stop) (mmm-get-block lines)
    (when (< start stop)
      (mmm-apply-all :start start :stop stop)))
  (message "MMM-ifying block...done"))

(defun mmm-get-block (lines)
  (let ((inhibit-point-motion-hooks t))
    (list (save-excursion
            (forward-line (- lines))
            (beginning-of-line)
            (point))
          (save-excursion
            (forward-line lines)
            (end-of-line)
            (point)))))

;;}}}
;;{{{ Reparse Current Region

(defun mmm-reparse-current-region ()
  "Clear and reparse the area of the current submode region.
Use this command if a submode region's boundaries have become wrong."
  (interactive)
  (let ((ovl (mmm-overlay-at (point) 'all)))
    (when ovl
      (let ((beg (save-excursion
                   (goto-char (mmm-front-start ovl))
                   (forward-line -1)
                   (point)))
            (end (save-excursion
                   (goto-char (mmm-back-end ovl))
                   (forward-line 1)
                   (point))))
        (mmm-parse-region beg end)))))

;;}}}
;;{{{ Clear Submode Regions

;; See also `mmm-clear-history' which is interactive.

(defun mmm-clear-current-region ()
  "Deletes the submode region point is currently in, if any."
  (interactive)
  (delete-overlay (mmm-overlay-at (point) 'all)))

(defun mmm-clear-regions (start stop)
  "Deletes all submode regions from START to STOP."
  (interactive "r")
  (mmm-clear-overlays start stop))

(defun mmm-clear-all-regions ()
  "Deletes all submode regions in the current buffer."
  (interactive)
  (mmm-clear-overlays))

;;}}}
;;{{{ End Current Region

(defun* mmm-end-current-region (&optional arg)
  "End current submode region.
If ARG is nil, end it at the most appropriate place, usually its
current back boundary. If ARG is non-nil, end it at point. If the
current region is correctly bounded, the first does nothing, but the
second deletes that delimiter as well.

If the region's BACK property is a string, it is inserted as above and
the overlay moved if necessary. If it is a function, it is called with
two arguments--the overlay, and \(if ARG 'middle t)--and must do the
entire job of this function."
  (interactive "P")
  (let ((ovl (mmm-overlay-at)))
    (when ovl
      (combine-after-change-calls
        (save-match-data
          (save-excursion
            (when (mmm-match-back ovl)
              (if arg
                  (replace-match "")
                (return-from mmm-end-current-region)))))
        (let ((back (overlay-get ovl 'back)))
          (cond ((stringp back)
                 (save-excursion
                   (unless arg (goto-char (overlay-end ovl)))
                   (save-excursion (insert back))
                   (move-overlay ovl (overlay-start ovl) (point))))
                ((functionp back)
                 (funcall back ovl (if arg 'middle t))))))
      (mmm-refontify-maybe (save-excursion (forward-line -1) (point))
                           (save-excursion (forward-line 1) (point))))))

;;}}}
;;{{{ Narrow to Region

(defun mmm-narrow-to-submode-region (&optional pos)
  "Narrow to the submode region at point."
  (interactive)
  ;; Probably don't use mmm-current-overlay here, because this is
  ;; sometimes called from inside messy functions.
  (let ((ovl (mmm-overlay-at pos)))
    (when ovl
      (narrow-to-region (overlay-start ovl) (overlay-end ovl)))))

;; The inverse command is `widen', usually on `C-x n w'

;;}}}

;; INSERTING REGIONS
;;{{{ Insert regions by keystroke

;; This is the "default" binding in the MMM Mode keymap. Keys defined
;; by classes should be control keys, to avoid conflicts with MMM
;; commands.
(defun mmm-insert-region (arg)
  "Insert a submode region based on last character in invoking keys.
Keystrokes after `mmm-mode-prefix-key' which are not bound to an MMM
Mode command \(see `mmm-command-modifiers') are passed on to this
function. If they have the modifiers `mmm-insert-modifiers', then they
are looked up, sans those modifiers, in all current submode classes to
find an insert skeleton. For example, in Mason, `p' \(with appropriate
prefix and modifiers) will insert a <%perl>...</%perl> region."
  (interactive "P")
  (let* ((seq (this-command-keys))
         (event (aref seq (1- (length seq))))
         (mods (event-modifiers event))
         (key (mmm-event-key event)))
    (if (subsetp mmm-insert-modifiers mods)
        (mmm-insert-by-key
         (append (set-difference mods mmm-insert-modifiers)
                 key)
         arg))))

(defun mmm-insert-by-key (key &optional arg)
  "Insert a submode region based on event KEY.
Inspects all the classes of the current buffer to find a matching
:insert key sequence. See `mmm-classes-alist'. ARG, if present, is
passed on to `skeleton-proxy-new' to control wrapping.

KEY must be a list \(MODIFIERS... . BASIC-KEY) where MODIFIERS are
symbols such as shift, control, etc. and BASIC-KEY is a character code
or a symbol such as tab, return, etc. Note that if there are no
MODIFIERS, the dotted list becomes simply BASIC-KEY."
  (mmm-destructuring-bind (class skel str) (mmm-get-insertion-spec key)
    (when skel
      (let ((after-change-functions nil)
            (old-undo buffer-undo-list) undo)
        ;; XEmacs' skeleton doesn't manage positions by itself, so we
        ;; have to do it.
        (if mmm-xemacs (setq skeleton-positions nil))
        (skeleton-proxy-new skel str arg)
        (mmm-destructuring-bind (back end beg front) skeleton-positions
          ;; TODO: Find a way to trap invalid-parent signals from
          ;; make-region and undo the skeleton insertion.
          (let ((match-submode (plist-get class :match-submode))
		(match-face (plist-get class :match-face))
		(match-name (plist-get class :match-name))
		(front-form (regexp-quote (buffer-substring front beg)))
		(back-form (regexp-quote (buffer-substring end back)))
		submode face name)
	    (setq submode
		  (mmm-modename->function
		   (if match-submode
		       (mmm-save-all (funcall match-submode front-form))
		     (plist-get class :submode))))
	    (setq face
                  (cond ((functionp match-face)
                         (mmm-save-all
                          (funcall match-face front-form)))
                        (match-face
                         (cdr (assoc front-form match-face)))
                        (t
                         (plist-get class :face))))
	    (setq name
		  (cond ((plist-get class :skel-name)
			 ;; Optimize the name to the user-supplied str
			 ;; if we are so instructed.
			 str)
			;; Call it if it is a function
			((functionp match-name)
			 (mmm-save-all (funcall match-name front-form)))
			;; Now we know it's a string, does it need to
			;; be formatted?
			((plist-get class :save-name)
			 ;; Yes.  Haven't done a match before, so
			 ;; match the front regexp against the given
			 ;; form to format the string
			 (string-match (plist-get class :front)
				       front-form)
			 (mmm-format-matches match-name front-form))
			(t
			 ;; No, just use it as-is
			 match-name)))
            (mmm-make-region
             submode beg end 
	     :face face
	     :name name
	     :front front :back back
	     :match-front front-form :match-back back-form
	     :evaporation 'front
;;;             :beg-sticky (plist-get class :beg-sticky)
;;;             :end-sticky (plist-get class :end-sticky)
             :beg-sticky t :end-sticky t
             :creation-hook (plist-get class :creation-hook))
            (mmm-enable-font-lock submode)))
        ;; Now get rid of intermediate undo boundaries, so that the entire
        ;; insertion can be undone as one action.  This should really be
        ;; skeleton's job, but it doesn't do it.
        (setq undo buffer-undo-list)
        (while (not (eq (cdr undo) old-undo))
          (when (eq (cadr undo) nil)
            (setcdr undo (cddr undo)))
          (setq undo (cdr undo)))))))

(defun mmm-get-insertion-spec (key &optional classlist)
  "Get the insertion info for KEY from all classes in CLASSLIST.
Return \(CLASS SKEL STR) where CLASS is the class spec a match was
found in, SKEL is the skeleton to insert, and STR is the argument.
CLASSLIST defaults to the return value of `mmm-get-all-classes',
including global classes."
  (loop for classname in (or classlist (mmm-get-all-classes t))
        for class = (mmm-get-class-spec classname)
        for inserts = (plist-get class :insert)
        for skel = (cddr (assoc key inserts))
        with str
        ;; If SKEL is a dotted pair, it means call another key's
        ;; insertion spec with an argument.
        unless (consp (cdr skel))
        do (setq str (cdr skel)
                 skel (cddr (assoc (car skel) inserts)))
        if skel return (list class skel str)
        ;; If we have a group class, recurse.
        if (plist-get class :classes)
           if (mmm-get-insertion-spec key it)
              return it
           else
              return nil))

;;}}}
;;{{{ Help on Insertion

(defun mmm-insertion-help ()
  "Display help on currently available MMM insertion commands."
  (interactive)
  (with-output-to-temp-buffer "*Help*"
    (princ "Available MMM Mode Insertion Commands:\n")
    (princ "Key             Inserts\n")
    (princ "---             -------\n\n")
    (mapcar #'mmm-display-insertion-key
            (mmm-get-all-insertion-keys))))

(defun mmm-display-insertion-key (spec)
  "Print an insertion binding to standard output.
SPEC should be \(KEY NAME ...) where KEY is an insertion key and NAME
is a symbol naming the insertion."
  (let* ((str (make-string 16 ?\ ))
         ;; This gets us a dotted list, because of the way insertion
         ;; keys are specified.
         (key (append mmm-insert-modifiers (car spec)))
         (lastkey (nthcdr (max (1- (safe-length key)) 0) key)))
    ;; Now we make it a true list
    (if (consp key)
        (setcdr lastkey (list (cdr lastkey)))
      (setq key (list key)))
    ;; Get the spacing right
    (store-substring str 0
      (key-description
       (apply #'vector (append mmm-mode-prefix-key (list key)))))
    (princ str)
    ;; Now print the binding symbol
    (princ (cadr spec))
    (princ "\n")))

(defun mmm-get-all-insertion-keys (&optional classlist)
  "Return an alist of all currently available insertion keys.
Elements look like \(KEY NAME ...) where KEY is an insertion key and
NAME is a symbol naming the insertion."
  (remove-duplicates
   (loop for classname in (or classlist (mmm-get-all-classes t))
         for class = (mmm-get-class-spec classname)
         append (plist-get class :insert) into keys
         ;; If we have a group class, recurse.
         if (plist-get class :classes)
         do (setq keys (append keys (mmm-get-all-insertion-keys it)))
         finally return keys)
   :test #'equal
   :key #'(lambda (x) (cons (car x) (cadr x)))
   :from-end t))

;;}}}

;;{{{ Auto Insertion (copied from interactive session);-COM-
;-COM-
;-COM-;; Don't use `mmm-ify-region' of course. And rather than having
;-COM-;; classes define their own functions, we should have them pass a
;-COM-;; skeleton as an attribute. Then our insert function can turn off
;-COM-;; after-change hooks and add the submode region afterward.
;-COM-
;-COM-(define-skeleton mmm-see-inline
;-COM-  "" nil
;-COM-  -1 @ " " _ " " @ "%>"
;-COM-  '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
;-COM-
;-COM-(define-skeleton mmm-see-other
;-COM-  "" nil
;-COM-  @ ";\n" _ "\n" @ "<%/" str ">"
;-COM-  '(apply #'mmm-ify-region 'cperl-mode (reverse skeleton-positions)))
;-COM-
;-COM-(make-local-hook 'after-change-functions)
;-COM-(add-hook 'after-change-functions 'mmm-detect t)
;-COM-
;-COM-(defun mmm-detect (beg end length)
;-COM-  (when (mmm-looking-back-at "<% ")
;-COM-    (mmm-see-inline))
;-COM-  (when (mmm-looking-back-at "<%\\(\\w+\\)>")
;-COM-    (mmm-see-other (match-string 1))))
;-COM-
;;}}}

(provide 'mmm-cmds)

;;; mmm-cmds.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.