rd-mode.l - 書き捨て御免

xyzzyのruby-mode(のruby-doc.l)や、RDtool添付のruby-mode.elを参考にしながらスクラッチした。
書くものがある程度でかくなる、なんかしっくりこない。我ながらLisp感に欠けるという感想を持った。こなれてないなぁ。
おつとめ

Element の色付け
メジャーモードでは定番の改行とインデントを良きに計らう仕事
Inline Element の挿入コマンド
ぼんやりと付けたいと思ってたり思ってなかったりする機能

Headline のインデックス作成(PukiWikiの{{doc}}だっけ?)
Include ベリファイア
;;; -*- Mode: Lisp; Package: EDITOR -*-
;;; 
;;; This files is not part of xyzzy.
;;;
#|
== configurations

+ Example

In .xyzzy or siteinit.l:

  (require "rd-mode")
  (push '("\\.rd$" . rd-mode) *auto-mode-alist*)
  (rd-keyconfig
   '((:link  #\C-c #\C-l)
     (:ref   #\C-c #\C-r)
     (:em    #\C-c #\C-i #\e)
     (:code  #\C-c #\C-i #\c)
     (:var   #\C-c #\C-i #\v)
     (:kbd   #\C-c #\C-i #\k)
     (:index #\C-c #\C-i #\i)
     (:note  #\C-c #\C-i #\n)
     (:verb  #\C-c #\C-i #\b)))

|#

(require "keyconf")
(provide "rd")
(in-package "editor")

(export '(rd-mode
	  rd-keyconfig
	  *rd-mode-hook*
	  *rd-mode-map*))

(defvar *rd-mode-hook* nil "rd-mode起動時のフック")
(defvar *rd-mode-map* nil "rd-mode用キーマップ")
(defvar *rd-regexp-keyword-list* nil "rd-mode構文ハイライト")

(defun rd-mode ()
  (interactive)
  (kill-all-local-variables)
  (setf buffer-mode 'rd-mode mode-name "RD")
  (use-keymap *rd-mode-map*)
  (make-local-variable 'regexp-keyword-list)
  (setq regexp-keyword-list *rd-regexp-keyword-list*)
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate "=+\\|\\++\\|[ \t\n\^L]*$")
  (make-local-variable 'paragraph-start)
  (setq paragraph-start "=+\\|\\++\\|[ \t\n\^L]")
  (run-hooks '*rd-mode-hook*))

(defun rd-insert-newline ()
  (interactive)
  (insert #\LFD)
  (rd-do-indent-based-on-previous-line))

(defun rd-do-indent-based-on-previous-line ()
  (multiple-value-bind (type baseline) (rd-lex-previous-line)
    (case type
      ((:headline :include :itemlist :enumlist) nil)
      (:commentline
       (save-excursion
	 (forward-line -1)
	 (looking-at "[ \t#]+")
	 (skip-chars-forward " \t#")
	 (setf baseline (current-column)))
       (insert (match-string 0))
       (indent-to baseline))
      (t (indent-to baseline)))))


(defun rd-indent-line ()
  (interactive)
  (unless (member (rd-lex-current-line) '(:headline :include))
    (multiple-value-bind (type baseline) (rd-lex-previous-line)
      (save-excursion
	(goto-bol)
	(delete-region (point)
		       (progn
			 (skip-chars-forward " \t")
			 (point)))
	(indent-to baseline))
	(if (and (bolp) baseline)
	    (skip-chars-forward " \t"))
      )))


(defun rd-lex-current-line ()
  (save-excursion
    (goto-bol)
    (cond ((looking-for "=") (values :headline 0))
	  ((looking-for "+") (values :headline 0))
	  ((looking-for "<<<") (values :include 0))
	  ((looking-for "#") (values :commentline 0))
	  (t (let ((type nil))
	       (skip-chars-forward " \t")
	       (cond ((looking-at "\\*") (setf type :itemlist))
		     ((looking-at "([0-9]+)") (setf type :enumlist))
		     ((looking-at ":") (setf type :desclist))
		     ((looking-at "---") (setf type :methodlist)))
	       (if type (progn
			  (forward-char (length (match-string 0)))
			  (skip-chars-forward " \t"))
		 (setf type (if (looking-at "[^ \t\n]") :textline :whiteline)))
	       (values type (current-column)))))))

(defun rd-lex-previous-line ()
  (save-excursion
    (forward-line -1)
    (rd-lex-current-line)))


;;; initialize *rd-mode-map*
(unless *rd-mode-map*
  (setf *rd-mode-map* (make-sparse-keymap))
  (define-key *rd-mode-map* #\TAB 'rd-indent-line)
  (define-key *rd-mode-map* #\RET 'rd-insert-newline))

;;; initialize *rd-regexp-keyword-list*
(unless *rd-regexp-keyword-list*
  (setf
   *rd-regexp-keyword-list*
   (compile-regexp-keyword-list
    '(("^#" t (:keyword :comment :line))
      ("^<<<" t (:keyword 9 :line :underline))
      ("^=+" t (:keyword 0 :line :bold))
      ("^\\++" t (:keyword 0 :line :bold))
      ("^[ \t]*\\*" t (:keyword 1 :bold))
      ("^[ \t]*([0-9]+)" t (:keyword 1 :bold))
      ("^[ \t]*---" t (:keyword 1 :bold :line))
      ("^[ \t]*:" t (:keyword 1 :bold :line))
      ("^[ \t]*" t (:keyword :string :line))
      ("((\\*.*?\\*))" t :tag)
      ("(({.*?}))" t :tag)
      ("((|.*?|))" t :tag)
      ("((%.*?%))" t :tag)
      ("((:.*?:))" t :tag)
      ("((<.*?>))" t :tag)
      ("((-.*?-))" t :tag)
      ("(('.*?'))" t :tag)))))


(keyconf::define
 rd-keyconfig
 ((:em    rd-inline-em)
  (:code  rd-inline-code)
  (:var   rd-inline-var)
  (:kbd   rd-inline-kbd)
  (:index rd-inline-index)
  (:note  rd-inline-note)
  (:verb  rd-inline-verb)
  (:link  rd-inline-link-wizard)
  (:ref   rd-inline-reference-wizard))
 (lambda (cmd key)
   (define-key *rd-mode-map* key cmd)))


(defun rd-insert-inline (form &optional str (back 3))
  (insert form)
  (backward-char back)
  (if str (insert str)))

(defun rd-inline-em (&optional str)
  (interactive "*") (rd-insert-inline "((**))" str))
(defun rd-inline-code (&optional str)
  (interactive "*") (rd-insert-inline "(({}))" str))
(defun rd-inline-var (&optional str)
  (interactive "*") (rd-insert-inline "((||))" str))
(defun rd-inline-kbd (&optional str)
  (interactive "*") (rd-insert-inline "((%%))" str))
(defun rd-inline-link (&optional str)
  (interactive "*") (rd-insert-inline "((<>))" str))
(defun rd-inline-index (&optional str)
  (interactive "*") (rd-insert-inline "((::))" str))
(defun rd-inline-note (&optional str)
  (interactive "*") (rd-insert-inline "((--))" str))
(defun rd-inline-verb (&optional str)
  (interactive "*") (rd-insert-inline "((''))" str))

(defun rd-inline-link-caption-escape (org)
  (if (string-match "[|/]" org) (format nil "\"~A\"" org) org))

(defun rd-inline-link-wizard (url caption)
  (interactive "sURL: \nsCaption: ")
  (rd-inline-link (if (zerop (length caption))
		      (format nil "URL:~A" url)
		    (format nil "~A|URL:~A"
			    (rd-inline-link-caption-escape caption) url))))

;;; Labelを検索して補完したりしたい(希望。つまり未実装)
(defun rd-inline-reference-wizard (label)
  (interactive "sLabel: ")
  (rd-inline-link (rd-inline-link-caption-escape label)))