home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / region-key.el < prev    next >
Encoding:
Text File  |  1993-02-03  |  19.5 KB  |  454 lines
  1. ;;; Copyright (C) 1992 Aaron Larson.
  2.  
  3. ;;; This file is not part of the GNU Emacs distribution (yet).
  4.  
  5. ;;; This file is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;;; accepts responsibility to anyone for the consequences of using it
  8. ;;; or for whether it serves any particular purpose or works at all,
  9. ;;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;;; License for full details.
  11.  
  12. ;;; Everyone is granted permission to copy, modify and redistribute
  13. ;;; this file, but only under the conditions described in the
  14. ;;; GNU Emacs General Public License.   A copy of this license is
  15. ;;; supposed to have been given to you along with GNU Emacs so you
  16. ;;; can know your rights and responsibilities.  It should be in a
  17. ;;; file named COPYING.  Among other things, the copyright notice
  18. ;;; and this notice must be preserved on all copies.
  19.  
  20. ;;; region-key.el
  21.  
  22. ;;; LCD Archive Entry:
  23. ;;; region-key|Aaron Larson|alarson@src.honeywell.com|
  24. ;;; Region specific modes for emacs.|
  25. ;;; 93-01-18|version 1.0|~/misc/region-key.el.Z|
  26.  
  27.  
  28. ;;; The following supports the establishment of keybindings for regions of
  29. ;;; a buffer.  The regions are defined by user supplied functions.  In this
  30. ;;; way, for example, it is possible to define a function which will return
  31. ;;; true when point is in the documentation string for a lisp function, and
  32. ;;; have the documentation string be processed in latex-mode, while the
  33. ;;; rest of buffer is processed in lisp-mode.  There is no limit to the
  34. ;;; number of different "region-specific" modes which can be defined for a
  35. ;;; buffer, although the time to process keybindings for local modes is
  36. ;;; proportional to the number of region-specific modes defined.
  37. ;;; 
  38. ;;; See define-region-specific-keybindings for more info.
  39. ;;; 
  40. ;;; To accomplish this, a "fake" local keymap is installed in the current
  41. ;;; buffer which has entries in it for the FIRST characters of all local key
  42. ;;; sequences for all region specific modes for this buffer (see region-
  43. ;;; specific-local-keys-only for an exception to this).  When one of these
  44. ;;; keys is typed, a dispatch function (region-specific-keybinding-exec) is
  45. ;;; called which then calls the "region definition predicate" functions for all
  46. ;;; the region specific modes in the buffer until one returns true.  A full
  47. ;;; key sequence is then read, and if it was defined by the local keymap for
  48. ;;; the associated mode, the local variables for the mode are established and
  49. ;;; the command is executed.  If the key sequence was defined by the global
  50. ;;; map, no local variable bindings are established.  (It could certianly be
  51. ;;; argued that in this situation, the other region specific modes should be
  52. ;;; consulted, or that the local variable binding should be established anyway,
  53. ;;; but due to the "bug" referenced in meta-region-specifc-keybinding-exec it
  54. ;;; turns out to be objectional to establish the keybindings since all meta
  55. ;;; commands then fall into this category.  Checking the other region specific
  56. ;;; modes creates a pseudo hierarchy of modes which I think would be hard for a
  57. ;;; user to reason about, but I have not actually tried it.)
  58.  
  59. ;;; This file defines externally visible functions:
  60. ;;;   define-region-specific-keybindings
  61.  
  62. ;;; The functions progv and mapkeymap should be moved to other files
  63. ;;; during some future emacs reorganization.
  64.  
  65. ;;; Modification History:
  66. ;;; Written: Aaron Larson (alarson@src.honeywell.com) 12/7/91
  67. ;;; Modified:
  68. ;;;   Aaron Larson 2/25/92  Install syntax-table for all command executions.
  69. ;;;   Aaron Larson 5/11/92  Allow regions-specific-keybinding-exec
  70. ;;;                   callable non interactively .
  71.  
  72. ;;; Begin version 1.0
  73.  
  74. (require 'cl)
  75. (provide 'region-key)
  76.  
  77. ;;; ---------- This should be in a more general place. ---------- 
  78. (defun mapkeymap (function keymap)
  79.   "Call FUNCTION for each key in KEYMAP.  Function will be called with two 
  80. arguments, a key, and its current binding."
  81.   (if (consp keymap)
  82.       (dolist (k (cdr keymap))
  83.     (funcall function (car k) (cdr k)))
  84.     (dotimes (i (length keymap))
  85.       (funcall function i (aref keymap i)))))
  86.  
  87. (defmacro save-match-data (&rest forms)
  88.   (let ((md (gensym)))
  89.     (`(let (((, md) (match-data)))
  90.        (unwind-protect
  91.         (progn (,@ forms))
  92.      (store-match-data (, md)))))))
  93.  
  94. ;;; --------- Following should be in cl.el -------------
  95.  
  96. ;;; (put 'progv 'common-lisp-indent-hook '(4 4 &body))
  97. (defmacro progv (vars vals &rest body)
  98.   "progv vars vals &body forms
  99. bind vars to vals then execute forms.
  100. If there are more vars than vals, the extra vars are unbound, if
  101. there are more vals than vars, the extra vals are just ignored."
  102.   (` (progv-runtime (, vars) (, vals) (function (lambda () (,@ body))))))
  103.  
  104. ;;; To do this efficiently, it really needs to be a special form, or at
  105. ;;; least have a byte compiled representation.
  106. (defun progv-runtime (vars vals body)
  107.   (eval (let ((vars-n-vals nil)
  108.           (unbind-forms nil))
  109.       (do ((r vars (cdr r))
  110.            (l vals (cdr l)))
  111.           ((endp r))
  112.         (push (list (car r) (list 'quote (car l))) vars-n-vals)
  113.         (if (null l)
  114.         (push (` (makunbound '(, (car r)))) unbind-forms)))
  115.       (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body)))))))
  116.  
  117. (defvar region-specific-local-keys-only nil
  118.   "*If true, then only keys local to a region specific keymap dispatch to
  119. region-specific-keybinding-exec, otherwise ALL keys will.  In general you
  120. want all keys to go through region-specific-keybinding-exec since mode 
  121. settings effect the operation of globally defined functions as well (e.g. 
  122. forward-sexp), however on some platforms the overhead of this is too high, 
  123. so setting this to true will result in the overhead being noticed only for
  124. locally defined keys.")
  125.  
  126. (defstruct region-specific-info
  127.   ;; the mode name (symbol) for this region-specific mode.
  128.   mode-name
  129.   ;; function of zero args, returns true if in a region of buffer that
  130.   ;; this info applies to, the resulting value, if non nil, is passed to
  131.   ;; prep-fun
  132.   pred-fun
  133.   ;; the keymap that should be used when reading the command key sequence
  134.   keymap
  135.   ;; A random buffer that is in the mode that this region of the buffer is
  136.   ;; to be assumed to be in.
  137.   buffer
  138.   ;; The syntax table for this region
  139.   syntax-table
  140.   ;; A function of one arg that is called to "prepare" the buffer to
  141.   ;; execute a region specific key binding.  Typical things for this
  142.   ;; function to do are to narrow the buffer so that the region specific
  143.   ;; command only sees the region of the buffer in in this mode
  144.   prep-fun)
  145.  
  146. (defvar region-specific-info-list ()
  147.   "list of regin-specific-info structs.  Structs are unique w.r.t mode-name")
  148.  
  149. (defvar original-keymap nil)
  150.  
  151. (defvar region-specific-dispatch-keymap nil)
  152.  
  153. (defun define-region-specific-keybindings (mode buffer predicate &optional prep-fun)
  154.           "MODE is the mode name (symbol) for the region, or nil to disable all
  155. region-specific key bindings for this buffer.  BUFFER is a buffer in major
  156. mode MODE, or nil to disable region-specific-key bindings for MODE in this
  157. buffer.  PREDICATE, a function of no arguments, defines the regions of the
  158. buffer where this mode will be in effect.  PREP-FUN (optional), will be
  159. called, within a save-restriction, with the value returned from PREIDICATE
  160. prior to calling the interactive command, and prior to establishing the
  161. local variable bindings for MODE from BUFFER.
  162.  
  163. For any point in the current-buffer where PREDICATE returns non nil,
  164. define-region-specific-keybindings causes any local key bindings defined in
  165. the current-local-map of BUFFER to override the current-local-map of the
  166. current-buffer (however, see variable region-specific-local-keys-only for an
  167. exception to this.  Define-region-specific-keybindings may be called to define
  168. any number of \"region specific\" local keymaps.  If the PREDICATE function
  169. for more than one of the region specific keymaps returns non nil, one of
  170. them will be arbitrarily choosen."
  171.  
  172.   (if (null mode)
  173.       (progn
  174.     ;; disable everything and clean up.
  175.     (use-local-map original-keymap)
  176.     (kill-local-variable 'original-keymap)
  177.     (kill-local-variable 'region-specific-info-list)
  178.     (kill-local-variable 'region-specific-dispatch-keymap))
  179.       (progn
  180.     ;; First do some initialization.
  181.     (when (null original-keymap)
  182.       (make-local-variable 'original-keymap)
  183.       (setq original-keymap (current-local-map)))
  184.     ;; if someone introduces a new local key binding after this function runs,
  185.     ;; it will be hard for users to acquire the new binding.
  186.     (when (null region-specific-dispatch-keymap)
  187.       (make-local-variable 'region-specific-dispatch-keymap)
  188.       (make-local-variable 'region-specific-info-list)
  189.       (if region-specific-local-keys-only
  190.           (setq region-specific-dispatch-keymap (make-sparse-keymap))
  191.           (progn
  192.         (setq region-specific-dispatch-keymap (make-keymap))
  193.         ;; make them all dispatch.  We will later "reset" several
  194.         ;; of these key bindings to the same thing, but so what?
  195.         (fillarray region-specific-dispatch-keymap 'region-specific-keybinding-exec)))
  196.       (use-local-map region-specific-dispatch-keymap)
  197.       ;; get the help key so that describe-bindings displays the
  198.       ;; "expected" thing.
  199.       (define-key region-specific-dispatch-keymap (char-to-string help-char)
  200.         'region-specific-keybinding-exec)
  201.       ;; see meta-region-specific-keybinding-exec for explanation.
  202.       (let ((kmap (make-keymap)))
  203.         (fillarray kmap 'meta-region-specific-keybinding-exec)
  204.         (define-key region-specific-dispatch-keymap (char-to-string meta-prefix-char) kmap)))
  205.     (let ((struct (do ((l region-specific-info-list (cdr l)))
  206.               ((or (null l)
  207.                    (eq mode (region-specific-info-mode-name (car l))))
  208.                (car l)))))
  209.       ;; delete the old one, we'll create a new one below.  Reusing the
  210.       ;; old instance requires setf of structure accessors, which
  211.       ;; doesn't work with old versions of the byte compiler.
  212.       (when struct
  213.         (setq region-specific-info-list (delq struct region-specific-info-list)))
  214.       (if (null buffer)
  215.           ;; null buffer --> ignore this mode from now on.
  216.           (when (null region-specific-info-list)
  217.         ;; this was the last one, might as well disable it all the way.
  218.         (define-region-specific-keybindings nil nil nil))
  219.           (let* ((keymap (save-excursion (set-buffer buffer) (current-local-map)))
  220.              (syntax (save-excursion (set-buffer buffer) (syntax-table)))
  221.              (struct (make-region-specific-info :mode-name mode
  222.                             :pred-fun  predicate
  223.                             :keymap    keymap
  224.                             :buffer    buffer
  225.                             :prep-fun  (or prep-fun 'identity)
  226.                             :syntax-table syntax)))
  227.         (push struct region-specific-info-list)
  228.         ;; for any key defined in the keymap for that mode, define
  229.         ;; it locally to call the dispatch function.
  230.         (mapkeymap (function (lambda (k ignore)
  231.                  ;; all meta chars are handled above.
  232.                  (unless (eq k meta-prefix-char)
  233.                    (define-key region-specific-dispatch-keymap
  234.                    (char-to-string k)
  235.                  'region-specific-keybinding-exec))))
  236.                keymap)
  237.         )))))
  238.   nil)
  239.  
  240. (defun read-cmd-in-map (map &optional install-map)
  241.   (let ((omap (current-local-map)))
  242.     (unwind-protect
  243.      (progn
  244.        (use-local-map map)
  245.        (let* ((seq (read-key-sequence nil))
  246.           (lcmd (lookup-key (current-local-map) seq))
  247.           (gcmd (lookup-key global-map seq))
  248.           (cmd (or (and (not (numberp lcmd)) lcmd)
  249.                (and (not (numberp gcmd)) gcmd))))
  250.          (if cmd
  251.          (values cmd (eq cmd lcmd))
  252.          (values 'undefined nil))))
  253.       (unless install-map
  254.     (use-local-map omap)))))
  255.  
  256. (defun region-specific-keybinding-exec (&optional CmD)
  257.   "Execute a command from the original keymap, or from one of the region
  258. specific modes depending on context.  If CMD is nil, then the command is 
  259. determined by reading the keyboard in an appropriate keymap.  Otherwise
  260. CMD should be a function to call with the variable bindings for the
  261. appropriate mode established."
  262.   (interactive)
  263.   ;; see if any of the predicate functions identifies the point as being
  264.   ;; within a "region-specific" region.
  265.   (let* ((info nil)
  266.      (val nil))
  267.     (do ((l region-specific-info-list (cdr l)))
  268.     ((or val (null l)))
  269.       (when (setq val (funcall (region-specific-info-pred-fun (car l))))
  270.     (setq info (car l))))
  271.  
  272.     ;; WARNING: there are lots of ordering dependencies in the following,
  273.     ;; e.g. read-cmd-in-map must be done before calling the prep-fun, etc.  Be
  274.     ;; careful if you reorder anything.  This is at least in part a
  275.     ;; problem because many "functions" return state information
  276.     ;; about the "current" situation, rather than taking arguments, e.g.
  277.     ;; current-local-map, rather than bufer-local-map, etc.
  278.     (let ((buf (current-buffer))
  279.       (orig-syntax-table (syntax-table))
  280.       dest-map dest-syntax-table)
  281.       ;; leave the keymap the command is read from installed so that
  282.       ;; things like describe-bindings gets the right bindings for the
  283.       ;; given situation.
  284.       (unwind-protect
  285.        (let ((Call-Fun 'call-interactively)
  286.          localp)
  287.          (if CmD
  288.          ;; CmD was specified as an argument.
  289.          (setq Call-Fun 'funcall
  290.                localp info)
  291.          (progn
  292.            ;; this assumes that this fun is bound to a "top level"
  293.            ;; command (i.e. not a sequence within a prefix map).
  294.            (setq unread-command-char last-input-char)
  295.            (if (null val)
  296.                (setq CmD (read-cmd-in-map original-keymap t)
  297.                  localp nil)
  298.                (multiple-value-setq (CmD localp)
  299.              (read-cmd-in-map (region-specific-info-keymap info) t)))
  300.            (setq this-command CmD)))
  301.          (setq dest-map (current-local-map))
  302.          ;; this implements region specific modes, not a hierarchy of
  303.          ;; modes (i.e. if not found in this local mode, try the next
  304.          ;; local mode), which may be more appropriate.  
  305.          (if localp
  306.          (let ((var-alist (buffer-local-variables (region-specific-info-buffer info))))
  307.            (save-restriction
  308.              (funcall (region-specific-info-prep-fun info) val)
  309.              ;; set syntax table must be done AFTER calling region
  310.              ;; prep function since the prep function assumes it
  311.              ;; is still in the mode of the original buffer, and
  312.              ;; changing syntax on it could break things like sexp
  313.              ;; traversal. 
  314.              (set-syntax-table (setq dest-syntax-table
  315.                          (region-specific-info-syntax-table info)))
  316.              ;; this will of course die miserably if the info-buffer has a
  317.              ;; local variable named "CmD" or Call-Fun!!
  318.              (progv (mapcar 'car var-alist)
  319.              (mapcar 'cdr var-alist)
  320.                (funcall Call-Fun CmD))))
  321.          (progn
  322.            (when val
  323.              ;; set syntax table when in a specific region, even
  324.              ;; for globally defined commands.  Necessary for
  325.              ;; things like forward-sexp!
  326.              (set-syntax-table (setq dest-syntax-table
  327.                          (region-specific-info-syntax-table info))))
  328.            ;; cmd was defined in global map
  329.            (funcall Call-Fun CmD))))
  330.     ;; buffer may be deleted.
  331.     (when (buffer-name buf)
  332.       (save-excursion
  333.         ;; cmd may have switched buffers!
  334.         (set-buffer buf)
  335.         ;; If the executed command didn't change the keymap, then
  336.         ;; restore the saved map.
  337.         (when (and (eq (current-local-map) dest-map)
  338.                ;; If the last command disabled all region specific
  339.                ;; bindings, then the map is the same, but the dispatch
  340.                ;; map has been eliminated.
  341.                region-specific-dispatch-keymap)
  342.           (use-local-map region-specific-dispatch-keymap))
  343.         ;; If the executed command didn't change the syntax table, then
  344.         ;; restore the saved one.
  345.         (when (eq (syntax-table) dest-syntax-table)
  346.           (set-syntax-table orig-syntax-table))))))))
  347.  
  348. ;;; This is a highly bletcherous piece of cruft.  It is caused by the fact
  349. ;;; that the 18.55 keyboard reader, when reading meta characters, IGNORES
  350. ;;; local keymaps which have bindings for meta-prefix-char which are not
  351. ;;; themselves keymaps (see read_key_sequence in file keyboard.c in the
  352. ;;; vicinity of the string "Are the definitions prefix characters?").  So,
  353. ;;; to get around this, we define a keymap, make all the entries in it
  354. ;;; point to this function, re-meta the character the meta flag was
  355. ;;; stripped from, then proceed as usual.  
  356. ;;; Clear as mud.  [alarson:19910725.1157CST]
  357. (defun meta-region-specific-keybinding-exec ()
  358.   (interactive)
  359.   (setq last-input-char (logior 256 last-input-char))
  360.   (region-specific-keybinding-exec))
  361.  
  362.  
  363. ;;;; --------------------------------------------------------------------
  364. ;;;; The following is an example usage of the above.  It should really be
  365. ;;;; put in a separate file.
  366. ;;;; --------------------------------------------------------------------
  367.  
  368. (defvar latex-strings-mode nil)
  369.  
  370. (defvar latex-strings-mode-double-quote-is-lisp nil
  371.   "*If true, a double quote character in a latex string will generate a double
  372. quote rather than a pair of single quotes as in latex-mode.")
  373.  
  374. (defun latex-strings-mode (&optional arg)
  375.   "A minor mode for lisp-mode modes that causes keyboard commands within
  376. strings to be treated as though they were entered while in latex-mode.
  377. Toggles mode on and off, with arg force on.
  378.  
  379. See also:
  380.   variable latex-strings-mode-double-quote-is-lisp"
  381.  
  382.   (interactive "P")
  383.   (when (not (assoc 'latex-strings-mode minor-mode-alist))
  384.     (push '(latex-strings-mode  " LaTeX-Strings") minor-mode-alist))
  385.   (make-local-variable 'latex-strings-mode)
  386.   (setq latex-strings-mode (or arg (not latex-strings-mode)))
  387.   ;; update mode line
  388.   (set-buffer-modified-p (buffer-modified-p))
  389.   (define-region-specific-keybindings
  390.       'latex-strings-mode
  391.       ;; nil disables bindings for this region-specific mode.
  392.       (when latex-strings-mode
  393.     (save-excursion
  394.       (set-buffer (get-buffer-create " *some-random-latex-mode-buffer*"))
  395.       (latex-mode)
  396.       (current-buffer)))
  397.     'lisp-in-a-string-p
  398.     'narrow-to-region-around-string)
  399.   ;; double quote is both a latex-mode binding, and the terminator for
  400.   ;; lisp strings.  If we leave it as a tex-mode thing, then you have a
  401.   ;; mess of a time terminating lisp strings.  This slightly messes up the
  402.   ;; describe-bindings documentation, but its just not liveable
  403.   ;; otherwise.
  404.   ;; Apparently some people prefer it. [alarson:19920225.0848CST]
  405.   (when (and latex-strings-mode
  406.          latex-strings-mode-double-quote-is-lisp)
  407.     (local-unset-key "\"")))
  408.  
  409. (defvar lisp-latex-string-begin "[^\\\"]*\""
  410.   "*A regexp that matches the beginning of a lisp string which will be treated
  411. as a latex-string.  It must not start with whitespace.  Typical usage is to
  412. restrict latex strings to be a subset of all lisp strings.")
  413.  
  414. (defun lisp-in-a-string-p ()
  415.   (save-match-data
  416.    (let* ((val-list (parse-partial-sexp (save-excursion (beginning-of-defun)
  417.                             (point))
  418.                     (point)))
  419.       (in-a-string (nth 3 val-list))
  420.       (last-complete-sexp-begin (nth 2 val-list)))
  421.      (when in-a-string
  422.        (save-excursion
  423.      (if (null last-complete-sexp-begin)
  424.          ;; apparently if there is no complete sexp (e.g. a string as the
  425.          ;; first form in a file), this can be nil
  426.          (re-search-backward lisp-latex-string-begin (point-min) t)
  427.          (progn
  428.            (goto-char last-complete-sexp-begin)
  429.            (forward-sexp)
  430.            ;; ... lisp-skip-whitespace my lisp-mode function...
  431.            ;; Skip over whitespace and comments.
  432.            (re-search-forward "\\([ \t\n]+\\|;.*\\)*")))
  433.      (when (looking-at lisp-latex-string-begin) (point)))))))
  434.   
  435. (defun narrow-to-region-around-string (string-start)
  436.   ;; condition case is because the string may not be terminated properly,
  437.   ;; if not we still want the user cmd to execute.
  438.   (save-match-data 
  439.    (save-excursion
  440.      (goto-char string-start)
  441.      (condition-case v
  442.      ;; start region AFTER the opening quote.
  443.      (let ((beg (or (and (looking-at lisp-latex-string-begin)
  444.                  (match-end 0))
  445.             string-start)))
  446.        (forward-sexp)
  447.        ;; include a final newline if possible.  Several of the text mode
  448.        ;; commands (especially fill-paragraph) insert a final newline if
  449.        ;; one doesn't exist.
  450.        (when (looking-at "[ \t]*$")
  451.          (forward-line 1))
  452.        (narrow-to-region beg (point)))
  453.        (error)))))
  454.