Download
(require 'cl)
(define-minor-mode msf-abbrev-mode
"File based abbrevs"
:init-value nil
:global nil
:group 'msf-abbrev
:lighter ""
:keymap (make-sparse-keymap)
(if msf-abbrev-mode
(progn (msf-abbrev-install-locally major-mode)
(abbrev-mode msf-abbrev-mode))
(msf-abbrev-uninstall-locally major-mode)
(abbrev-mode msf-abbrev-mode)))
(define-global-minor-mode global-msf-abbrev-mode
msf-abbrev-mode msf-abbrev-maybe-enable
:group 'msf-abbrev)
(defcustom msf-abbrev-root (expand-file-name
".emacs.d/mode-abbrevs")
"*Root directory of user abbreviation files.
This directory should have subdirectories such as c-mode, lisp-mode, etc."
:group 'msf-abbrev
:type 'directory)
(defcustom msf-abbrev-always-rescan nil
"*Whether rescan directory when every time enter a major-mode."
:group 'msf-abbrev
:type 'boolean)
(defcustom msf-abbrev-mode-alias nil
"*Definition of mode alias"
:group 'msf-abbrev
:type 'lisp)
(defcustom msf-abbrev-indent-after-expansion nil
"*Whether to indent the region inserted after the abbrev is expanded."
:group 'msf-abbrev
:type 'boolean)
(defcustom msf-abbrev-first-insertion-replaces t
"*Whether to replace a field's content when first inserting text at
it.
If non-nil, and the first change to a field is text insertion then
replace the default content with the inserted text."
:group 'msf-abbrev
:type 'boolean)
(defcustom msf-abbrev-first-deletion-removes nil
"*Whether to remove a fields content when first deleting text.
If non-nil, and the first change to a field is text deletion then
the full field content is removed."
:group 'msf-abbrev
:type 'boolean)
(defcustom msf-abbrev-goto-next-loops nil
"*Whether to loop after the last field in a form.
If non-nil, `msf-cmd-goto-next' goes to the first field in the
form instead of deleting the form and going to the end point."
:group 'msf-abbrev
:type 'boolean)
(defcustom msf-abbrev-after-expansion-hook nil
"Hook called after expansion of an msf abbrev."
:group 'msf-abbrev
:type 'hook)
(defcustom msf-abbrev-choose-method
'msf-choose-selecting
"Function used to get the value for a multiple choice field.
If you specify the name of some another function, please ensure it
has an argument list like `completing-read' does."
:group 'msf-abbrev
:type '(choice
(function-item :tag "Using the msf selection buffer."
msf-choose-selecting)
(function-item :tag "Detect a completion function."
msf-choose-completing)
(function-item :tag "Builtin basic completion"
completing-read)
(function-item :tag "IDO completion"
ido-completing-read)
(function :tag "User specified function"
msf-choose-completing)))
(defvar msf-fld-field-keymap
(let ((map (make-sparse-keymap)))
(define-key map
(kbd "TAB") 'msf-cmd-next-real)
(define-key map
(kbd "S-TAB") 'msf-cmd-previous-real)
(define-key map
(kbd "C-c n") 'msf-cmd-next-real)
(define-key map
(kbd "C-c p") 'msf-cmd-previous-real)
(define-key map
(kbd "<S-iso-lefttab>") 'msf-cmd-previous-real)
(define-key map
(kbd "C-c f") 'msf-cmd-next-fld)
(define-key map
(kbd "C-c b") 'msf-cmd-previous-fld)
(define-key map
(kbd "C-c >") 'msf-cmd-goto-end)
(define-key map
(kbd "C-c <") 'msf-cmd-goto-start)
(define-key map
(kbd "M-RET") 'msf-cmd-end-form)
(define-key map
(kbd "C-c e") 'msf-cmd-make-editable)
(define-key map
(kbd "C-c q") 'msf-cmd-clean-field)
(define-key map
(kbd "C-c Q") 'msf-cmd-clean-form)
map)
"Keymap active on form simple fields")
(defvar msf-fld-linked-keymap
(let ((map (copy-keymap msf-fld-field-keymap)))
(define-key map
(kbd "C-c u") 'msf-cmd-unlink)
map)
"Keymap active on form linked fields")
(defvar msf-fld-choice-keymap
(let ((map (copy-keymap msf-fld-field-keymap)))
(define-key map
(kbd "RET") 'msf-cmd-make-choice)
map)
"Keymap active on form choice fields")
(defface msf-fld-field-face
(list (cons t (cons :inherit (list 'highlight))))
"Face used to highlight form simple fields"
:group 'msf-abbrev)
(defface msf-fld-linked-face
(list (cons t (cons :inherit (list 'lazy-highlight))))
"Face used to highlight form linked fields"
:group 'msf-abbrev)
(defface msf-fld-choice-face
(list (cons t (cons :inherit (list 'button))))
"Face used to highlight form choice fields"
:group 'msf-abbrev)
(defvar msf-abbrev-scan-time nil)
(defvar msf-abbrev-form-priority 0
"Priority counter used for form overlays")
(defvar msf-abbrev-mode-abbrevs nil
"Global alist of mode abbrevs")
(defvar msf-fld-before-deletion-hook
nil
"Hook to be run before a text deletion ocurrs in a field")
(defvar msf-fld-after-deletion-hook
'msf-fld-after-deletion
"Hook to be run after a text deletion ocurrs in a field")
(defvar msf-fld-before-insertion-hook
nil
"Hook to be run before a text insertion ocurrs in a field")
(defvar msf-fld-after-insertion-hook
'msf-fld-after-insertion
"Hook to be run after a text insertion ocurrs in a field")
(defvar msf-fld-before-resurrection-hook
'msf-fld-before-resurrection
"Hook to be run before a field will be killed")
(defvar msf-fld-after-resurrection-hook
'msf-fld-after-resurrection
"Hook to be run after a field has been resurrected")
(defvar msf-fld-linked-modification-hooks
'((fld-after-insertion-hook
msf-fld-linked-replicate)
(fld-after-deletion-hook
msf-fld-linked-replicate)
(fld-before-resurrection-hook
msf-fld-linked-before-resurrection)
(fld-after-resurrection-hook
msf-fld-linked-after-resurrection))
"Hooks to be run on modification to a linked field")
(setplist 'msf-fld-field-category
`(face msf-fld-field-face
keymap ,msf-fld-field-keymap))
(setplist 'msf-fld-linked-category
`(face msf-fld-linked-face
fld-modification-hooks
msf-fld-linked-modification-hooks
keymap ,msf-fld-linked-keymap))
(setplist 'msf-fld-choice-category
`(face msf-fld-choice-face
keymap ,msf-fld-choice-keymap))
(defun msf-abbrev-directory-files (dir)
"List abbrev files on DIR"
(delq nil
(mapcar
(lambda (x)
(if (or (string-match "^\\." (file-name-nondirectory x))
(string-match "~$" (file-name-nondirectory x)))
nil x))
(directory-files dir t))))
(defun msf-abbrev-eval(lisp)
(eval (cond ((consp lisp) lisp)
((and (stringp lisp) (file-exists-p lisp))
(with-temp-buffer
(insert-file-contents lisp)
(read (buffer-substring-no-properties
(point-min) (point-max)))))
((stringp lisp) (read lisp))
(t (error "Invalid argument type: %s"
(type-of lisp))))))
(defun msf-abbrev-add-to-list (list element &optional append)
(let ((old (assoc (car element) (symbol-value list))))
(if old (setcdr old (cdr element))
(add-to-list list element append))))
(defsubst msf-abbrev-file-mtime (file &optional id-format)
(nth 5 (file-attributes file id-format)))
(defun msf-abbrev-mode-alias (modename)
(let ((mode (intern-soft modename)))
(setq mode (assoc-default mode msf-abbrev-mode-alias))
(if mode
(symbol-name mode)
(let ((cpls
(file-name-all-completions
(concat modename ".aliases.") msf-abbrev-root))
(dest modename))
(when cpls
(assert (string-match "\\(.*\\)\\.aliases\\.\\(.*\\)" (car cpls)))
(setq dest (match-string 2 (car cpls))))
dest))))
(defun msf-abbrev-locate-mode-dir (modename)
(concat (file-name-as-directory msf-abbrev-root)
(msf-abbrev-mode-alias modename)))
(defsubst msf-abbrev-file-newer-than-p (file time)
(time-less-p time (msf-abbrev-file-mtime file)))
(defun msf-abbrev-major-mode-heuristic (symbol)
(and (fboundp symbol)
(string-match ".*-mode$" (symbol-name symbol))))
(defun msf-abbrev-maybe-enable nil
"Called if `globa-msf-abbrev-mode' is enabled
Enable `msf-abbrev-mode' only for those buffer whose
major-mode has an abbrev directory or init file."
(when (or (assq major-mode msf-abbrev-mode-abbrevs)
(file-exists-p
(format "%s%s"
(file-name-as-directory msf-abbrev-root)
major-mode))
(file-directory-p
(format "%s%s"
(file-name-as-directory msf-abbrev-root)
major-mode)))
(msf-abbrev-mode 1)))
(defun msf-abbrev-scan-mode (&optional modename replace)
"Scan abbrevs and generate interactive functions from abbrev
files in the corresponding directory of MODENAME.
MODENAME must be a symbol like 'ruby-mode, defaults to the
current value of the variable `major-mode'
If REPLACE is non-nil then the abbrevs for MODENAME are removed
before scanning the directory."
(interactive
(list (intern (completing-read
"Scan mode: "
obarray 'msf-abbrev-major-mode-heuristic
t (symbol-name major-mode)))
t))
(let (mode table)
(if (or (null modename) (eq modename major-mode))
(setq modename (msf-abbrev-mode-alias
(symbol-name major-mode))
table local-abbrev-table)
(setq modename (msf-abbrev-mode-alias
(symbol-name modename))
table (symbol-value (intern (format "%S-abbrev-table" modename)))))
(setq mode (intern-soft modename))
(assert (symbolp mode))
(let ((last-time (or (cdr (assq mode msf-abbrev-scan-time))
'(0 0)))
(mode-dir (msf-abbrev-locate-mode-dir modename))
(modeab (assq mode msf-abbrev-mode-abbrevs))
init-file)
(when (or (null modeab) replace)
(setq modeab (cdr modeab))
(setq init-file (concat mode-dir ".el"))
(if (and (file-exists-p init-file)
(msf-abbrev-file-newer-than-p init-file last-time))
(load init-file))
(when (file-directory-p mode-dir)
(mapc (lambda (abbr-file)
(msf-abbrev-define-abbrev
(intern (file-name-nondirectory
(file-name-sans-extension
abbr-file)))
(msf-abbrev-eval
`(lambda nil
,(format "Expand content of file %s"
abbr-file)
(msf-abbrev-expand-file ,abbr-file)))
mode))
(remove-if (lambda (file)
(and (assoc (intern (file-name-nondirectory file)) modeab)
(not (msf-abbrev-file-newer-than-p file last-time))))
(msf-abbrev-directory-files mode-dir))))
(msf-abbrev-define-on-table mode table)
(msf-abbrev-add-to-list 'msf-abbrev-scan-time
(cons mode (current-time)))))))
(defun msf-abbrev-install-locally (mode)
"Install abbrevs for MODE in the `local-abbrev-table'"
(msf-abbrev-scan-mode mode msf-abbrev-always-rescan))
(defun msf-abbrev-uninstall-locally (mode)
"Uninstall abbrevs for MODE from the `local-abbrev-table'"
(msf-abbrev-define-on-table mode local-abbrev-table 'undefine))
(defun msf-abbrev-define-on-table (&optional mode table undefine)
"Install msf-abbrevs defined for MODE in TABLE
MODE defaults to the current value of `major-mode'.
TABLE defaults to the local variable `local-abbrev-table'.
If UNDEFINE is non-nil undefine MODE's abbrevs from TABLE"
(or mode (setq mode major-mode))
(or table (setq table local-abbrev-table))
(let ((mode-abbrevs (assq mode msf-abbrev-mode-abbrevs)))
(when mode-abbrevs
(mapc (lambda (name-function)
(let ((name (car name-function))
(expand-function (cdr name-function)))
(define-abbrev table
(symbol-name name)
(if undefine nil "")
expand-function 0 t)))
(cdr mode-abbrevs)))))
(defun msf-abbrev-choose-abbrev (&optional mode requires-match)
(let ((abbrevs (assq (or mode major-mode)
msf-abbrev-mode-abbrevs))
(choice nil)
(choices nil))
(when abbrevs
(mapc (lambda (abbrev)
(setq choices (cons (format "%s" (car abbrev))
choices)))
(cdr abbrevs))
(msf-choose-completing "Abbrev name: " choices nil
requires-match))))
(defun msf-abbrev-define-abbrev (name function &optional mode)
"Define an abbrev for MODE inserted by FUNCTION and
named NAME.
MODE defaults to the current value of the variable `major-mode'.
FUNCTION is called with no arguments by the generated wrapper.
Return the name of the wrapper function with format:
`msf-expand/MODE/NAME'"
(and (stringp name) (setq name (intern name)))
(or mode (setq mode major-mode))
(let (funname fundoc funobj mode-abbrevs)
(setq funname
(intern (format "msf-expand/%s/%s" mode name)))
(setq fundoc
(format "Expansion function for \"%s\" in %s"
name mode))
(if (symbolp function)
(setq fundoc (format "%s wrapping the `%s' function"
fundoc function))
(when (documentation function)
(setq fundoc
(format "%s\n\nDocumentation:\n\n%s"
fundoc
(documentation function)))))
(setq funobj
(msf-abbrev-eval
`(defun ,funname nil ,fundoc
(interactive)
(apply ,function nil)
(msf-abbrev-just-expanded ',funname)
',funname)))
(put funname 'no-self-insert t)
(put funname 'abbrev-name name)
(setq mode-abbrevs
(or (assq mode msf-abbrev-mode-abbrevs)
(list mode)))
(setcdr mode-abbrevs
(append (cdr mode-abbrevs)
(list (cons name funname))))
(setq msf-abbrev-mode-abbrevs
(assq-delete-all mode msf-abbrev-mode-abbrevs))
(add-to-list 'msf-abbrev-mode-abbrevs mode-abbrevs)))
(defun msf-abbrev-expand-abbrev (name &optional mode)
(or mode (setq mode major-mode))
(or (symbolp name) (setq name (intern name)))
(let ((mode-abbrevs (assq mode msf-abbrev-mode-abbrevs)))
(if mode-abbrevs
(let ((expand-function (assq name (cdr mode-abbrevs))))
(if expand-function
(apply (cdr expand-function) nil)
(error "No such abbrev %s for %s" name mode)))
(error "No msf-abbrevs defined for %s" mode))))
(defun msf-abbrev-expand-file (file)
"Insert FILE contents as a form or eval it if the file name
ends with .el"
(if (and (string-match "\\.el$" file)
(file-exists-p file))
(msf-abbrev-eval file)
(msf-form-insert
(with-temp-buffer
(insert-file-contents file)
(buffer-string)))))
(defun msf-abbrev-just-expanded (function)
"Notify that FUNCTION has just made an expansion.
Run `msf-abbrev-after-expansion-hook'"
(run-hooks 'msf-abbrev-after-expansion-hook))
(defun msf-abbrev-generate-init-file (mode)
(interactive
(list (intern (completing-read
"Scan mode: "
msf-abbrev-mode-abbrevs
nil t))))
(let ((modeab (assq mode msf-abbrev-mode-abbrevs))
mode-dir name func form-file)
(setq mode (symbol-name mode)
mode-dir (msf-abbrev-locate-mode-dir mode))
(with-current-buffer (get-buffer-create (concat "*" mode "*"))
(erase-buffer)
(setq buffer-file-name (concat mode-dir ".el"))
(insert ";; -*- mode: emacs-lisp -*-\n")
(emacs-lisp-mode)
(dolist (ab (cdr modeab))
(setq name (symbol-name (car ab))
func (symbol-name (cdr ab))
form-file (concat mode-dir "/" name))
(insert "(defun " func " ()\n"
"\"Expandsion function for " name " in " mode ".\"\n"
"(interactive)\n"
"(msf-form-insert "
(if (file-exists-p form-file)
(format "%S"
(with-temp-buffer
(insert-file-contents form-file)
(buffer-substring-no-properties
(point-min) (point-max))))
(with-temp-buffer
(insert (format "%S"
(symbol-function (cdr ab))))
(goto-char (point-min))
(re-search-forward "msf-form-insert")
(buffer-substring (point) (scan-sexps (point) 1))))
")\n"
"(msf-abbrev-just-expanded (quote " func "))\n"
"(quote " func "))\n\n"))
(insert "(add-to-list 'msf-abbrev-mode-abbrevs\n '("
mode "\n")
(dolist (ab (cdr modeab))
(setq name (symbol-name (car ab))
func (symbol-name (cdr ab)))
(insert " (" name " . " func ")\n"))
(insert " ))")
(switch-to-buffer (current-buffer))
(message "Press C-x C-s to save init file"))))
(defun msf-form-insert (str)
"Insert STR and generate editable fields"
(let ((inhibit-modification-hooks t)
(case-fold-search t)
(form nil))
(goto-char
(save-excursion
(save-match-data
(setq form
(make-overlay (point)
(save-excursion (insert str)
(point))))
(msf-form-put form 'priority
(incf msf-abbrev-form-priority))
(msf-form-put form 'msf-form msf-abbrev-form-priority)
(run-hook-with-args 'msf-form-insert-hook form)
(msf-form-parse-comments form)
(msf-form-parse-trims form)
(msf-form-parse-elisp form)
(msf-form-parse-vars form)
(msf-form-parse-choices form)
(msf-form-parse-fields form)
(msf-form-parse-links form)
(msf-form-parse-queries form)
(msf-form-parse-endpoint form))
(when msf-abbrev-indent-after-expansion
(indent-region (msf-form-start form)
(msf-form-end form)))
(msf-form-put form 'modification-hooks
(list 'msf-form-on-modification))
(msf-form-put form 'insert-in-front-hooks
(list 'msf-form-on-modification))
(msf-form-put form 'insert-behind-hooks
(list 'msf-form-on-modification))
(msf-form-put form 'evaporate t)
(msf-form-start-point form)))
(unless (msf-form-first-fld form)
(msf-form-delete form))))
(defun msf-form-parse-endpoint (form)
(save-excursion
(goto-char (msf-form-start form))
(while (re-search-forward "<\\(cursor\\|start-?point\\)>"
(msf-form-end form) t)
(replace-match "" nil t)
(msf-form-put form 'start-point (point-marker)))
(goto-char (msf-form-start form))
(while (re-search-forward "<end-?point>"
(msf-form-end form) t)
(replace-match "" nil t)
(msf-form-put form 'end-point (point-marker)))))
(defun msf-form-parse-comments (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward "<comment +\".*?\">"
(msf-form-end form) t))
(replace-match "<trim \"\n\">" nil t))))
(defun msf-form-parse-trims (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward
(concat "[ \t\n\r\f]*<\\(trim\\)"
"\\([ \t\n\r\f]+\"\\(.*?\\|"
"[ \t\n\r\f]+\\)\"\\)?>"
"[\t\n\r\f]*")
(msf-form-end form) t))
(let* ((newsep (match-string 3))
(spaces (and newsep (string-to-int newsep))))
(replace-match "")
(cond ((> spaces 0)
(insert-char ? spaces))
((stringp newsep)
(insert newsep))
(t nil))))))
(defun msf-form-parse-vars (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward
"<\\(varlookup\\)[ \t]+\"\\(.*?\\)\">"
(msf-form-end form) t))
(let ((v (match-string 2)))
(replace-match (format "%s" (eval (intern v))
nil t))))))
(defun msf-form-parse-elisp (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward
"<\\(elisp\\|eval\\)[ \t]+\"\\(.*?\\)\">"
(msf-form-end form) t))
(let ((v (match-string 2)))
(replace-match "")
(eval (read v))))))
(defun msf-form-parse-queries (form)
(save-excursion
(goto-char (msf-form-start form))
(let ((query-alist nil))
(while (and (< (point) (msf-form-end form))
(re-search-forward
"\\(<\\(query\\) \"\\(.*?\\)\">\\)"
(msf-form-end form) t))
(let ((key (match-string 3)))
(when (not (assoc key query-alist))
(setq query-alist
(cons (list key (read-from-minibuffer key))
query-alist)))
(replace-match (cadr (assoc key query-alist))))))))
(defun msf-form-parse-fields (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward
(concat "<\\(formjump\\|field\\)"
"\\([ \t\n\r\f]+link=\"\\(..*?\\)\"\\)?"
"[ \t\n\r\f]+\"\\(..*?\\)\">")
(msf-form-end form) t))
(let ((link (match-string 3))
(txt (match-string 4))
(properties '(category msf-fld-field-category)))
(replace-match "" nil t)
(when link
(setq properties
(append (list 'fld-link link
'fld-modification-hooks
'msf-fld-linked-modification-hooks)
properties)))
(msf-fld-insert txt form properties)))))
(defun msf-form-parse-links (form)
(save-excursion
(goto-char (msf-form-start form))
(while (and (< (point) (msf-form-end form))
(re-search-forward
"<link\\(ed\\)?[ \t]+\"\\(..*?\\)\">"
(msf-form-end form) t))
(let (name source)
(setq name (match-string 2))
(replace-match "" nil t)
(setq source (msf-form-first-fld
form nil nil
(list 'fld-link name)))
(if source
(msf-fld-insert
(buffer-substring-no-properties(msf-fld-start source)
(msf-fld-end source))
form
(list 'category 'msf-fld-linked-category
'fld-link name))
(msf-fld-insert
name form
(list 'category 'msf-fld-field-category
'fld-link name
'fld-modification-hooks
'msf-fld-linked-modification-hooks)))))))
(defun msf-form-parse-choices (form)
(save-excursion
(goto-char (msf-form-start form))
(let ((choice-start nil)
(choice-end nil)
(choices nil)
(link nil)
(properties '(category msf-fld-choice-category)))
(while (and (< (point) (msf-form-end form))
(re-search-forward
(concat "<choose"
"\\([ \t]+link=\"\\(..*?\\)\"[ \t]*\\)?>"
"[ \t\n\r\f]*")
(msf-form-end form) t))
(setq link (match-string 2))
(and link
(setq properties
(append (list 'fld-link link
'fld-modification-hooks
'msf-fld-linked-modification-hooks)
properties)))
(replace-match "" nil t)
(setq choice-start (point-marker))
(assert (re-search-forward
"[ \t\n\r\f]*</choose>"
(msf-form-end form) t))
(replace-match "" nil t)
(setq choice-end (point-marker))
(goto-char choice-start)
(setq choices nil)
(while (and (< (point) (msf-form-end form))
(re-search-forward
(concat "[ \t\n\r\f]*<choice +"
"\"\\(..*?\\)\">[ \t\n\r\f]*")
choice-end t))
(setq choices (cons (match-string 1) choices))
(replace-match "" nil t))
(setq choices (reverse choices))
(setq properties (append (list 'fld-choices choices)
properties))
(msf-fld-insert (car choices) form properties)))))
(defun msf-form-start-point (form)
"Return the starting point for the user in this FORM.
If a point was defined with <start-point> then it is returned,
otherwise the first real (not linked) field position. If no
fields are present in the FORM return `msf-form-end-point'"
(or (msf-form-get form 'start-point)
(msf-form-first-real form)
(msf-form-end-point form)))
(defun msf-form-end-point (form)
"Return the end point of FORM"
(or (msf-form-get form 'end-point)
(msf-form-end form)))
(defun msf-form-first-fld (form &optional start end properties category)
"Find the first field position in FORM, if not found return nil.
Search is restricted to FORM boundaries or START and END if they
are given.
If PROPERTIES is given, it must be a list used to restrict search
to those fields wich text-properties has PROPERTIES as a subset.
If CATEGORY is given it must match the field's 'category property"
(catch :field
(let (field)
(or start (setq start (msf-form-start form)))
(or end (setq end (msf-form-end form)))
(while (setq field
(text-property-any start end 'fld-form form))
(cond ((and (subsetp properties (msf-fld-properties field)
:test 'equal)
(cond ((functionp category)
(apply category
(msf-fld-get 'category field)
nil))
(category
(member (msf-fld-get 'category field)
(if (listp category) category
(list category))))
(t t)))
(throw :field (msf-fld-start field)))
((> end (msf-fld-end field))
(setq start (msf-fld-end field)))
(t
(throw :field nil)))))))
(defun msf-form-last-fld (form &optional start end properties category)
"Like `msf-form-first-fld' but search is made backwards."
(save-excursion
(catch :field
(or start (setq start (msf-form-start form)))
(or end (setq end (msf-form-end form)))
(goto-char end)
(while (and (setq field
(previous-single-property-change
(point) 'fld-form nil start)))
(cond ((and (eq (msf-fld-form field) form)
(subsetp properties
(msf-fld-properties field)
:test 'equal)
(cond ((functionp category)
(apply category
(msf-fld-get 'category field)
nil))
(category
(member (msf-fld-get 'category field)
(if (listp category) category
(list category))))
(t t)))
(throw :field (msf-fld-start field)))
((> field start)
(goto-char field))
(t (throw :field nil)))))))
(defsubst msf-form-first-link (form &optional start end properties)
"Return the first link in FORM"
(msf-form-first-fld form start end properties
'msf-fld-linked-category))
(defsubst msf-form-last-link (form &optional start end properties)
"Return the last link in FORM"
(msf-form-last-fld form start end properties
'msf-fld-linked-category))
(defsubst msf-form-first-real (form &optional start end properties)
"Return the first REAL field (not a link) in FORM."
(msf-form-first-fld
form start end properties
(lambda (c) (not (eq c 'msf-fld-linked-category)))))
(defsubst msf-form-last-real (form &optional start end properties)
"Return the last REAL field (not a link) in FORM"
(msf-form-last-fld
form start end properties
(lambda (c) (not (eq c 'msf-fld-linked-category)))))
(defun msf-form-delete (form)
"Destroy FORM and make all fields on it simple text"
(let ((inhibit-modification-hooks t)
(field nil)
(properties nil))
(while (setq field (msf-form-first-fld form field))
(msf-fld-set default-text-properties field))
(delete-overlay form)))
(defsubst msf-form-start (form)
(overlay-start form))
(defsubst msf-form-end (form)
(overlay-end form))
(defsubst msf-form-get (form prop)
(overlay-get form prop))
(defsubst msf-form-put (form prop value)
(overlay-put form prop value))
(defsubst msf-form-at (point)
"Return the form at POINT.
If a field is located at POINT return it's form, otherwise returnp
the form with highest priority if any."
(or (msf-fld-form point)
(let (form (priority -1))
(mapc (lambda (overlay)
(when (and (msf-form-get overlay 'msf-form)
(< priority
(msf-form-get overlay 'priority)))
(setq form overlay)))
(overlays-at point))
form)))
(defun msf-form-on-modification (form after begin end &optional count)
"Run when a modification is made to FORM"
(let ((fld-pos (cond ((eq (msf-fld-form begin) form)
(set-marker (make-marker) begin))
((eq (msf-fld-form end) form)
(set-marker (make-marker) end))
((eq (msf-fld-form (1- end)) form)
(set-marker (make-marker) (1- end)))))
(inhibit-modification-hooks t)
(begin (set-marker (make-marker) begin))
(end (set-marker (make-marker) end))
(hook-name nil)
(fld-hook nil)
(args nil))
(setq args
(cond ((and fld-pos after (= begin end))
(setq hook-name 'fld-after-deletion-hook)
(list form fld-pos begin count))
((and fld-pos after)
(setq hook-name 'fld-after-insertion-hook)
(list form fld-pos begin end))
((and fld-pos (= begin end))
(setq hook-name 'fld-before-insertion-hook)
(list form fld-pos begin))
((and fld-pos
(= (msf-fld-start fld-pos) begin)
(= (msf-fld-end fld-pos) end))
(setq hook-name 'fld-before-resurrection-hook)
(list form begin end))
(fld-pos
(setq hook-name 'fld-before-deletion-hook)
(list form fld-pos begin end))
((and after (/= begin end)
(let ((res (msf-form-get
form
'fld-resurrection)))
(and res (assoc begin res))))
(setq hook-name 'fld-after-resurrection-hook)
(list form begin end))))
(and (boundp 'warning-minimum-log-level)
(lwarn 'msf-abbrev :debug "msf-form-on-modification %s"
(list form after begin end count)))
(when (and hook-name args (not undo-in-progress))
(and (boundp 'warning-minimum-log-level)
(lwarn 'msf-abbrev :debug "%s %s" hook-name args))
(catch :fld-end-modification
(setq fld-hook
(or (and fld-pos
(msf-fld-get 'fld-modification-hooks fld-pos))
(msf-fld-get 'fld-modification-hooks begin)
(msf-fld-get 'fld-modification-hooks end)))
(eval `(run-hook-with-args
',(intern (format "msf-%s" hook-name)) ,@args))
(unless fld-hook
(setq fld-hook
(or (and fld-pos
(msf-fld-get 'fld-modification-hooks
fld-pos))
(msf-fld-get 'fld-modification-hooks begin)
(msf-fld-get 'fld-modification-hooks end))))
(when (and (symbolp fld-hook) (boundp fld-hook))
(setq fld-hook (symbol-value fld-hook)))
(mapc (lambda (hook) (apply hook args))
(cdr (assoc hook-name fld-hook)))
))))
(defadvice yank (around msf-fld-around-yank activate)
(let ((form (msf-fld-form)))
(if (or form
(some (lambda (overlay)
(and (setq form
(msf-form-get
overlay 'fld-resurrection))
(assoc (point-marker) form)
(setq form overlay)))
(overlays-at (point))))
(let ((inhibit-modification-hooks t)
(yank-excluded-properties t)
(begin (point)))
(msf-form-on-modification form nil begin begin)
ad-do-it
(msf-form-on-modification form 'after begin (point)))
ad-do-it)))
(defun msf-fld-after-insertion (form fld-pos begin end)
(set-text-properties begin end
(msf-fld-properties fld-pos))
(unless (msf-fld-get 'fld-state fld-pos)
(msf-fld-add '(fld-state typed) fld-pos)
(when msf-abbrev-first-insertion-replaces
(save-excursion
(and (> begin (msf-fld-start fld-pos))
(delete-region (msf-fld-start fld-pos) begin))
(and (> (msf-fld-end fld-pos) end)
(delete-region end (msf-fld-end fld-pos)))))
(move-marker fld-pos begin)))
(defun msf-fld-after-deletion (form fld-pos begin count)
(when (and (not (msf-fld-get 'fld-state))
msf-abbrev-first-deletion-removes)
(let ((inhibit-modification-hooks nil))
(throw :fld-end-modification
(delete-region (msf-fld-start fld-pos)
(msf-fld-end fld-pos)))))
(msf-fld-add '(fld-state untyped) fld-pos))
(defun msf-fld-before-resurrection (form begin end)
(msf-form-put form 'fld-resurrection
(cons (cons begin
(msf-fld-properties begin))
(msf-form-get form 'fld-resurrection))))
(defun msf-fld-after-resurrection (form begin end)
(let* ((res-info (msf-form-get form 'fld-resurrection))
(old-properties (assoc begin res-info)))
(set-text-properties begin end (cdr old-properties))
(add-text-properties begin end '(fld-state resurrected))
(msf-form-put form 'fld-resurrection
(delq old-properties res-info))))
(defun msf-fld-insert (text form &optional properties)
(let ((begin (point-marker)))
(insert text)
(and properties
(add-text-properties begin (point) properties))
(add-text-properties begin (point)
`(fld-form ,form))
(when (> (point) (msf-form-end form))
(move-overlay form (msf-form-start form) (point)))))
(defun msf-fld-form (&optional pos)
(msf-fld-get 'fld-form (or pos (point))))
(defun msf-fld-start (&optional pos)
(or pos (setq pos (point)))
(let ((form (msf-fld-form pos)))
(assert form)
(if (eq (msf-fld-form (1- pos)) form)
(previous-single-property-change
pos 'fld-form nil (msf-form-start form))
pos)))
(defun msf-fld-end (&optional pos)
(or pos (setq pos (point)))
(let ((form (msf-fld-form pos)))
(assert form)
(next-single-property-change
pos 'fld-form nil (msf-form-end form))))
(defun msf-fld-set-text (text &optional pos)
(save-excursion
(let ((form (msf-fld-form pos))
(old-properties (msf-fld-properties pos))
(text (with-temp-buffer
(goto-char (point-min)) (insert text)
(buffer-substring-no-properties (point-min)
(point-max))))
(inhibit-modification-hooks t))
(goto-char (msf-fld-start pos))
(delete-region (msf-fld-start pos) (msf-fld-end pos))
(msf-fld-insert text form old-properties))))
(defsubst msf-fld-text (&optional pos)
(buffer-substring (msf-fld-start pos) (msf-fld-end pos)))
(defsubst msf-fld-text-no-properties (&optional pos)
(buffer-substring-no-properties (msf-fld-start pos)
(msf-fld-end pos)))
(defsubst msf-fld-put (property value &optional pos)
(put-text-property (msf-fld-start pos)
(msf-fld-end pos)
property value))
(defsubst msf-fld-get (property &optional pos)
(get-text-property (or pos (point)) property))
(defsubst msf-fld-set (properties &optional pos)
(set-text-properties (msf-fld-start pos)
(msf-fld-end pos)
properties))
(defsubst msf-fld-add (properties &optional pos)
(add-text-properties (msf-fld-start pos)
(msf-fld-end pos)
properties))
(defsubst msf-fld-remove (properties &optional pos)
(remove-text-properties (msf-fld-start pos)
(msf-fld-end pos)
properties))
(defsubst msf-fld-properties (&optional pos)
(text-properties-at (or pos (point))))
(defun msf-fld-forget (field)
(let ((form (msf-fld-form field))
(link (msf-fld-get 'fld-link field))
(category (msf-fld-get 'category field))
(inhibit-modification-hooks t))
(assert (and form link))
(when (and link (not (eq category 'msf-fld-linked-category)))
(msf-fld-make-real (msf-form-first-link
form nil nil
(list 'fld-link link))))
(msf-fld-set default-text-properties field)
(unless (msf-form-first-fld form)
(msf-form-delete form))))
(defun msf-fld-make-real (field)
(let ((form (msf-fld-form field))
(link (msf-fld-get 'fld-link field))
(inhibit-modification-hooks t)
(real nil))
(assert (and form link))
(setq real (msf-form-first-real
form nil nil (list 'fld-link link)))
(assert real)
(msf-fld-set-text (msf-fld-text-no-properties real) field)
(msf-fld-set (msf-fld-properties real) field)))
(defun msf-fld-unlink (field)
(let ((inhibit-modification-hooks t))
(msf-fld-make-real field)
(msf-fld-remove '(fld-link t fld-modification-hooks t) field)))
(defun msf-fld-linked-replicate (form fld-pos &rest ignored)
"Update the text for other linked fields with the same link name.
Called after text insertion/deletion on a linked field"
(let ((new-txt (buffer-substring-no-properties
(msf-fld-start fld-pos)
(msf-fld-end fld-pos)))
(link (msf-fld-get 'fld-link fld-pos))
(field (msf-form-start form))
(properties nil))
(save-excursion
(while (setq field (msf-form-first-fld
form field nil (list 'fld-link link)))
(goto-char (setq field (msf-fld-start field)))
(if (= (msf-fld-start fld-pos) field)
(setq field (msf-fld-end fld-pos))
(setq properties (msf-fld-properties field))
(delete-region (msf-fld-start field)
(msf-fld-end field))
(msf-fld-insert new-txt form
(append properties
'(fld-state replicated)))
(setq field (point)))))))
(defun msf-fld-linked-before-resurrection (form begin end)
"Save information for other linked fields and delete them.
This must be called AFTER a linked field has been fully deleted"
(let ((res-info (msf-form-get form 'fld-resurrection))
(link (msf-fld-get 'fld-link begin))
(field (msf-form-start form))
(properties nil))
(save-excursion
(while (setq field (msf-form-first-fld
form field nil (list 'fld-link link)))
(goto-char (setq field (msf-fld-start field)))
(setq properties (msf-fld-properties field))
(delete-region (msf-fld-start field)
(msf-fld-end field))
(add-to-list 'res-info (cons (point-marker) properties))
(setq field (point))))
(msf-form-put form 'fld-resurrection res-info)))
(defun msf-fld-linked-after-resurrection (form begin end)
"Resurrect other linked fields on a linked field resurrection"
(let ((new-txt (buffer-substring-no-properties begin end))
(res-info (msf-form-get form 'fld-resurrection))
(link (msf-fld-get 'fld-link begin))
(predicate nil))
(setq predicate
(lambda (field)
(when (equal link (cadr (member 'fld-link
(cdr field))))
(unless (= begin (car field))
(save-excursion
(goto-char (car field))
(msf-fld-insert
new-txt form
(append (cdr field)
'(fld-state resurrected)))))
t)))
(msf-form-put form 'fld-resurrection
(delete-if predicate res-info))))
(defun msf-choose-completing (prompt table &optional
predicate require-match
initial-input hist def
inherit-input-method)
"Use a `completing-read' like function to make a selection"
(let ((fun (cond
((featurep 'ido) 'ido-completing-read)
(t 'completing-read))))
(apply fun prompt table predicate require-match
initial-input hist def inherit-input-method)))
(defun msf-choose-selecting (prompt choices-list &optional
predicate initial-input
hist existing-choice
inherit-im)
"Choose an item from a list using a simple selection buffer.
This creates a new selection buffer with very limited
key-bindings:
C-n : Next option
<down> : Next option
C-p : Previous option
<up> : Previous option
RET : Select current option
TAB : Select current option
"
(let* (i map done o choice-index choice-info out)
(setq map (make-sparse-keymap))
(setq i 0)
(setq choice-index 0)
(kill-buffer (get-buffer-create " fld-choose"))
(with-current-buffer (get-buffer-create " fld-choose")
(erase-buffer)
(insert "Make your choice, C-g aborts:\n\n")
(mapc
(lambda (c)
(insert c)
(setq choice-info (cons (cons i (list (line-number-at-pos)
(length c)))
choice-info))
(when (equal existing-choice c)
(setq choice-index i))
(setq i (1+ i))
(insert "\n"))
choices-list)
(setq choice-info (reverse choice-info))
(goto-char (point-min))
(forward-line 2)
(forward-line choice-index)
(setq o (make-overlay (line-beginning-position)
(+ (line-beginning-position)
(cadr (cdr (assoc choice-index choice-info))))))
(overlay-put o 'face 'bold-italic))
(save-window-excursion
(delete-other-windows)
(let ((buf (get-buffer " fld-choose")))
(fit-window-to-buffer (display-buffer buf))
(while (not done)
(let (
(keys nil))
(setq keys (read-key-sequence-vector prompt))
(cond
((or (equal keys [16])
(equal keys [up]))
(when (> choice-index 0)
(set-buffer buf)
(setq choice-index (1- choice-index))
(goto-line (car (cdr (assoc choice-index choice-info))))
(move-overlay o
(line-beginning-position)
(+ (line-beginning-position)
(cadr (cdr (assoc choice-index
choice-info)))))))
((or (equal keys [14])
(equal keys [down]))
(when (< choice-index (1- i))
(set-buffer buf)
(setq choice-index (1+ choice-index))
(goto-line (car (cdr (assoc choice-index choice-info))))
(move-overlay o
(line-beginning-position)
(+ (line-beginning-position)
(cadr (cdr (assoc choice-index
choice-info)))))))
((or (equal keys [9])
(equal keys [13]))
(setq out (nth choice-index choices-list)
done t))
((equal keys [7])
(setq done t))
(t nil))))))
(message "")
out))
(defun msf-cmd-goto-root nil
(interactive)
(let ((current-mode-str (format "%s" major-mode)))
(if (assq major-mode msf-abbrev-mode-abbrevs)
(dired (concat (file-name-as-directory msf-abbrev-root)
current-mode-str))
(dired msf-abbrev-root))))
(defun msf-cmd-define ()
(interactive)
(let* ((current-mode-str
(cond
((and
(eq major-mode 'latex-mode)
(boundp 'AUCTeX-version))
"LaTeX-mode")
((and
(eq major-mode 'tex-mode)
(boundp 'AUCTeX-version))
"TeX-mode")
(t (format "%s" major-mode))))
(d (concat (file-name-as-directory msf-abbrev-root)
current-mode-str)))
(when (or (file-exists-p d)
(and (y-or-n-p
(format
"Could not find directory %s, create it? " d))
(progn
(make-directory d)
t)))
(let ((name (msf-abbrev-choose-abbrev major-mode nil))
(reloader
(eval `(lambda nil
(with-current-buffer ,(current-buffer)
(msf-abbrev-scan-mode major-mode 'replace)
(msf-abbrev-define-on-table
major-mode local-abbrev-table)
(message "Abbrevs for %s reloaded."
major-mode)))))
(find-file-hook
(eval `(lambda nil
(make-variable-buffer-local
'after-save-hook)
(setq after-save-hook reloader)
(goto-char (point-max))
(insert ,(if mark-active
(buffer-substring-no-properties
(region-beginning)
(region-end))
""))))))
(find-file (concat (file-name-as-directory d) name))))))
(defun msf-cmd-expand ()
(interactive)
(let ((abbrev (msf-abbrev-choose-abbrev major-mode t)))
(if abbrev
(msf-abbrev-expand-abbrev abbrev major-mode)
(message "Expansion canceled"))))
(defun msf-cmd-goto-start nil
(interactive)
(goto-char (msf-form-start-point (msf-form-at (point)))))
(defun msf-cmd-goto-end nil
(interactive)
(goto-char (msf-form-end-point (msf-form-at (point)))))
(defun msf-cmd-unlink nil
(interactive)
(let (form field)
(setq form (or (msf-fld-form (setq field (point)))
(msf-fld-form (setq field (1- (point))))))
(assert (and form field))
(save-excursion
(msf-fld-unlink field))))
(defun msf-cmd-clean-field nil
(interactive)
(let (form field)
(setq form (or (msf-fld-form (setq field (point)))
(msf-fld-form (setq field (1- (point))))))
(assert (and form field))
(save-excursion
(msf-fld-forget field))))
(defun msf-cmd-end-form nil
(interactive)
(let ((form (msf-form-at (point))))
(goto-char (msf-form-end-point form))
(msf-form-delete form)))
(defun msf-cmd-clean-form nil
(interactive)
(let ((form (msf-form-at (point))))
(msf-form-delete form)))
(defun msf-cmd-goto-next (scanner)
(let ((form (msf-form-at (point)))
(start (if (msf-fld-form (point))
(msf-fld-end (point))
(point)))
(next nil))
(assert form)
(if (setq next (apply scanner (list form start)))
(goto-char (msf-fld-start next))
(if msf-abbrev-goto-next-loops
(goto-char (apply scanner (list form)))
(call-interactively 'msf-cmd-end-form)))))
(defun msf-cmd-goto-previous (scanner)
(let (form end prev)
(setq form (or (msf-fld-form (setq end (point)))
(msf-fld-form (setq end (1- (point))))))
(assert form)
(setq end (msf-fld-start end))
(if (setq prev (apply scanner (list form nil end)))
(goto-char (msf-fld-start prev))
(setq prev (apply scanner (list form)))
(if prev
(goto-char (msf-fld-start prev))
(display-warning 'msf-abbrev
"No previous field in form"
:warning)))))
(defun msf-cmd-next-fld nil
(interactive)
(msf-cmd-goto-next 'msf-form-first-fld))
(defun msf-cmd-previous-fld nil
(interactive)
(msf-cmd-goto-previous 'msf-form-last-fld))
(defun msf-cmd-next-real nil
"Go to the next real field in the form at point.
If no field exists after point, go to the end point and
delete the form."
(interactive)
(msf-cmd-goto-next 'msf-form-first-real))
(defun msf-cmd-previous-real nil
"Go to the previous real field in FORM"
(interactive)
(msf-cmd-goto-previous 'msf-form-last-real))
(defun msf-cmd-make-choice nil
(interactive)
(let (form field choices selection)
(setq form (or (msf-fld-form (setq field (point)))
(msf-fld-form (setq field (1- (point))))))
(assert (and form field))
(setq field (set-marker (make-marker) field))
(setq selection (msf-fld-text-no-properties field))
(setq choices (msf-fld-get 'fld-choices field))
(setq selection
(apply msf-abbrev-choose-method
(concat "Choose a field value and press RET."
" Navigate using C-n and C-p")
(copy-list choices) nil t
nil nil selection nil))
(when (member selection choices)
(msf-fld-set-text selection field)
(msf-form-on-modification
form 'after (msf-fld-start field)(msf-fld-end field) 0)
(goto-char (msf-fld-end field)))))
(defun msf-cmd-make-editable nil
"Like setting `msf-abbrev-first-insertion-replaces' to nil just
for the field at point."
(interactive)
(let (form field (inhibit-modification-hooks t))
(setq form (or (msf-fld-form (setq field (point)))
(msf-fld-form (setq field (1- (point))))))
(assert (and form field))
(msf-fld-add '(fld-state editable) field)))
(provide 'msf-abbrev)