diff options
Diffstat (limited to 'contrib')
-rw-r--r-- | contrib/mmm/mmm-cmds.el | 449 |
1 files changed, 449 insertions, 0 deletions
diff --git a/contrib/mmm/mmm-cmds.el b/contrib/mmm/mmm-cmds.el new file mode 100644 index 00000000..f39da066 --- /dev/null +++ b/contrib/mmm/mmm-cmds.el @@ -0,0 +1,449 @@ +;;; 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) + +;; 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." + (multiple-value-bind (class skel str) (mmm-get-insertion-spec key) + (when skel + (let ((after-change-functions nil) + (old-undo buffer-undo-list) undo + ;; da: Proof General patch for compatibility with holes.el, + ;; bind this variable to prevent inserting holes here. + mmm-inside-insert-by-key) + ;; 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) + (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
\ No newline at end of file |