Download
(eval-when-compile
(require 'cl))
(require 'tempo)
(defgroup tempo-x nil
"Various tempo elements handler."
:group 'abbrev
:group 'convenience
:group 'pde)
(defun tempo-x-space ()
"Expand tempo if complete in `tempo-local-tags' or insert space."
(interactive "*")
(or (tempo-expand-if-complete)
(call-interactively 'self-insert-command)))
(defun tempo-x-rebuild ()
"Force to rebuild collections in all buffer"
(interactive)
(mapc (lambda (buf)
(with-current-buffer buf
(if (local-variable-p 'tempo-dirty-collection)
(tempo-invalidate-collection))))
(buffer-list)))
(defun tempo-x-elements-handler (element)
"Handle new tempo elements."
(if (consp element)
(cond ((eq (car element) 'pi)
(apply 'tempo-x-insert-prompt (cdr element)))
((eq (car element) 'Pi)
(let ((tempo-interactive t))
(apply 'tempo-x-insert-prompt (cdr element))))
((eq (car element) 'R)
(funcall 'tempo-x-insert-recursion (cdr element)))
((eq (car element) 'snippet)
(funcall 'tempo-x-insert-snippet (cdr element))))))
(defun tempo-x-insert-prompt (prompt &optional default save-name no-insert)
"Prompt for a text string with DEFAULT.
Like `tempo-insert-prompt', but you can give parameters for
`completing-reading' in CDR of PROMPT."
(let ((saved (and save-name (tempo-lookup-named save-name)))
insertion)
(cond ((and saved (not no-insert))
(tempo-insert-named save-name)
"")
(saved "")
(tempo-interactive
(if (symbolp default) (setq default (symbol-value default)))
(cond ((stringp prompt)
(setq insertion (read-from-minibuffer prompt default)))
((and (listp prompt) (stringp (car prompt)))
(let ((old-args (cdr prompt)) collection args)
(setq prompt (replace-regexp-in-string ":\\s-$" "" (car prompt)))
(setq prompt
(if default
(format "%s (default %s): " prompt default)
(concat prompt ": ")))
(dotimes (i 7)
(cond ((eq i 5)
(push default args))
((and (eq i 0)
(symbolp (setq collection (nth i old-args)))
(boundp collection))
(push (symbol-value collection) args))
(t (push (nth i old-args) args))))
(setq insertion (apply 'completing-read prompt (nreverse args)))))
(t (error "The prompt (%s) is not a string or a list" prompt)))
(if save-name (tempo-save-named save-name insertion))
(if no-insert "" insertion))
(t (tempo-insert-mark (point-marker)) (or default "")))))
(defun tempo-x-insert-recursion (element)
"Hander recursive for template.
Elements like:
(R other-elements (& condition final-form) ...)
the condition can be a saved name or a list. If it is a name and
when it is empty, quit the loop. If it is a list, the CAR of
CONDITION can a list of names and the rest part is a form to
eval. You can use the names in the form, the names will automatic
clear from `tempo-named-insertions' after evaled so that you will
be prompt again. If the eval result is true, the FINAL-FORM will
be evaled and abort the loop.
This is an example to insert sh-if much like the skeleton does.
(tempo-define-template
\"sh-if\"
'(\"if \" (pi \"condition: \" (\"[ ]\" . 3)) \"; then\" > n>
p > n>
(R \"elif \" (pi \"condition: \" (\"[ ]\" . 3) condition)
(& ((condition) (string-match \"\\\\[\\\\s-*\\]\" condition))
(delete-region recursion-start (point)))
\"; then\" > n>
p > n>)
\"else\" > n>
p n>
\"fi\" > n>))
FIXME: the regexp above is display incorrect.
"
(let (recursion-start condition)
(catch 'exit
(while t
(setq recursion-start (point))
(mapc (lambda (elt)
(if (and (consp elt)
(eq (car elt) '&))
(progn
(let ((condition (cadr elt))
vars exit)
(if (symbolp condition)
(setq exit (= (length (tempo-lookup-named condition)) 0)
vars (list condition))
(setq vars (car condition))
(setq exit (eval `(let ,(mapcar (lambda (var)
`(,var (tempo-lookup-named ',var)))
vars)
,@(cdr condition)))))
(mapc (lambda (var)
(tempo-save-named var nil))
vars)
(when exit
(eval (nth 2 elt))
(throw 'exit t))))
(tempo-insert elt tempo-insert-region)))
element)))
""))
(defcustom tempo-x-exclude-chars ""
"*Chars not to extend when add to front or end of the field."
:type 'string
:group 'tempo-x)
(defface tempo-x-editable-face
'((((background dark)) (:background "steel blue"))
(((background light)) (:background "light cyan")))
"*Face used for editable text in tempo snippets."
:group 'tempo-x)
(defface tempo-x-auto-face
'((((background dark)) (:background "dodger blue"))
(((background light)) (:background "light gray")))
"*Face used for automatically updating text in tempo snippets."
:group 'tempo-x)
(defface tempo-x-form-face
'((((background dark)) (:background "dodger blue"))
(((background light)) (:background "light gray")))
"*Face used for automatically updating text in tempo snippets."
:group 'tempo-x)
(defvar tempo-x-snippet-map
(let ((map (make-sparse-keymap)))
(define-key map "\t" 'tempo-x-next-field)
(define-key map (kbd "<backtab>") 'tempo-x-previous-field)
map)
"*keymap for tempo marker")
(defvar tempo-x-delete-field-text nil)
(defvar tempo-x-snippet-overlay nil
"Overlay to install keymap")
(make-variable-buffer-local 'tempo-x-snippet-overlay)
(defvar tempo-x-snippet-sources nil
"List of source overlays for current snippet.")
(make-variable-buffer-local 'tempo-x-snippet-sources)
(defvar tempo-x-snippet-forms nil
"List of forms overlays for current snippet.")
(make-variable-buffer-local 'tempo-x-snippet-forms)
(defun tempo-x-insert-snippet (elements)
"Provide snippet abbev.
Syntax of snippet:
(snippet (S name &optional display insert)
(F (vars) forms))
S insert a field, the first NAME will be the source and other field
with the same NAME become mirrors. Change the source will also change
mirrors. DISPLAY is the text to insert to the field, default is the
`symbol-name' of NAME. INSERT is non-nil means the DISPLAY is the
default text, you can make change to the text. Otherwise the text will
be erase after any changes in front of field.
F insert an form. The VARS is a list of NAME used in fields. the
evaled result will insert into the buffer. When any fields in VARS
changed, the text of form will change too."
(tempo-x-snippet-clear)
(let ((inhibit-modification-hooks t)
(beg (point))
ov)
(mapc (lambda (elem)
(if (and (listp elem) (memq (car elem) '(S F)))
(cond ((eq (car elem) 'S)
(apply 'tempo-x-insert-field (cdr elem)))
((eq (car elem) 'F)
(apply 'tempo-x-insert-form (cdr elem))))
(tempo-insert elem nil)))
elements)
(mapc (lambda (ov)
(let ((text (eval (overlay-get ov 'tempo-x-form))))
(when text
(tempo-x-set-overlay-text ov text))))
tempo-x-snippet-forms)
(setq ov (make-overlay beg (point)))
(overlay-put ov 'keymap tempo-x-snippet-map)
(setq tempo-x-snippet-overlay ov)
""))
(defun tempo-x-insert-field (name &optional display insert)
"Insert a field to buffer."
(if (tempo-x-find-source name)
(tempo-x-insert-mirror name)
(tempo-x-insert-source name display insert)))
(defun tempo-x-insert-source (name display insert)
"Insert source field to buffer"
(tempo-insert-mark (point-marker))
(let ((beg (point))
(text (or display (symbol-name name)))
ov)
(insert text)
(setq ov (make-overlay beg (point)))
(mapc (lambda (pair)
(overlay-put ov (car pair) (cdr pair)))
`((tempo-x-name . ,name)
(tempo-x-display . ,text)
(tempo-x-insert . ,insert)
(face . tempo-x-editable-face)
(intangible . ,(not insert))
,@(if insert
'((modification-hooks tempo-x-snippet-update)
(insert-behind-hooks tempo-x-snippet-update)
(insert-in-front-hooks tempo-x-snippet-update))
'((insert-in-front-hooks tempo-x-snippet-replace)
(modification-hooks tempo-x-snippet-update)))))
(push (cons name ov) tempo-x-snippet-sources)))
(defun tempo-x-insert-mirror (name)
"Insert mirror field to buffer"
(let ((beg (point))
(source (tempo-x-find-source name))
ov)
(when source
(insert (tempo-x-overlay-text source))
(setq ov (make-overlay beg (point)))
(let ((mirrors (overlay-get source 'tempo-x-mirrors)))
(push ov mirrors)
(overlay-put source 'tempo-x-mirrors mirrors))
(mapc (lambda (pair)
(overlay-put ov (car pair) (cdr pair)))
`((face . tempo-x-auto-face)
(modification-hooks tempo-x-delete-field)
(insert-in-front-hooks tempo-x-dont-grow-overlay))))))
(defun tempo-x-insert-form (vars &rest form)
"Insert form to buffer"
(setq form
`(let
,(mapcar (lambda (var)
`(,var (tempo-x-overlay-text (tempo-x-find-source ',var))))
vars)
,@form))
(let (ov)
(setq ov (make-overlay (point) (point)))
(mapc (lambda (pair)
(overlay-put ov (car pair) (cdr pair)))
`((tempo-x-form . ,form)
(face . tempo-x-form-face)
(modification-hooks tempo-x-delete-field)
(insert-in-front-hooks tempo-x-dont-grow-overlay)))
(mapc (lambda (name)
(let ((source (tempo-x-find-source name))
forms)
(if source
(progn
(setq forms (overlay-get source 'tempo-x-forms))
(push ov forms)
(overlay-put source 'tempo-x-forms forms))
(error "Unknown form variable '%s': maybe you didn't source it yet!" name))))
vars)
(push ov tempo-x-snippet-forms)))
(defun tempo-x-delete-overlay (ov)
"Delete mirror field, add marker for navigator after deletion."
(when (overlayp ov)
(tempo-insert-mark (copy-marker (overlay-start ov)))
(delete-overlay ov)))
(defun tempo-x-snippet-clear ()
"Clear current snippet."
(mapc (lambda (source)
(setq source (cdr source))
(mapc 'tempo-x-delete-overlay
(overlay-get source 'tempo-x-mirrors))
(and (overlayp source) (delete-overlay source)))
tempo-x-snippet-sources)
(mapc 'tempo-x-delete-overlay tempo-x-snippet-forms)
(tempo-x-delete-overlay tempo-x-snippet-overlay)
(setq tempo-x-snippet-sources nil
tempo-x-snippet-overlay nil
tempo-x-snippet-forms nil))
(defun tempo-x-find-source (name)
"Return the source overlay with the NAME"
(cdr (assq name tempo-x-snippet-sources)))
(defun tempo-x-overlay-text (ov)
"Text of the overlay"
(buffer-substring-no-properties (overlay-start ov) (overlay-end ov)))
(defun tempo-x-set-overlay-text (overlay text)
"Change the text of the overlay"
(save-excursion
(let ((beg (overlay-start overlay)))
(goto-char beg)
(delete-region beg (overlay-end overlay))
(insert text)
(move-overlay overlay beg (point)))))
(defun tempo-x-clear-source (overlay)
"Clear OVERLAY and its mirrors."
(mapc 'tempo-x-delete-overlay
(overlay-get overlay 'tempo-x-mirrors))
(mapc (lambda (ov)
(setq tempo-x-snippet-forms (delq ov tempo-x-snippet-forms))
(tempo-x-delete-overlay ov))
(overlay-get overlay 'tempo-x-forms))
(setq tempo-x-snippet-sources
(delq (assq (overlay-get overlay 'tempo-x-name) tempo-x-snippet-sources)
tempo-x-snippet-sources))
(delete-overlay overlay))
(defun tempo-x-propagate-source (ov)
"Change the mirrors and related forms."
(let ((text (tempo-x-overlay-text ov))
(mirrors (overlay-get ov 'tempo-x-mirrors))
(forms (overlay-get ov 'tempo-x-forms)))
(dolist (o mirrors)
(unless (eq o ov)
(tempo-x-set-overlay-text o text)))
(dolist (o forms)
(let ((text (eval (overlay-get o 'tempo-x-form))))
(when text
(tempo-x-set-overlay-text o text))))))
(defun tempo-x-dont-grow-overlay (ov after-p beg end &optional r)
"Hooks to make start of overlay unchange."
(let ((inhibit-modification-hooks t))
(when after-p
(move-overlay ov end (overlay-end ov)))))
(defun tempo-x-delete-field (ov after-p beg end &optional r)
"A wrapper to call `delete-overlay' from modification hooks."
(if after-p
(unless (string= tempo-x-delete-field-text
(buffer-substring-no-properties beg end))
(tempo-x-delete-overlay ov))
(setq tempo-x-delete-field-text
(buffer-substring-no-properties beg end))))
(defun tempo-x-snippet-replace (ov after-p beg end &optional r)
"Hooks to convert intangible overlay to ordinary"
(when after-p
(let ((inhibit-modification-hooks t))
(mapc (lambda (pair)
(overlay-put ov (car pair) (cdr pair)))
`((intangible . nil)
(modification-hooks tempo-x-snippet-update)
(insert-behind-hooks tempo-x-snippet-update)
(insert-in-front-hooks tempo-x-snippet-update)))
(delete-region end (overlay-end ov))
(tempo-x-snippet-update ov t beg end nil))))
(defun tempo-x-snippet-update (ov after-p beg end &optional r)
"Update source overlay.
If insert chars in front or behind overlay that is in
`tempo-x-exclude-chars', don't grow the overlay.
Make mirrors and sources changes.
If the text become empty, if delete by deleting commands except DEL,
delete source field. Otherwise recover to beginning."
(let ((inhibit-modification-hooks t))
(when after-p
(when (/= beg end)
(cond ((= beg (overlay-start ov))
(save-excursion
(goto-char beg)
(skip-chars-forward tempo-x-exclude-chars)
(move-overlay ov (point) (overlay-end ov))))
((> end (overlay-end ov))
(save-excursion
(goto-char (overlay-end ov))
(skip-chars-forward (concat "^" tempo-x-exclude-chars))
(move-overlay ov (overlay-start ov) (min end (point)))))))
(tempo-x-propagate-source ov)
(when (= (overlay-end ov) (overlay-start ov))
(if (> r 1)
(progn
(tempo-x-clear-source ov))
(tempo-x-set-overlay-text ov (overlay-get ov 'tempo-x-display))
(tempo-x-propagate-source ov)
(unless (overlay-get ov 'tempo-x-insert)
(mapc (lambda (pair)
(overlay-put ov (car pair) (cdr pair)))
'((intangible . t)
(insert-behind-hooks)
(insert-in-front-hooks tempo-x-snippet-replace)
(modification-hooks tempo-x-snippet-update)))))))))
(defun tempo-x-next-field ()
"Move to next field, if already the next field clear all fields."
(interactive)
(let ((pos (point))
(sources tempo-x-snippet-sources)
(last (point-max))
ov found)
(while (and sources (not found))
(if (and (> (overlay-start (cdar sources)) pos)
(or (null (setq ov (cdr (cadr sources))))
(<= (overlay-start ov) pos)))
(setq found t)
(setq ov (car sources)
sources (cdr sources))))
(if found
(goto-char (overlay-start (cdar sources)))
(tempo-forward-mark)
(tempo-x-snippet-clear))))
(defun tempo-x-previous-field ()
"Move to previous field"
(interactive)
(let ((pos (point))
(sources tempo-x-snippet-sources)
ov found)
(while (and sources (not found))
(setq ov (cdar sources))
(if (<= (overlay-end ov) pos)
(setq found t)
(setq sources (cdr sources))))
(goto-char (overlay-start ov))))
(defmacro tempo-x-test-template (&rest tempo)
"Test the template without define it."
`(let ((tpl ,@tempo))
(tempo-insert-template 'tpl nil)))
(add-to-list 'tempo-user-elements 'tempo-x-elements-handler)
(provide 'tempo-x)