Abbrev tables in elisp with some extra stuff (was: Abbrev should preserve case)

[Stefan Monnier]

>     I'm not sure I understand the question: of course we know how to avoid the
>     problem.  And we know that it's really harmful if you happen to have
>     variable names such as Case or CASE or cAse.

> Now I see the point.  Yes, making that abbrev case-sensitive would be
> a useful thing to do.

>     I do not want to change the default case-insensitivity of abbrevs, but
>     I think it'd be worthwhile to be able to specify some case-sensitive
>     abbrevs as well.

> That is fine with me.

The patch below does the following:
- reimplement the abbrev.c code in Elisp.  abbrev.c can then be removed.
- add a docstring arg to define-abbrev-table.
- add property lists to abbrev-tables.  Some properties have special meaning:
  - :parents contains a list of abbrev tables from which this table inherits
    abbreviations.
  - :case-preserve non-nil means that abbreviations are lookedup without
    case-folding, and the expansion is not capitalized/upcased.
  - :syntax-table holds the syntax table to use to find the relevant word.
  - :abbrev-before-point-function holds a function to use to find the
    abbrev at point.  It should take no argument and return a list of the
    form (NAME SYM START END) where NAME is the abbrev name as found in the
    buffer, SYM is the abbrev, START and END are the buffer positions where
    NAME was found (i.e. NAME = (buffer-substring START END)).  It should
    preserve point.
  - :enable-function can be set to a function of no argument which returns
    non-nil iff the abbrevs in this table should be used for this instance
    of `expand-abbrev'.  Useful to disable skeleton-abbrevs in strings and
    comments.
- allow local-abbrev-table to hold a list of abbrev tables so minor
  modes can add their own abbrev tables as well (useful for mailabbrev.el).
- add a variable abbrev-auto-activated-tables that can be used to disable
  all but some specific tables.  This can be used to implement
  mail-abbrevs-only.

It also has a few more new features that I tried and then dropped or
forgot about, so if/when this code is accepted, it'll need a bit of clean up
before installation.


        Stefan


--- orig/lisp/abbrev.el
+++ mod/lisp/abbrev.el
@@ -363,6 +363,504 @@
            (if (or noquery (y-or-n-p (format "Expand `%s'? " string)))
                (expand-abbrev)))))))
 
+;;; Abbrev properties.
+
+
+;; Todo:
+;; - abbrev table may be chosen based on context (e.g. mail-abbrev uses an
+;;   ugly pre-abbrev-expand-hook in order to do abbrev-expansion in the
+;;   header differently from abbrev expansion in the rest of the message).
+;; - multi-word or non-word abbrevs?
+;; - abbrevs could have a `predicate' so you can disable them in strings and
+;;   comments, for example.  Maybe the predicate should be on the table
+;;   rather than on individual abbrevs.  This may be enough to cover the
+;;   above request for context-dependent abbrevs.
+
+(defun abbrev-table-get (table prop)
+  "Get the PROP property of abbrev table TABLE."
+  (let ((sym (intern-soft "" table)))
+    (if sym (get sym prop))))
+
+(defun abbrev-table-put (table prop val)
+  "Set the PROP property of abbrev table TABLE to VAL."
+  (let ((sym (intern "" table)))
+    (set sym nil)           ; Make sure it won't be confused for an abbrev.
+    (put sym prop val)))
+
+(defun abbrev-get (sym prop)
+  (let ((plist (symbol-plist sym)))
+    (if (listp plist)
+        (plist-get plist prop)
+      (if (eq 'count prop) plist))))
+
+(defun abbrev-put (sym prop val)
+  (let ((plist (symbol-plist sym)))
+    (if (consp plist)
+        (put sym prop val)
+      (setplist sym (if (eq 'count prop) val
+                      (list 'count plist prop val))))))
+
+(defmacro abbrev-with-wrapper-hook (var &rest body)
+  "Run BODY wrapped with the VAR hook.
+VAR is a special hook: its functions are called with one argument which
+is the \"original\" code, so the hook function can wrap the original function,
+can call it several times, or even not call it at all.
+This is similar to an `around' advice."
+  (declare (indent 1) (debug t))
+  `(labels ((loop (--abrev-funs-- --abbrev-global--)
+                  (lexical-let ((funs --abbrev-funs--)
+                                (global --abbrev-global--))
+                    (if (consp funs)
+                        (if (eq t (car funs))
+                            (loop (append global (cdr funs)) nil)
+                          (funcall (car funs)
+                                   (lambda () (loop (cdr funs) global))))
+                      ,@body))))
+     (loop ,var (if (local-variable-p ',var) (default-value ',var)))))
+         
+
+;;; Code that used to be implemented in src/abbrev.c
+
+(defvar abbrev-table-name-list '(fundamental-mode-abbrev-table
+                                global-abbrev-table)
+  "List of symbols whose values are abbrev tables.")
+
+(defun make-abbrev-table (&optional props)
+  "Create a new, empty abbrev table object."
+  ;; The value 59 is an arbitrary prime number.
+  (let ((table (make-vector 59 0)))
+    (while (consp props)
+      (abbrev-table-put table (pop props) (pop props)))
+    table))
+
+(defvar global-abbrev-table (make-abbrev-table)
+  "The abbrev table whose abbrevs affect all buffers.
+Each buffer may also have a local abbrev table.
+If it does, the local table overrides the global one
+for any particular abbrev defined in both.")
+
+(defvar abbrev-minor-mode-tables nil
+  "List of additional abbrev tables.")
+(make-variable-buffer-local 'abbrev-minor-mode-tables)
+
+(defvar fundamental-mode-abbrev-table
+  (let ((table (make-abbrev-table)))
+    ;; Set local-abbrev-table's default to be fundamental-mode-abbrev-table.
+    (setq-default local-abbrev-table table)
+    table)
+  "The abbrev table of mode-specific abbrevs for Fundamental Mode.")
+
+(defvar abbrevs-changed nil
+  "Set non-nil by defining or altering any word abbrevs.
+This causes `save-some-buffers' to offer to save the abbrevs.")
+
+(defcustom abbrev-all-caps nil
+  "Set non-nil means expand multi-word abbrevs all caps if abbrev was so."
+  :type 'boolean
+  :group 'abbrev-mode)
+
+(defvar abbrev-start-location nil
+  "Buffer position for `expand-abbrev' to use as the start of the abbrev.
+When nil, use the word before point as the abbrev.
+Calling `expand-abbrev' sets this to nil.")
+
+(defvar abbrev-start-location-buffer nil
+  "Buffer that `abbrev-start-location' has been set for.
+Trying to expand an abbrev in any other buffer clears 
`abbrev-start-location'.")
+
+(defvar last-abbrev nil
+  "The abbrev-symbol of the last abbrev expanded.  See `abbrev-symbol'.")
+
+(defvar last-abbrev-text nil
+  "The exact text of the last abbrev expanded.
+nil if the abbrev has already been unexpanded.")
+
+(defvar last-abbrev-location 0
+  "The location of the start of the last abbrev expanded.")
+
+;; (defvar local-abbrev-table fundamental-mode-abbrev-table
+;;   "Local (mode-specific) abbrev table of current buffer.")
+;; (make-variable-buffer-local 'local-abbrev-table)
+
+(defcustom pre-abbrev-expand-hook nil
+  "Function or functions to be called before abbrev expansion is done.
+This is the first thing that `expand-abbrev' does, and so this may change
+the current abbrev table before abbrev lookup happens."
+  :type 'hook
+  :group 'abbrev-mode)
+
+(defun clear-abbrev-table (table)
+  "Undefine all abbrevs in abbrev table TABLE, leaving it empty."
+  (setq abbrevs-changed t)
+  (dotimes (i (length table))
+    (aset table i 0)))
+
+(defun define-abbrev (table name expansion &optional hook count system-flag
+                            ;; In case the abbrev list passed to
+                            ;; `define-abbrev-table' includes extra elements
+                            ;; that we should ignore.
+                            &rest ignore)
+  "Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK.
+NAME must be a string, and should be lower-case.
+EXPANSION should usually be a string.
+To undefine an abbrev, define it with EXPANSION = nil.
+If HOOK is non-nil, it should be a function of no arguments;
+it is called after EXPANSION is inserted.
+If EXPANSION is not a string, the abbrev is a special one,
+ which does not expand in the usual way but only runs HOOK.
+
+COUNT, if specified, gives the initial value for the abbrev's
+usage-count, which is incremented each time the abbrev is used.
+\(The default is zero.)
+
+SYSTEM-FLAG, if non-nil, says that this is a \"system\" abbreviation
+which should not be saved in the user's abbreviation file.
+Unless SYSTEM-FLAG is `force', a system abbreviation will not
+overwrite a non-system abbreviation of the same name."
+  (unless count (setq count 0))
+  (let ((sym (intern name table)))
+    ;; Don't override a prior user-defined abbrev with a system abbrev,
+    ;; unless system-flag is `force'.
+    (unless (and (not (memq system-flag '(nil force)))
+                 (boundp sym) (symbol-value sym)
+                 (not (abbrev-get sym 'system-flag)))
+      (unless (or system-flag
+                  (and (boundp sym) (fboundp sym)
+                       ;; load-file-name
+                       (equal (symbol-value sym) expansion)
+                       (equal (symbol-function sym) hook)))
+        (setq abbrevs-changed t))
+      (set sym expansion)
+      (fset sym hook)
+      (setplist sym (if (null system-flag) count
+                      (list 'count count 'system-flag system-flag))))
+    name))
+
+(defun abbrev--check-chars (abbrev global)
+  "Check if the characters in ABBREV have word syntax in either the
+current (if global is nil) or standard syntax table."
+  (with-syntax-table
+      (cond ((null global) (standard-syntax-table))
+            ;; ((syntax-table-p global) global)
+            (t (syntax-table)))
+    (when (string-match "\\W" abbrev)
+      (let ((badchars ())
+            (pos 0))
+        (while (string-match "\\W" abbrev pos)
+          (pushnew (aref abbrev (match-beginning 0)) badchars)
+          (setq pos (1+ pos)))
+        (error "Some abbrev characters (%s) are not word constituents %s"
+               (apply 'string (nreverse badchars))
+               (if global "in the standard syntax" "in this mode"))))))
+
+(defun define-global-abbrev (abbrev expansion)
+  "Define ABBREV as a global abbreviation for EXPANSION.
+The characters in ABBREV must all be word constituents in the standard
+syntax table."
+  (interactive "sDefine global abbrev: \nsExpansion for %s: ")
+  (abbrev--check-chars abbrev 'global)
+  (define-abbrev global-abbrev-table (downcase abbrev) expansion))
+
+(defun define-mode-abbrev (abbrev expansion)
+  "Define ABBREV as a mode-specific abbreviation for EXPANSION.
+The characters in ABBREV must all be word-constituents in the current mode."
+  (interactive "sDefine mode abbrev: \nsExpansion for %s: ")
+  (unless local-abbrev-table
+    (error "Major mode has no abbrev table"))
+  (abbrev--check-chars abbrev nil)
+  (define-abbrev local-abbrev-table (downcase abbrev) expansion))
+
+(defvar abbrev-auto-activated-tables t
+  ;; Could be expanded to be a predicate.
+  "List of abbrev tables that can be used when `expand-abbrev' is called 
implicitly.
+If t, use all installed tables.")
+
+(defun abbrev-set-member (elem set)
+  (cond
+   ((functionp set) (funcall set elem))
+   ((eq (car-safe set) 'not) (not (abbrev-set-member elem (cadr set))))
+   (t (member elem set))))
+
+(defun abbrev-active-tables (&optional tables)
+  (cond
+   ((consp tables) tables)
+   ((vectorp tables) (list tables))
+   (t
+    (let ((tables (append abbrev-minor-mode-tables
+                          (if (listp local-abbrev-table)
+                              (append local-abbrev-table
+                                      (list global-abbrev-table))
+                            (list local-abbrev-table global-abbrev-table)))))
+      (if (or (eq t abbrev-auto-activated-tables)
+              (eq this-command 'expand-abbrev))
+          tables
+        (dolist (table (prog1 tables (setq tables nil)) tables)
+          (if (abbrev-set-member table abbrev-auto-activated-tables)
+              (push table tables))))))))
+          
+
+(defun abbrev-symbol (abbrev &optional table)
+  "Return the symbol representing abbrev named ABBREV.
+This symbol's name is ABBREV, but it is not the canonical symbol of that name;
+it is interned in an abbrev-table rather than the normal obarray.
+The value is nil if that abbrev is not defined.
+Optional second arg TABLE is abbrev table to look it up in.
+The default is to try buffer's mode-specific abbrev table, then global table."
+  (let ((tables (abbrev-active-tables table))
+        sym)
+    (while (and tables (not (symbol-value sym)))
+      (let ((table (pop tables))
+            (case-fold (not (abbrev-table-get table :case-preserve))))
+        (setq tables (append (abbrev-table-get table :parents) tables))
+        (setq sym (intern-soft (if case-fold (downcase abbrev) abbrev) table))
+        (if (and (not case-fold) (symbol-value sym))
+            ;; The :case-preserve property normally belongs to the
+            ;; abbrev-table, but the use of this abbrev needs to know if
+            ;; this abbrev came from a case preserving table or not, so we
+            ;; save a copy in the abbrev itself.
+            (abbrev-put sym :case-preserve t))))
+    (if (symbol-value sym)
+        sym)))
+              
+
+(defun abbrev-expansion (abbrev &optional table)
+  "Return the string that ABBREV expands into in the current buffer.
+Optionally specify an abbrev table as second arg;
+then ABBREV is looked up in that table only."
+  (symbol-value (abbrev-symbol abbrev table)))
+
+(defun abbrev-before-point-exhaustive-search (table)
+  "Sample :abbrev-before-point-function."
+  (save-excursion
+    (skip-syntax-backward " ")
+    (let (res)
+      (mapatoms (lambda (sym)
+                  (when (symbol-value sym)
+                    (let ((name (symbol-name sym)))
+                      (when (search-backward name (- (point) (length name)) t)
+                        (setq res (list name sym
+                                        (match-beginning 0) (match-end 0)))))))
+                table)
+      res)))
+
+(defun abbrev--before-point ()
+  "Try and find an abbrev before point.  Return it if found, nil otherwise."
+  (unless (eq abbrev-start-location-buffer (current-buffer))
+    (setq abbrev-start-location nil))
+
+  (let ((tables (abbrev-active-tables))
+        (pos (point))
+        start end sym)
+
+    (if abbrev-start-location
+        (progn
+          (setq start abbrev-start-location)
+          (setq abbrev-start-location nil)
+          ;; Remove the hyphen inserted by `abbrev-prefix-mark'.
+          (if (and (< start (point-max))
+                   (eq (char-after start) ?-))
+              (delete-region start (1+ start)))
+          (skip-syntax-backward " ")
+          (setq end (point))
+          (setq name (buffer-substring start end))
+          (setq sym (abbrev-symbol name tables))
+          ;; Restore point.
+          (goto-char pos))
+        
+      (while (and tables (not sym))
+        (let* ((table (pop tables))
+               (fun (abbrev-table-get table :abbrev-before-point-function))
+               (enable-fun (abbrev-table-get table :enable-function)))
+          (setq tables (append (abbrev-table-get table :parents) tables))
+          (with-syntax-table (or (abbrev-table-get table :syntax-table)
+                                 (syntax-table))
+            (if fun
+                ;; Use abbrev-before-point-function if provided.
+                (let ((res (funcall fun table)))
+                  (setq name (pop res)  sym (pop res)
+                        start (pop res) end (pop res)))
+              (and (or (not enable-fun) (funcall enable-fun))
+                   (setq start (and (forward-word -1) (point)))
+                   (setq end   (and (forward-word 1) (min (point) pos)))
+                   (setq name (buffer-substring start end))
+                   ;; This will also look it up in parent tables.  This is
+                   ;; not on purpose, but it seems harmless.
+                   (setq sym (abbrev-symbol name table)))
+              ;; Restore point.
+              (goto-char pos))))))
+    (if sym (list name sym start end))))
+
+
+(defun expand-abbrev ()
+  "Expand the abbrev before point, if there is an abbrev there.
+Effective when explicitly called even when `abbrev-mode' is nil.
+Returns the abbrev symbol, if expansion took place."
+  (interactive)
+  (run-hooks 'pre-abbrev-expand-hook)
+
+  (destructuring-bind (&optional name sym wordstart wordend)
+      (abbrev--before-point)
+    (when sym
+      (let ((value sym))
+        (unless (or ;; executing-kbd-macro
+                 noninteractive
+                 (window-minibuffer-p (selected-window)))
+          ;; Add an undo boundary, in case we are doing this for
+          ;; a self-inserting command which has avoided making one so far.
+          (undo-boundary))
+        ;; Now sym is the abbrev symbol.
+        (setq last-abbrev-text name)
+        (setq last-abbrev sym)
+        (setq last-abbrev-location wordstart)
+        ;; Increment use count.
+        (abbrev-put sym 'count (1+ (abbrev-get sym 'count)))
+        ;; If this abbrev has an expansion, delete the abbrev
+        ;; and insert the expansion.
+        (when (stringp (symbol-value sym))
+          (goto-char wordend)
+          (insert (symbol-value sym))
+          (delete-region wordstart wordend)
+          (when (and (not (abbrev-get sym :case-preserve))
+                     (string-match "[[:upper:]]" name))
+            (if (not (string-match "[[:lower:]]" name))
+                ;; Abbrev was all caps.  If expansion is multiple words,
+                ;; normally capitalize each word.
+                (if (and (not abbrev-all-caps)
+                         (save-excursion
+                           (> (progn (backward-word 1) (point))
+                              (progn (goto-char wordstart)
+                                     (forward-word 1) (point)))))
+                    (upcase-initials-region wordstart (point))
+                  (upcase-region wordstart (point)))
+              ;; Abbrev included some caps.  Cap first initial of expansion.
+              (let ((end (point)))
+                ;; Find the initial.
+                (goto-char wordstart)
+                (skip-syntax-forward "^w" (1- end))
+                ;; Change just that.
+                (upcase-initials-region (point) (1+ (point)))))))
+        (when (symbol-function sym)
+          (let* ((hook (symbol-function sym))
+                 (expanded
+                  ;; If the abbrev has a hook function, run it.
+                  (funcall hook)))
+            ;; In addition, if the hook function is a symbol with
+            ;; a non-nil `no-self-insert' property, let the value it
+            ;; returned specify whether we consider that an expansion took
+            ;; place.  If it returns nil, no expansion has been done.
+            (if (and (symbolp hook)
+                     (null expanded)
+                     (get hook 'no-self-insert))
+                (setq value nil))))
+        value))))
+
+(defun unexpand-abbrev ()
+  "Undo the expansion of the last abbrev that expanded.
+This differs from ordinary undo in that other editing done since then
+is not undone."
+  (interactive)
+  (save-excursion
+    (unless (or (< last-abbrev-location (point-min))
+                (> last-abbrev-location (point-max)))
+      (goto-char last-abbrev-location)
+      (when (stringp last-abbrev-text)
+        ;; This isn't correct if last-abbrev's hook was used
+        ;; to do the expansion.
+        (let ((val (symbol-value last-abbrev)))
+          (unless (stringp val)
+            (error "value of abbrev-symbol must be a string"))
+          (delete-region (point) (+ (point) (length val)))
+          ;; Don't inherit properties here; just copy from old contents.
+          (insert last-abbrev-text)
+          (setq last-abbrev-text nil))))))
+
+(defun write--abbrev (sym)
+  (unless (or (null (symbol-value sym)) (abbrev-get sym 'system-flag))
+    (insert "    (")
+    (prin1 name)
+    (insert " ")
+    (prin1 (symbol-value sym))
+    (insert " ")
+    (prin1 (symbol-function sym))
+    (insert " ")
+    (prin1 (abbrev-get sym 'count))
+    (insert ")\n")))
+
+(defun describe--abbrev (sym)
+  (when (symbol-value sym)
+    (prin1 (symbol-name sym))
+    (if (null (abbrev-get sym 'system-flag))
+        (indent-to 15 1)
+      (insert " (sys)")
+      (indent-to 20 1))
+    (prin1 (abbrev-get sym 'count))
+    (indent-to 20 1)
+    (prin1 (symbol-value sym))
+    (when (symbol-function sym)
+      (indent-to 45 1)
+      (prin1 (symbol-function sym)))
+    (terpri)))
+
+(defun insert-abbrev-table-description (name &optional readable)
+  "Insert before point a full description of abbrev table named NAME.
+NAME is a symbol whose value is an abbrev table.
+If optional 2nd arg READABLE is non-nil, a human-readable description
+is inserted.  Otherwise the description is an expression,
+a call to `define-abbrev-table', which would
+define the abbrev table NAME exactly as it is currently defined.
+
+Abbrevs marked as \"system abbrevs\" are omitted."
+  (let ((table (symbol-value name))
+        (symbols ()))
+    (mapatoms (lambda (sym) (if (symbol-value sym) (push sym symbols))) table)
+    (setq symbols (sort symbols 'string-lessp))
+    (let ((standard-output (current-buffer)))
+      (if readable
+         (progn
+           (insert "(")
+           (prin1 name)
+           (insert ")\n\n")
+           (mapc 'describe--abbrev symbols)
+           (insert "\n\n"))
+       (insert "(define-abbrev-table '")
+       (prin1 name)
+       (insert " '(")
+       (mapc 'write--abbrev symbols)
+       (insert "    ))\n\n"))
+      nil)))
+
+(defun define-abbrev-table (tablename definitions
+                                      &optional docstring &rest props)
+  "Define TABLENAME (a symbol) as an abbrev table name.
+Define abbrevs in it according to DEFINITIONS, which is a list of elements
+of the form (ABBREVNAME EXPANSION HOOK USECOUNT SYSTEMFLAG).
+\(If the list is shorter than that, omitted elements default to nil).
+PROPS is a property list to apply to the table.
+Properties with special meaning:
+- :parents contains a list of abbrev tables from which this table inherits
+  abbreviations.
+- :case-preserve non-nil means that abbreviations are lookedup without
+  case-folding, and the expansion is not capitalized/upcased.
+- :syntax-table holds the syntax table to use for to find the relevant word.
+- :abbrev-before-point-function holds a function to use to find the
+  abbrev at point.  It should take no argument and return a list of the
+  form (NAME SYM START END) where NAME is the abbrev name as found in the
+  buffer, SYM is the abbrev, START and END are the buffer positions where
+  NAME was found (i.e. NAME = (buffer-substring START END)).  It should
+  preserve point.
+- :enable-function can be set to a function of no argument which returns
+  non-nil iff the abbrevs in this table should be used for this instance
+  of `expand-abbrev'."
+  (let ((table (if (boundp tablename) (symbol-value tablename))))
+    (unless table
+      (setq table (make-abbrev-table props))
+      (set tablename table)
+      (push tablename abbrev-table-name-list))
+    (when (stringp docstring)
+      (put tablename 'variable-documentation docstring))
+    (dolist (elt definitions)
+      (apply 'define-abbrev table elt))))
+
 (provide 'abbrev)
 
 ;; arch-tag: dbd6f3ae-dfe3-40ba-b00f-f9e3ff960df5