rallentando/lisp-electric.el

## lisp-electric.el
;;; lisp-electric.el --- electric commands editing for S-expression

;; メインとなるS式編集用コマンドは以下の3つです。
;;
;; lel-matching-char:
;;
;;    "(" か "[" を入力するとそれ自体を挿入し、イベントループに入ります。
;;
;;    イベントループ内ではタブかS-タブを入力すると、S式単位で範囲選択が
;;    できます。
;;
;;    それ以外を入力することで最初に入力した開き括弧に対応する閉じ括弧
;;    を挿入し、入力のあったイベントを実行し、ループを脱出します。その
;;    ときタブかS-タブによって範囲選択されていると、その範囲の末尾に閉
;;    じ括弧を挿入します。また閉じ括弧の入力でループを脱出すると、カー
;;    ソルが閉じ括弧を置いた場所に移動します。
;;
;;    恐らく普通にコードを書いていると勝手に閉じ括弧が挿入されるだけに
;;    なるかと思われます。
;;
;;  例)
;;
;;      alpha beta gamma
;;      ^
;;      この状態から"(","tab","tab","tab",")" と入力すると
;;
;;      (alpha beta gamma)
;;                        ^
;;      この様になります。
;;
;;      ※^はキャレットの位置です。
;;
;;
;;    また "\"" を入力するとそれ自体を挿入し、イベントループに入ります。
;;    "(" や "[" を入力した時と動きは似ていますが、こちらはS式単位では
;;    なく単語単位で範囲選択を変えます。それ以外は上の小機能版と考えて
;;    ください。範囲選択した場合、移動コマンドで抜けるといいかと思われ
;;    ます。
;;
;;  例)
;;
;;      (alpha beta gamma)
;;             ^
;;      この状態から"\"","tab",")" と入力すると
;;
;;      (alpha "beta" gamma)
;;                   ^
;;      この様になります。
;;
;; lel-space:
;;
;;    " " を入力するとそれ自体を挿入し、イベントループに入ります。タブ
;;    かS-タブを入力することによってS式単位で範囲選択できるのは
;;    lel-matching-charと同様です。
;;
;;    再度 " " を入力すると、最初のスペースを入力する前の状態で
;;    yasnippetが展開できるなら展開し、範囲選択されていたらその範囲を
;;    lel-lisp-snippetsなどで指定されたフィールドの位置に挿入します。展
;;    開できなければ " " を挿入してループを脱出します。
;;
;;    ")" か "]" を入力すると、前の式もしくは要素の前と現在のポイントの
;;    位置もしくは範囲選択されている場合その範囲の末尾に入力された括弧
;;    のペアを挿入します。
;;
;;  例)
;;
;;      listalpha beta gamma
;;          ^
;;      この状態から " ","tab","tab","tab",")" と入力すると
;;
;;      (list alpha beta gamma)
;;            ^
;;      この様になります。
;;
;;      また、
;;
;;      lambda
;;            ^
;;      (+ a 5)
;;
;;      この状態から " ","tab"," " と入力すると
;;
;;      (lambda ()
;;           ^
;;        (+ a 5)
;;        )
;;
;;      この様になります。
;;
;; lel-del-form:
;;
;;    カーソル位置付近の一番レベルの低いリストの要素を削除します。その
;;    要素がリストの先頭ならそのリストをくくっている括弧のペアも削除し
;;    ます。
;;
;;
;;  lel-matching-char,lel-spaceの2つのコマンドは、コマンド終了時に範囲
;;  選択されていた場所をインデントします。
;;
;;  delformはリストの先頭要素を削除した場合、そのリストであった部分全体
;;  をインデントします。
;;

(require 'yasnippet nil t)        ;先にyasnippetを導入しといてください
(require 'slime nil t)            ;snippetの登録に必要です(common-lisp)
(require 'scheme-complete nil t)  ;snippetの登録に必要です(scheme)
(require 'gosh-mode nil t)        ;snippetの登録に必要です(gauche専用)

(eval-when-compile (require 'cl))

(defun lel-expandable-keyword-alist()
  (case major-mode
    ((gauche-mode scheme-mode gosh-mode) lel-scheme-snippets)
    ((lisp-mode common-lisp-mode) lel-lisp-snippets)
    ((emacs-lisp-mode lisp-interaction-mode) lel-emacs-snippets)))

(defvar lel-scheme-snippets
  '(("define" . 2)
    ("if" . 2)
    ("lambda" . 2)
    ("let" . 4)
    ("leta" . 4)
    ("letrec" . 4)
    ("let1" . 3)
    ("map" . 1)
    ("for-each" . 1)
    ("unless" . 2)
    ("when" . 2)))

(defvar lel-lisp-snippets
  '(("defun" . 3)
    ("defvar" . 2)
    ("if" . 2)
    ("lambda" . 2)
    ("let" . 4)
    ("leta" . 4)
    ("unless" . 2)
    ("when" . 2)))

(defvar lel-emacs-snippets
  '(("defun" . 3)
    ("defvar" . 2)
    ("if" . 2)
    ("lambda" . 2)
    ("let" . 4)
    ("leta" . 4)
    ("unless" . 2)
    ("when" . 2)))

(defvar lisp-electric-mode-map nil
  "Keymap for lisp electric mode.")

(if lisp-electric-mode-map
    nil
  (progn
    (setq lisp-electric-mode-map (make-sparse-keymap))
    (define-key lisp-electric-mode-map " " 'lel-space);yas
    (define-key lisp-electric-mode-map "(" 'lel-matching-char)
    (define-key lisp-electric-mode-map "[" 'lel-matching-char)
    (define-key lisp-electric-mode-map "\"" 'lel-matching-char)
;    (define-key lisp-electric-mode-map "*" 'lel-matching-char)
;    (define-key lisp-electric-mode-map "+" 'lel-matching-char)
    (define-key lisp-electric-mode-map [(M d)] 'lel-del-form)
    (define-key lisp-electric-mode-map [(C c)(C k)] 'lel-del-form)))

(define-minor-mode lisp-electric-mode
  "Toggle Lisp Electric mode.
With no argument, this command toggles the mode.  Non-null prefix
argument turns on the mode.  Null prefix argument turns off the
mode."
  ;;indicator for the mode line.
  :lighter " LEl"
  ;;keymap
  :keymap lisp-electric-mode-map)

(defvar lel-insertion-beg nil)
(defvar lel-insertion-end nil)
(defvar lel-overlay nil)

(defun lel-set-overlay()
  (if lel-overlay
      (move-overlay lel-overlay
                    lel-insertion-beg lel-insertion-end
                    (current-buffer))
    (progn
      (setq lel-overlay
            (make-overlay lel-insertion-beg
                          lel-insertion-end))
      (make-face 'lel-insertion-face)
      (set-face-background 'lel-insertion-face "Firebrick4")
      (overlay-put lel-overlay 'priority 200)
      (overlay-put lel-overlay 'face 'lel-insertion-face))))

(defun lel-msg-end()
  (message
   (concat
    "End: ... "
    (replace-regexp-in-string
     "\n" "\\\\n"
     (buffer-substring-no-properties
      lel-insertion-end
      (- lel-insertion-end 20))))))

(defun lel-insertion-fore(num)
  (ignore-errors
    (let ((end (if (lel-code-at-point-p)
                   (or (scan-sexps lel-insertion-end num) (buffer-end 1))
                 (save-excursion
                   (goto-char lel-insertion-end)
                   (forward-word num) (point)))))
      (setq lel-insertion-end end)
      (lel-set-overlay)
      (lel-msg-end))))

(defun lel-insertion-back(num)
  (ignore-errors
    (let ((end (if (lel-code-at-point-p)
                   (scan-sexps lel-insertion-end (- num))
                 (save-excursion
                   (goto-char lel-insertion-end)
                   (backward-word num) (point)))))
      (setq lel-insertion-end end)
      (lel-set-overlay)
      (lel-msg-end))))

(defun lel-insertion-clear()
  (setq lel-insertion-end lel-insertion-beg)
  (if lel-overlay (delete-overlay lel-overlay)))

(defun lel-code-at-point-p()
  (and lisp-electric-mode
       (let ((properties0 (text-properties-at (point)))
             (properties1 (text-properties-at (- (point) 1))))
         (or (and (null (memq 'font-lock-string-face properties0))
                  (null (memq 'font-lock-comment-face properties0)))
             (and (null (memq 'font-lock-string-face properties1))
                  (null (memq 'font-lock-comment-face properties1)))))))

(defun lel-string-at-point-p()
  (and lisp-electric-mode
       (consp (memq 'font-lock-string-face (text-properties-at (point))))))

(defun lel-beg-point()
  (or (ignore-errors
        (save-excursion
          (backward-sexp)
          (point)))
      (point)))

(defun lel-insert-paren(event fragment width division)
  (let ((close event)
        (open (or (car (rassoc (list event) insert-pair-alist))
                  event))
        (beg (lel-beg-point)))
    (goto-char lel-insertion-end)
    (while (looking-back "[ \n\t]") (backward-char))
    (when (looking-at " \\(\\'\\|\n\\|)\\)") (forward-char))
    (save-excursion (insert close))
    (incf lel-insertion-end)
    (dotimes (i (1- division))
      (backward-sexp width)
      (save-excursion (insert open fragment " "))
      (while (looking-back "[ \n\t]") (backward-char))
      (save-excursion (insert close))
      (setq lel-insertion-end (+ lel-insertion-end (length fragment) 3)))
    (goto-char beg)
    (insert open)
    (forward-sexp)
    (forward-char)
    (indent-region beg lel-insertion-end)
    (if lel-overlay (delete-overlay lel-overlay))))

(defun lel-insert-end(width division)
  (let ((open last-command-event)
        (close (or (cadr (assoc last-command-event insert-pair-alist))
                   last-command-event)))
    (goto-char lel-insertion-end)
    (while (looking-back "[ \t\n]") (backward-char))
    (save-excursion (insert close))
    (incf lel-insertion-end)
    (dotimes (i (- division 1))
      (if (lel-string-at-point-p)
          (backward-word width)
        (backward-sexp width))
      (save-excursion (insert open))
      (incf lel-insertion-end)
      (if (lel-string-at-point-p)
          (while (looking-back "\\W") (backward-char))
        (while (looking-back "[ \n\t]") (backward-char)))
      (save-excursion (insert close))
      (incf lel-insertion-end))))

(defun no-err-match-string()
  (ignore-errors
    (match-string 0)))

(defun backward-delimiter-point()
  (save-excursion
    (re-search-backward "\\(\\s\(\\|\\s\)\\|[: \n\t]\\)")
    (point)))

(defun forward-delimiter-point()
  (save-excursion
    (re-search-forward "\\(\\s\(\\|\\s\)\\|[ \n\t]\\)")
    (point)))

(defun lel-del-form()
  (interactive)
  (let* ((back (backward-delimiter-point))
         (from (string-to-char (no-err-match-string)))
         (fore (forward-delimiter-point))
         (to   (string-to-char (no-err-match-string))))
    (case from
      (32 ;spc
       (delete-region back (- fore 1)))
      ((?\] ?\))
       (delete-region (+ back 1) (- fore 1)))
      ((?\( ?\[)
       (let ((end
              (ignore-errors
                (save-excursion
                  (re-search-backward "\\s\(")
                  (forward-sexp)
                  (delete-backward-char 1)
                  (point)))))
         (case to ((?\( ?\) ?\[ ?\]) (decf fore)))
         (delete-region back fore)
         (indent-region back (- end (- fore back))))))))

(defun lel-format-and-regist-snippet(arglist)
  (let* ((str-lis (split-string
                   (replace-regexp-in-string
                    "\\.\\.\\." " ..."
                    (replace-regexp-in-string
                     "\\(\\[\\|\\]\\)" " "
                     arglist))
                   " +"))
         (str (cdr str-lis))
         (result (car str-lis))
         (key (substring (car str-lis) 1))
         (count 1))
    (while (not (equal str nil))
      (let* ((open  (and (string-match "\\((\\|\\]\\)+" (car str)) (match-string 0 (car str))))
             (close (and (string-match "\\()\\|\\[\\)+" (car str)) (match-string 0 (car str))))
             (sbstr-beg (if open (length open) 0))
             (sbstr-end (if close (- (length close)) nil)))
        (setq result (concat result
                             " " open "${"
                             (number-to-string count)
                             ":"
                             (substring (car str) sbstr-beg sbstr-end)
                             "}" close)))
      (incf count)
      (setq str (cdr str)))
    (case major-mode
      ((gauche-mode scheme-mode gosh-mode)
       (setq lel-scheme-snippets (cons (cons key (- count 1)) lel-scheme-snippets)))
      ((lisp-mode common-lisp-mode)
       (setq lel-lisp-snippets (cons (cons key (- count 1)) lel-lisp-snippets)))
      ((emacs-lisp-mode lisp-interaction-mode)
       (setq lel-emacs-snippets (cons (cons key (- count 1)) lel-emacs-snippets))))
    result))

(defun lel-define-lisp-snippet()
  (let ((func (slime-symbol-at-point)))
    (ignore-errors
      (yas/define-snippets
       'lisp-mode
       (list (list func
                   (lel-format-and-regist-snippet
                    (slime-eval `(swank:operator-arglist ,func ,(slime-current-package))))
                   func))))))

(defun lel-define-emacs-snippet()
  (let ((func (symbol-at-point)))
    (ignore-errors
      (yas/define-snippets
       'emacs-lisp-mode
       (list (list (symbol-name func)
                   (lel-format-and-regist-snippet
                    (or (car (help-split-fundoc (documentation func) func))
                        (format "%S"
                                (help-make-usage func (help-function-arglist func)))))
                   (symbol-name func)))))))

(defun lel-define-scheme-snippet()
  (let ((func (scheme-symbol-at-point)))
    (ignore-errors
      (yas/define-snippets
       'scheme-mode
       (list (list (symbol-name func)
                   (lel-format-and-regist-snippet
                    (scheme-sexp-to-string
                     (cons func
                           (or (cadadr (scheme-env-lookup (scheme-current-env) func))
                               (cadr   (scheme-env-lookup (scheme-current-env) func))))))
                   (symbol-name func)))))))

(defun lel-define-gosh-snippet()
  (let ((func (gosh-parse-symbol-at-point)))
    (ignore-errors
      (yas/define-snippets
       'scheme-mode
       (mapcar
        #'(lambda (sexp)
           (let ((str (gosh-eldoc--sexp->string
                       (cons func (or (cadadr sexp) (cadr sexp))))))
             (list (symbol-name func) (lel-format-and-regist-snippet str) str)))
        (gosh-env-matches (gosh-parse-current-env) func nil))))))

(defun lel-define-snippet()
  (case major-mode
    ((emacs-lisp-mode lisp-interaction-mode)
     (lel-define-emacs-snippet))
    ((lisp-mode common-lisp-mode)
     (and (featurep 'slime) (lel-define-lisp-snippet)))
    ((gauche-mode scheme-mode)
     (and (featurep 'scheme-complete) (lel-define-scheme-snippet)))
    (gosh-mode
     (and (featurep 'gosh-mode) (lel-define-gosh-snippet)))))

(defun lel-space(arg)
  (interactive "P")
  (if (lel-code-at-point-p)
      (let* ((division (prefix-numeric-value arg))
             (width 0)
             (fragment
              (buffer-substring (lel-beg-point) (point)))
             (expandable
              (lambda ()
                (member fragment (mapcar 'car (lel-expandable-keyword-alist)))))
             (nth-field
              (lambda ()
                (- (or (cdr (assoc fragment (lel-expandable-keyword-alist))) 1) 1)))
             (begin
              (progn (insert " ")
                     (save-excursion (re-search-forward "[ \n\t]*"))
                     (+ (point) (length (no-err-match-string)))))
             (done nil))
        (setq lel-insertion-beg begin
              lel-insertion-end begin)
        (while (not done)
          (let ((event (read-event)))
            (case event
              (15       (lel-insertion-clear) (incf division) (setq width 0))
              (33554447 (lel-insertion-clear) (decf division) (setq width 0))
              ((9 'tab)          (lel-insertion-fore division) (incf width))
              ((33554441 'S-tab) (lel-insertion-back division) (decf width))
              ((41 93)
               (lel-insert-paren event fragment width division)
               (setq done t))
              (32 ;spc
               (let ((inside
                      (buffer-substring lel-insertion-beg lel-insertion-end))
                     (inside-beg nil)
                     (inside-end nil))
                 (if (and (featurep 'yasnippet)
                          (not (funcall expandable)))
                     (save-excursion
                       (backward-char)
                       (and (looking-back "\\(\\sw\\|\\s_\\)")
                            (lel-define-snippet))))
                 (if (and (featurep 'yasnippet)
                          (funcall expandable))
                     (progn
                       (delete-region lel-insertion-beg lel-insertion-end)
                       (while (looking-back "[ \n\t]") (backward-char))
                       (delete-char 1)
                       (yas/expand)
                       (dotimes (i (funcall nth-field)) (yas/next-field))
                       (setq inside-beg (point))
                       (insert inside)
                       (setq inside-end (point))
                       (indent-region inside-beg inside-end)
                       (dotimes (i (funcall nth-field)) (yas/prev-field)))
                   (push event unread-command-events))
                 (if lel-overlay (delete-overlay lel-overlay))
                 (setq done t)))
              (t
               (progn
                 (push event unread-command-events)
                 (if lel-overlay (delete-overlay lel-overlay))
                 (setq done t)))))))
    (insert " ")))

(defun lel-matching-char(arg)
  (interactive "P")
  (let ((division (prefix-numeric-value arg))
        (width 0)
        (done nil))
    (self-insert-command 1)
    (when (lel-code-at-point-p)
      (setq lel-insertion-beg (point)
            lel-insertion-end (point))
      (while (not done)
        (let ((event (read-event)))
          (case event
            (15       (lel-insertion-clear) (incf division) (setq width 0))
            (33554447 (lel-insertion-clear) (decf division) (setq width 0))
            ((9 'tab)          (lel-insertion-fore division) (incf width))
            ((33554441 'S-tab) (lel-insertion-back division) (decf width))
            ((41 93)
             (lel-insert-end width division)
             (indent-region lel-insertion-beg lel-insertion-end)
             (if lel-overlay (delete-overlay lel-overlay))
             (setq done t))
            (t
             (save-excursion
               (lel-insert-end width division)
               (indent-region lel-insertion-beg lel-insertion-end)
               (push event unread-command-events)
               (if lel-overlay (delete-overlay lel-overlay))
               (setq done t)))))))))

(defun lel-del-tail()
  (save-excursion
    (goto-char yas/snippet-end)
    (while (and lisp-electric-mode (looking-back "[ \n\t)]"))
      (when (looking-back "[ \n\t]") (delete-backward-char 1))
      (when (looking-back ")") (backward-char)))))

(add-hook 'yas/after-exit-snippet-hook 'lel-del-tail)

(provide 'lisp-electric)

;;; lisp-electric.el ends here


;; lisp-electricとyasnippetをインストールした後、
;;
;; (yas/load-directory "~/.emacs.d/snippets") とか
;; (setq yas/root-directory "~/.emacs.d/snippets") とか
;;
;; してyas/root-directoryが空でない状態になったら、以下のコードのクオー
;; トをはずして一回だけ実行(eval-regionとかで)してください。snippetがイ
;; ンストールされます。(前にあったやつは消されるのでバックアップ取るか
;; 手動でsnippet作ってください)

'(and yas/root-directory
     (let* ((scm (concat yas/root-directory "/text-mode/scheme-mode/"))
            (lsp (concat yas/root-directory "/text-mode/lisp-mode/"))
            (emc (concat yas/root-directory "/text-mode/emacs-lisp-mode/"))
            (create (lambda (dir file snippet) (progn (find-file (concat dir file)) (erase-buffer) (insert snippet) (save-buffer) (kill-this-buffer)))))
        (shell-command (concat "mkdir " scm)) (shell-command (concat "mkdir " lsp)) (shell-command (concat "mkdir " emc))
        (funcall create scm "define" "#name : define template\n#contributor : rallentando\n# --\n(define ($1)\n  $2\n)")
        (funcall create scm "for-each" "#name : for-each template\n#contributor : rallentando\n# --\n(for-each\n $1\n)")
        (funcall create scm "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n    $2\n    $3\n)")
        (funcall create scm "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n  $2\n)")
        (funcall create scm "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n  $4\n)")
        (funcall create scm "let1" "#name : let1 template\n#contributor : rallentando\n# --\n(let1 $1 $2\n  $3\n)")
        (funcall create scm "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n  $4\n)")
        (funcall create scm "letrec" "#name : letrec template\n#contributor : rallentando\n# --\n(letrec (($1 $2)$3)\n  $4\n)")
        (funcall create scm "map" "#name : map template\n#contributor : rallentando\n# --\n(map\n $1\n)")
        (funcall create scm "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n  $2\n)")
        (funcall create scm "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n  $2\n)")
        (funcall create lsp "defun" "#name : defun template\n#contributor : rallentando\n# --\n(defun $1($2)\n  $3\n)")
        (funcall create lsp "defvar" "#name : defvar template\n#contributor : rallentando\n# --\n(defvar $1\n  $2\n)")
        (funcall create lsp "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n    $2\n    $3\n)")
        (funcall create lsp "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n  $2\n)")
        (funcall create lsp "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n  $4\n)")
        (funcall create lsp "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n  $4\n)")
        (funcall create lsp "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n  $4\n)")
        (funcall create lsp "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n  $2\n)")
        (funcall create lsp "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n  $2\n)")
        (funcall create emc "defun" "#name : defun template\n#contributor : rallentando\n# --\n(defun $1($2)\n  $3\n)")
        (funcall create emc "defvar" "#name : defvar template\n#contributor : rallentando\n# --\n(defvar $1\n  $2\n)")
        (funcall create emc "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n    $2\n    $3\n)")
        (funcall create emc "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n  $2\n)")
        (funcall create emc "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n  $4\n)")
        (funcall create emc "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n  $4\n)")
        (funcall create emc "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n  $2\n)")
        (funcall create emc "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n  $2\n)")))
	;;; lisp-electric.el --- electric commands editing for S-expression

	;; メインとなるS式編集用コマンドは以下の3つです。
	;;
	;; lel-matching-char:
	;;
	;; "(" か "[" を入力するとそれ自体を挿入し、イベントループに入ります。
	;;
	;; イベントループ内ではタブかS-タブを入力すると、S式単位で範囲選択が
	;; できます。
	;;
	;; それ以外を入力することで最初に入力した開き括弧に対応する閉じ括弧
	;; を挿入し、入力のあったイベントを実行し、ループを脱出します。その
	;; ときタブかS-タブによって範囲選択されていると、その範囲の末尾に閉
	;; じ括弧を挿入します。また閉じ括弧の入力でループを脱出すると、カー
	;; ソルが閉じ括弧を置いた場所に移動します。
	;;
	;; 恐らく普通にコードを書いていると勝手に閉じ括弧が挿入されるだけに
	;; なるかと思われます。
	;;
	;; 例)
	;;
	;; alpha beta gamma
	;; ^
	;; この状態から"(","tab","tab","tab",")" と入力すると
	;;
	;; (alpha beta gamma)
	;; ^
	;; この様になります。
	;;
	;; ※^はキャレットの位置です。
	;;
	;;
	;; また "\"" を入力するとそれ自体を挿入し、イベントループに入ります。
	;; "(" や "[" を入力した時と動きは似ていますが、こちらはS式単位では
	;; なく単語単位で範囲選択を変えます。それ以外は上の小機能版と考えて
	;; ください。範囲選択した場合、移動コマンドで抜けるといいかと思われ
	;; ます。
	;;
	;; 例)
	;;
	;; (alpha beta gamma)
	;; ^
	;; この状態から"\"","tab",")" と入力すると
	;;
	;; (alpha "beta" gamma)
	;; ^
	;; この様になります。
	;;
	;; lel-space:
	;;
	;; " " を入力するとそれ自体を挿入し、イベントループに入ります。タブ
	;; かS-タブを入力することによってS式単位で範囲選択できるのは
	;; lel-matching-charと同様です。
	;;
	;; 再度 " " を入力すると、最初のスペースを入力する前の状態で
	;; yasnippetが展開できるなら展開し、範囲選択されていたらその範囲を
	;; lel-lisp-snippetsなどで指定されたフィールドの位置に挿入します。展
	;; 開できなければ " " を挿入してループを脱出します。
	;;
	;; ")" か "]" を入力すると、前の式もしくは要素の前と現在のポイントの
	;; 位置もしくは範囲選択されている場合その範囲の末尾に入力された括弧
	;; のペアを挿入します。
	;;
	;; 例)
	;;
	;; listalpha beta gamma
	;; ^
	;; この状態から " ","tab","tab","tab",")" と入力すると
	;;
	;; (list alpha beta gamma)
	;; ^
	;; この様になります。
	;;
	;; また、
	;;
	;; lambda
	;; ^
	;; (+ a 5)
	;;
	;; この状態から " ","tab"," " と入力すると
	;;
	;; (lambda ()
	;; ^
	;; (+ a 5)
	;; )
	;;
	;; この様になります。
	;;
	;; lel-del-form:
	;;
	;; カーソル位置付近の一番レベルの低いリストの要素を削除します。その
	;; 要素がリストの先頭ならそのリストをくくっている括弧のペアも削除し
	;; ます。
	;;
	;;
	;; lel-matching-char,lel-spaceの2つのコマンドは、コマンド終了時に範囲
	;; 選択されていた場所をインデントします。
	;;
	;; delformはリストの先頭要素を削除した場合、そのリストであった部分全体
	;; をインデントします。
	;;

	(require 'yasnippet nil t) ;先にyasnippetを導入しといてください
	(require 'slime nil t) ;snippetの登録に必要です(common-lisp)
	(require 'scheme-complete nil t) ;snippetの登録に必要です(scheme)
	(require 'gosh-mode nil t) ;snippetの登録に必要です(gauche専用)

	(eval-when-compile (require 'cl))

	(defun lel-expandable-keyword-alist()
	(case major-mode
	((gauche-mode scheme-mode gosh-mode) lel-scheme-snippets)
	((lisp-mode common-lisp-mode) lel-lisp-snippets)
	((emacs-lisp-mode lisp-interaction-mode) lel-emacs-snippets)))

	(defvar lel-scheme-snippets
	'(("define" . 2)
	("if" . 2)
	("lambda" . 2)
	("let" . 4)
	("leta" . 4)
	("letrec" . 4)
	("let1" . 3)
	("map" . 1)
	("for-each" . 1)
	("unless" . 2)
	("when" . 2)))

	(defvar lel-lisp-snippets
	'(("defun" . 3)
	("defvar" . 2)
	("if" . 2)
	("lambda" . 2)
	("let" . 4)
	("leta" . 4)
	("unless" . 2)
	("when" . 2)))

	(defvar lel-emacs-snippets
	'(("defun" . 3)
	("defvar" . 2)
	("if" . 2)
	("lambda" . 2)
	("let" . 4)
	("leta" . 4)
	("unless" . 2)
	("when" . 2)))

	(defvar lisp-electric-mode-map nil
	"Keymap for lisp electric mode.")

	(if lisp-electric-mode-map
	nil
	(progn
	(setq lisp-electric-mode-map (make-sparse-keymap))
	(define-key lisp-electric-mode-map " " 'lel-space);yas
	(define-key lisp-electric-mode-map "(" 'lel-matching-char)
	(define-key lisp-electric-mode-map "[" 'lel-matching-char)
	(define-key lisp-electric-mode-map "\"" 'lel-matching-char)
	; (define-key lisp-electric-mode-map "*" 'lel-matching-char)
	; (define-key lisp-electric-mode-map "+" 'lel-matching-char)
	(define-key lisp-electric-mode-map [(M d)] 'lel-del-form)
	(define-key lisp-electric-mode-map [(C c)(C k)] 'lel-del-form)))

	(define-minor-mode lisp-electric-mode
	"Toggle Lisp Electric mode.
	With no argument, this command toggles the mode. Non-null prefix
	argument turns on the mode. Null prefix argument turns off the
	mode."
	;;indicator for the mode line.
	:lighter " LEl"
	;;keymap
	:keymap lisp-electric-mode-map)

	(defvar lel-insertion-beg nil)
	(defvar lel-insertion-end nil)
	(defvar lel-overlay nil)

	(defun lel-set-overlay()
	(if lel-overlay
	(move-overlay lel-overlay
	lel-insertion-beg lel-insertion-end
	(current-buffer))
	(progn
	(setq lel-overlay
	(make-overlay lel-insertion-beg
	lel-insertion-end))
	(make-face 'lel-insertion-face)
	(set-face-background 'lel-insertion-face "Firebrick4")
	(overlay-put lel-overlay 'priority 200)
	(overlay-put lel-overlay 'face 'lel-insertion-face))))

	(defun lel-msg-end()
	(message
	(concat
	"End: ... "
	(replace-regexp-in-string
	"\n" "\\\\n"
	(buffer-substring-no-properties
	lel-insertion-end
	(- lel-insertion-end 20))))))

	(defun lel-insertion-fore(num)
	(ignore-errors
	(let ((end (if (lel-code-at-point-p)
	(or (scan-sexps lel-insertion-end num) (buffer-end 1))
	(save-excursion
	(goto-char lel-insertion-end)
	(forward-word num) (point)))))
	(setq lel-insertion-end end)
	(lel-set-overlay)
	(lel-msg-end))))

	(defun lel-insertion-back(num)
	(ignore-errors
	(let ((end (if (lel-code-at-point-p)
	(scan-sexps lel-insertion-end (- num))
	(save-excursion
	(goto-char lel-insertion-end)
	(backward-word num) (point)))))
	(setq lel-insertion-end end)
	(lel-set-overlay)
	(lel-msg-end))))

	(defun lel-insertion-clear()
	(setq lel-insertion-end lel-insertion-beg)
	(if lel-overlay (delete-overlay lel-overlay)))

	(defun lel-code-at-point-p()
	(and lisp-electric-mode
	(let ((properties0 (text-properties-at (point)))
	(properties1 (text-properties-at (- (point) 1))))
	(or (and (null (memq 'font-lock-string-face properties0))
	(null (memq 'font-lock-comment-face properties0)))
	(and (null (memq 'font-lock-string-face properties1))
	(null (memq 'font-lock-comment-face properties1)))))))

	(defun lel-string-at-point-p()
	(and lisp-electric-mode
	(consp (memq 'font-lock-string-face (text-properties-at (point))))))

	(defun lel-beg-point()
	(or (ignore-errors
	(save-excursion
	(backward-sexp)
	(point)))
	(point)))

	(defun lel-insert-paren(event fragment width division)
	(let ((close event)
	(open (or (car (rassoc (list event) insert-pair-alist))
	event))
	(beg (lel-beg-point)))
	(goto-char lel-insertion-end)
	(while (looking-back "[ \n\t]") (backward-char))
	(when (looking-at " \\(\\'\\\|\n\\\|)\\)") (forward-char))
	(save-excursion (insert close))
	(incf lel-insertion-end)
	(dotimes (i (1- division))
	(backward-sexp width)
	(save-excursion (insert open fragment " "))
	(while (looking-back "[ \n\t]") (backward-char))
	(save-excursion (insert close))
	(setq lel-insertion-end (+ lel-insertion-end (length fragment) 3)))
	(goto-char beg)
	(insert open)
	(forward-sexp)
	(forward-char)
	(indent-region beg lel-insertion-end)
	(if lel-overlay (delete-overlay lel-overlay))))

	(defun lel-insert-end(width division)
	(let ((open last-command-event)
	(close (or (cadr (assoc last-command-event insert-pair-alist))
	last-command-event)))
	(goto-char lel-insertion-end)
	(while (looking-back "[ \t\n]") (backward-char))
	(save-excursion (insert close))
	(incf lel-insertion-end)
	(dotimes (i (- division 1))
	(if (lel-string-at-point-p)
	(backward-word width)
	(backward-sexp width))
	(save-excursion (insert open))
	(incf lel-insertion-end)
	(if (lel-string-at-point-p)
	(while (looking-back "\\W") (backward-char))
	(while (looking-back "[ \n\t]") (backward-char)))
	(save-excursion (insert close))
	(incf lel-insertion-end))))

	(defun no-err-match-string()
	(ignore-errors
	(match-string 0)))

	(defun backward-delimiter-point()
	(save-excursion
	(re-search-backward "\\(\\s\(\\\|\\s\)\\\|[: \n\t]\\)")
	(point)))

	(defun forward-delimiter-point()
	(save-excursion
	(re-search-forward "\\(\\s\(\\\|\\s\)\\\|[ \n\t]\\)")
	(point)))

	(defun lel-del-form()
	(interactive)
	(let* ((back (backward-delimiter-point))
	(from (string-to-char (no-err-match-string)))
	(fore (forward-delimiter-point))
	(to (string-to-char (no-err-match-string))))
	(case from
	(32 ;spc
	(delete-region back (- fore 1)))
	((?\] ?\))
	(delete-region (+ back 1) (- fore 1)))
	((?\( ?\[)
	(let ((end
	(ignore-errors
	(save-excursion
	(re-search-backward "\\s\(")
	(forward-sexp)
	(delete-backward-char 1)
	(point)))))
	(case to ((?\( ?\) ?\[ ?\]) (decf fore)))
	(delete-region back fore)
	(indent-region back (- end (- fore back))))))))

	(defun lel-format-and-regist-snippet(arglist)
	(let* ((str-lis (split-string
	(replace-regexp-in-string
	"\\.\\.\\." " ..."
	(replace-regexp-in-string
	"\\(\\[\\\|\\]\\)" " "
	arglist))
	" +"))
	(str (cdr str-lis))
	(result (car str-lis))
	(key (substring (car str-lis) 1))
	(count 1))
	(while (not (equal str nil))
	(let* ((open (and (string-match "\\((\\\|\\]\\)+" (car str)) (match-string 0 (car str))))
	(close (and (string-match "\\()\\\|\\[\\)+" (car str)) (match-string 0 (car str))))
	(sbstr-beg (if open (length open) 0))
	(sbstr-end (if close (- (length close)) nil)))
	(setq result (concat result
	" " open "${"
	(number-to-string count)
	":"
	(substring (car str) sbstr-beg sbstr-end)
	"}" close)))
	(incf count)
	(setq str (cdr str)))
	(case major-mode
	((gauche-mode scheme-mode gosh-mode)
	(setq lel-scheme-snippets (cons (cons key (- count 1)) lel-scheme-snippets)))
	((lisp-mode common-lisp-mode)
	(setq lel-lisp-snippets (cons (cons key (- count 1)) lel-lisp-snippets)))
	((emacs-lisp-mode lisp-interaction-mode)
	(setq lel-emacs-snippets (cons (cons key (- count 1)) lel-emacs-snippets))))
	result))

	(defun lel-define-lisp-snippet()
	(let ((func (slime-symbol-at-point)))
	(ignore-errors
	(yas/define-snippets
	'lisp-mode
	(list (list func
	(lel-format-and-regist-snippet
	(slime-eval `(swank:operator-arglist ,func ,(slime-current-package))))
	func))))))

	(defun lel-define-emacs-snippet()
	(let ((func (symbol-at-point)))
	(ignore-errors
	(yas/define-snippets
	'emacs-lisp-mode
	(list (list (symbol-name func)
	(lel-format-and-regist-snippet
	(or (car (help-split-fundoc (documentation func) func))
	(format "%S"
	(help-make-usage func (help-function-arglist func)))))
	(symbol-name func)))))))

	(defun lel-define-scheme-snippet()
	(let ((func (scheme-symbol-at-point)))
	(ignore-errors
	(yas/define-snippets
	'scheme-mode
	(list (list (symbol-name func)
	(lel-format-and-regist-snippet
	(scheme-sexp-to-string
	(cons func
	(or (cadadr (scheme-env-lookup (scheme-current-env) func))
	(cadr (scheme-env-lookup (scheme-current-env) func))))))
	(symbol-name func)))))))

	(defun lel-define-gosh-snippet()
	(let ((func (gosh-parse-symbol-at-point)))
	(ignore-errors
	(yas/define-snippets
	'scheme-mode
	(mapcar
	#'(lambda (sexp)
	(let ((str (gosh-eldoc--sexp->string
	(cons func (or (cadadr sexp) (cadr sexp))))))
	(list (symbol-name func) (lel-format-and-regist-snippet str) str)))
	(gosh-env-matches (gosh-parse-current-env) func nil))))))

	(defun lel-define-snippet()
	(case major-mode
	((emacs-lisp-mode lisp-interaction-mode)
	(lel-define-emacs-snippet))
	((lisp-mode common-lisp-mode)
	(and (featurep 'slime) (lel-define-lisp-snippet)))
	((gauche-mode scheme-mode)
	(and (featurep 'scheme-complete) (lel-define-scheme-snippet)))
	(gosh-mode
	(and (featurep 'gosh-mode) (lel-define-gosh-snippet)))))

	(defun lel-space(arg)
	(interactive "P")
	(if (lel-code-at-point-p)
	(let* ((division (prefix-numeric-value arg))
	(width 0)
	(fragment
	(buffer-substring (lel-beg-point) (point)))
	(expandable
	(lambda ()
	(member fragment (mapcar 'car (lel-expandable-keyword-alist)))))
	(nth-field
	(lambda ()
	(- (or (cdr (assoc fragment (lel-expandable-keyword-alist))) 1) 1)))
	(begin
	(progn (insert " ")
	(save-excursion (re-search-forward "[ \n\t]*"))
	(+ (point) (length (no-err-match-string)))))
	(done nil))
	(setq lel-insertion-beg begin
	lel-insertion-end begin)
	(while (not done)
	(let ((event (read-event)))
	(case event
	(15 (lel-insertion-clear) (incf division) (setq width 0))
	(33554447 (lel-insertion-clear) (decf division) (setq width 0))
	((9 'tab) (lel-insertion-fore division) (incf width))
	((33554441 'S-tab) (lel-insertion-back division) (decf width))
	((41 93)
	(lel-insert-paren event fragment width division)
	(setq done t))
	(32 ;spc
	(let ((inside
	(buffer-substring lel-insertion-beg lel-insertion-end))
	(inside-beg nil)
	(inside-end nil))
	(if (and (featurep 'yasnippet)
	(not (funcall expandable)))
	(save-excursion
	(backward-char)
	(and (looking-back "\\(\\sw\\\|\\s_\\)")
	(lel-define-snippet))))
	(if (and (featurep 'yasnippet)
	(funcall expandable))
	(progn
	(delete-region lel-insertion-beg lel-insertion-end)
	(while (looking-back "[ \n\t]") (backward-char))
	(delete-char 1)
	(yas/expand)
	(dotimes (i (funcall nth-field)) (yas/next-field))
	(setq inside-beg (point))
	(insert inside)
	(setq inside-end (point))
	(indent-region inside-beg inside-end)
	(dotimes (i (funcall nth-field)) (yas/prev-field)))
	(push event unread-command-events))
	(if lel-overlay (delete-overlay lel-overlay))
	(setq done t)))
	(t
	(progn
	(push event unread-command-events)
	(if lel-overlay (delete-overlay lel-overlay))
	(setq done t)))))))
	(insert " ")))

	(defun lel-matching-char(arg)
	(interactive "P")
	(let ((division (prefix-numeric-value arg))
	(width 0)
	(done nil))
	(self-insert-command 1)
	(when (lel-code-at-point-p)
	(setq lel-insertion-beg (point)
	lel-insertion-end (point))
	(while (not done)
	(let ((event (read-event)))
	(case event
	(15 (lel-insertion-clear) (incf division) (setq width 0))
	(33554447 (lel-insertion-clear) (decf division) (setq width 0))
	((9 'tab) (lel-insertion-fore division) (incf width))
	((33554441 'S-tab) (lel-insertion-back division) (decf width))
	((41 93)
	(lel-insert-end width division)
	(indent-region lel-insertion-beg lel-insertion-end)
	(if lel-overlay (delete-overlay lel-overlay))
	(setq done t))
	(t
	(save-excursion
	(lel-insert-end width division)
	(indent-region lel-insertion-beg lel-insertion-end)
	(push event unread-command-events)
	(if lel-overlay (delete-overlay lel-overlay))
	(setq done t)))))))))

	(defun lel-del-tail()
	(save-excursion
	(goto-char yas/snippet-end)
	(while (and lisp-electric-mode (looking-back "[ \n\t)]"))
	(when (looking-back "[ \n\t]") (delete-backward-char 1))
	(when (looking-back ")") (backward-char)))))

	(add-hook 'yas/after-exit-snippet-hook 'lel-del-tail)

	(provide 'lisp-electric)

	;;; lisp-electric.el ends here


	;; lisp-electricとyasnippetをインストールした後、
	;;
	;; (yas/load-directory "~/.emacs.d/snippets") とか
	;; (setq yas/root-directory "~/.emacs.d/snippets") とか
	;;
	;; してyas/root-directoryが空でない状態になったら、以下のコードのクオー
	;; トをはずして一回だけ実行(eval-regionとかで)してください。snippetがイ
	;; ンストールされます。(前にあったやつは消されるのでバックアップ取るか
	;; 手動でsnippet作ってください)

	'(and yas/root-directory
	(let* ((scm (concat yas/root-directory "/text-mode/scheme-mode/"))
	(lsp (concat yas/root-directory "/text-mode/lisp-mode/"))
	(emc (concat yas/root-directory "/text-mode/emacs-lisp-mode/"))
	(create (lambda (dir file snippet) (progn (find-file (concat dir file)) (erase-buffer) (insert snippet) (save-buffer) (kill-this-buffer)))))
	(shell-command (concat "mkdir " scm)) (shell-command (concat "mkdir " lsp)) (shell-command (concat "mkdir " emc))
	(funcall create scm "define" "#name : define template\n#contributor : rallentando\n# --\n(define ($1)\n $2\n)")
	(funcall create scm "for-each" "#name : for-each template\n#contributor : rallentando\n# --\n(for-each\n $1\n)")
	(funcall create scm "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n $2\n $3\n)")
	(funcall create scm "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n $2\n)")
	(funcall create scm "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n $4\n)")
	(funcall create scm "let1" "#name : let1 template\n#contributor : rallentando\n# --\n(let1 $1 $2\n $3\n)")
	(funcall create scm "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n $4\n)")
	(funcall create scm "letrec" "#name : letrec template\n#contributor : rallentando\n# --\n(letrec (($1 $2)$3)\n $4\n)")
	(funcall create scm "map" "#name : map template\n#contributor : rallentando\n# --\n(map\n $1\n)")
	(funcall create scm "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n $2\n)")
	(funcall create scm "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n $2\n)")
	(funcall create lsp "defun" "#name : defun template\n#contributor : rallentando\n# --\n(defun $1($2)\n $3\n)")
	(funcall create lsp "defvar" "#name : defvar template\n#contributor : rallentando\n# --\n(defvar $1\n $2\n)")
	(funcall create lsp "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n $2\n $3\n)")
	(funcall create lsp "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n $2\n)")
	(funcall create lsp "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n $4\n)")
	(funcall create lsp "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n $4\n)")
	(funcall create lsp "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n $4\n)")
	(funcall create lsp "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n $2\n)")
	(funcall create lsp "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n $2\n)")
	(funcall create emc "defun" "#name : defun template\n#contributor : rallentando\n# --\n(defun $1($2)\n $3\n)")
	(funcall create emc "defvar" "#name : defvar template\n#contributor : rallentando\n# --\n(defvar $1\n $2\n)")
	(funcall create emc "if" "#name : if template\n#contributor : rallentando\n# --\n(if ($1)\n $2\n $3\n)")
	(funcall create emc "lambda" "#name : lambda template\n#contributor : rallentando\n# --\n(lambda ($1)\n $2\n)")
	(funcall create emc "let" "#name : let template\n#contributor : rallentando\n# --\n(let (($1 $2)$3)\n $4\n)")
	(funcall create emc "leta" "#name : let* template\n#contributor : rallentando\n# --\n(let* (($1 $2)$3)\n $4\n)")
	(funcall create emc "unless" "#name : unless template\n#contributor : rallentando\n# --\n(unless ($1)\n $2\n)")
	(funcall create emc "when" "#name : when template\n#contributor : rallentando\n# --\n(when ($1)\n $2\n)")))