;;; mmm-cmds.el --- MMM Mode interactive commands and keymap

;; Copyright (C) 2000 by Michael Abraham Shulman

;; Author: Michael Abraham Shulman <mas@kurukshetra.cjb.net>
;; Version: $Id: mmm-cmds.el,v 1.1.1.3 2001/02/08 23:37:53 mdorman Exp $

;;{{{ 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 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
            (remove nil
                    (nconc
                     (mapcar #'(lambda (spec)
                                 (if (plist-get (cdr spec) :private)
                                     nil
                                   (list (symbol-name (car spec)))))
                             mmm-classes-alist)
                     (mapcar #'(lambda (spec)
                                 (if (caddr spec)
                                     nil
                                   (list (symbol-name (car spec)))))
                             mmm-autoloaded-classes))))
           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))

;;}}}
;;{{{ 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)))))

;;}}}
;;{{{ 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))

;;}}}
;;{{{ 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)))))

;;}}}
;;{{{ 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))))))

;;}}}
;;{{{ 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))
        ;; 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))
                 (front-str (buffer-substring front beg))
                 (back-str (buffer-substring end back))
                 (submode
                  (if match-submode
                      (mmm-save-all (funcall match-submode front-str))
                    (plist-get class :submode)))
                 (match-face (plist-get class :match-face))
                 (face
                  (cond ((functionp match-face)
                         (mmm-save-all
                          (funcall match-face front-str)))
                        (match-face
                         (cdr (assoc front-str match-face)))
                        (t
                         (plist-get class :face)))))
            (setq submode (mmm-modename->function submode))
            (mmm-make-region
             submode beg end :front front-str :back back-str
             :face face
;;;             :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)))))))

(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