改変 markdown-mode for #xyzzy (色付け & メジャーモード化)

markdown-mode.l

;; -*- mode:lisp; package:markdown-mode -*-

;; markdown.l ( http://www.geocities.jp/kiaswebsite/xyzzy/markdown.html )
;; Rev: 227 を元に改変
;;
;; License
;; =======
;;
;; Copyright (c) 2011 Yousuke Ushiki <[email protected]>
;; Copyright (c) 2005,2006 kia
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without
;; limitation the rights to use, copy, modify, merge, publish, distribute,
;; sublicense, and/or sell copies of the Software, and to permit persons to
;; whom the Software is furnished to do so, subject to the following
;; conditions:
;;
;; The above copyright notice and this permission notice shall be included
;; in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;
;;

(provide "markdown")

(in-package "editor")
(export '(markdown-mode))

(defpackage "markdown-mode"
  (:nicknames "md")
  (:use "lisp" "editor"))

(in-package "md")
(export '(*markdown-mode-map*
	  *markdown-mode-hook*
	  *markdown-use-setext-style*
	  *h1-style* *h2-style* *h3-style* *h4-style* *h5-style* *h6-style*
	  *italic-style* *bold-style* *italic-bold-style*
	  *listmarker-style* *code-style*
	  ))

(defvar *markdown-default-horizontal-rule* "*****")

(defparameter *h1-style* '(:color 7 4 :line :bold))
(defparameter *h2-style* '(:color 7 14 :line :bold))
(defparameter *h3-style* '(:color 9 0 :underline :bold))
(defparameter *h4-style* '(:color 11 0 :underline))
(defparameter *h5-style* '(:color 14 0))
(defparameter *h6-style* '(:color 12 0))
(defparameter *listmarker-style* '(:color 10 0 :bold))
(defparameter *code-style* '(:keyword 1))
(defparameter *italic-style* '(:keyword 2))
(defparameter *bold-style* '(:color 0 0 :bold))
(defparameter *italic-bold-style* '(:keyword 2 :bold))
;(defparameter *horizontal-line-style* '(:color 0 0 :line :underline))

(defun make-regexp-keyword-list ()
  (compile-regexp-keyword-list
   `(("^#[ \t].+" nil ,*h1-style*)
     ("^##[ \t].+" nil ,*h2-style*)
     ("^###[ \t].+" nil ,*h3-style*)
     ("^####[ \t].+" nil ,*h4-style*)
     ("^#####[ \t].+" nil ,*h5-style*)
     ("^######[ \t].+" nil ,*h6-style*)
     ("^[ \t]*[*+-][ \t]" nil ,*listmarker-style*)
;     ("^[^ \n][^\n]+\n=+$" nil ,(remove :line *h1-style*))
;     ("^[^ \n][^\n]+\n-+$" nil ,(remove :line *h2-style*))
     ("^=+$" nil ,(remove :line *h1-style*))
     ("^-+$" nil ,(remove :line *h2-style*))
;     ("\n\\([-*_]\\)\\1\\1+\n" nil ,*horizontal-line-style*)
     ("`[^\n`]+`" nil ,*code-style*)
     ("\\*\\*\\*[^\n*]+\\*\\*\\*" nil ,*italic-bold-style*)
     ("\\*\\*[^\n*]+\\*\\*" nil ,*bold-style*)
     ("\\*[^\n*]+\\*" nil ,*italic-style*)
     ("___[^\n_]+___" nil ,*italic-bold-style*)
     ("__[^\n_]+__" nil ,*bold-style*)
     ("_[^\n_]+_" nil ,*italic-style*)
     )))

(defvar *markdown-use-setext-style* t)

(defvar *markdown-prefix-key* '(#\C-c))

(defvar *markdown-mode-map* nil)
(defun setup-keymap ()
  (unless *markdown-mode-map*
    (let ((m (setq *markdown-mode-map* (make-sparse-keymap))))
      (flet ((pk (c) `(,@*markdown-prefix-key* ,c)))
	(define-key m #\RET 'markdown-newline)
	(define-key m (pk #\1) 'markdown-set-header-1)
	(define-key m (pk #\2) 'markdown-set-header-2)
	(define-key m (pk #\3) 'markdown-set-header-3)
	(define-key m (pk #\4) 'markdown-set-header-4)
	(define-key m (pk #\5) 'markdown-set-header-5)
	(define-key m (pk #\6) 'markdown-set-header-6)
	(define-key m (pk #\f) 'markdown-next-header)
	(define-key m (pk #\b) 'markdown-previous-header)
	(define-key m (pk #\h) 'markdown-set-header)
	(define-key m (pk #\-) 'markdown-horizontal-rule)
	(define-key m (pk #\^) 'markdown-reindent-with-marker-removal)
	(define-key m (pk #\>) 'markdown-shift-region)
	(define-key m (pk #\<) 'markdown-unshift-region)
	(define-key m (pk #\C-q) 'markdown-quote-region)))))

(defvar *markdown-mode-hook* nil)

(defvar *markdown-quote-re* "\\(?:[ \t]*>\\)+[ \t]*")

(defun markdown-quote-skip ()
  (if (looking-at *markdown-quote-re*)
      (let ((s (match-string 0)))
        (goto-char (+ (point) (length s)))
        s)
    ""))

(defun markdown-atx-header-p ()
  (save-excursion
    (goto-bol)
    (markdown-quote-skip)
    (when (looking-at "\\(#\\{1,6\\}\\)[ \t]*[^#]+[ \t]*#*$")
      (length (match-string 1)))))

(defun markdown-setext-header-p ()
  (save-excursion
    (let* ((q (progn (goto-bol) (markdown-quote-skip)))
           (col (progn (goto-eol) (- (current-column) (length q)))))
      (when (forward-line)
        (goto-bol)
        (when (and (string= q (markdown-quote-skip))
                   (looking-at "\\(?:=+\\|-+\\)")
                   (= (length (match-string 0)) col))
          (following-char))))))

(defun markdown-header-p ()
  (or (markdown-atx-header-p) (markdown-setext-header-p)))

(defun markdown-unset-atx-header ()
  (save-excursion
    (save-restriction
      (let ((end (progn (goto-eol) (point))))
        (goto-bol)
        (markdown-quote-skip)
        (narrow-to-region (point) end)
        (replace-buffer "#+[ \t]*\\(.+[^# \t]\\)[ \t]*#*" "\\1" :regexp t)))))

(defun markdown-unset-setext-header ()
  (save-excursion
    (goto-eol)
    (let ((beg (point)))
      (forward-line)
      (goto-eol)
      (delete-region beg (point)))))

(defun markdown-unset-header ()
  (cond ((markdown-atx-header-p) (markdown-unset-atx-header))
        ((markdown-setext-header-p) (markdown-unset-setext-header))))

(defun markdown-search-preceding-header ()
  (save-excursion
    (while (forward-line -1)
      (let ((p (markdown-header-p)))
        (and p (return p))))))

(defun markdown-setext-header-exists-p ()
  (save-excursion
    (goto-char (point-min))
    (or (markdown-setext-header-p)
        (while (forward-line)
          (if (markdown-setext-header-p)
              (return t))))))

(defun markdown-atx-header (n)
  (save-excursion
    (goto-bol)
    (markdown-quote-skip)
    (insert #\# n)
    (insert #\SPC)))

(defun markdown-setext-header (c)
  (save-excursion
    (goto-bol)
    (let ((q (markdown-quote-skip)))
      (goto-eol)
      (let ((col (- (current-column) (length q))))
        (when (> col 0)
          (insert #\LFD q)
          (insert c col))))))

(defun markdown-set-header-by-guess ()
  (let ((ph (or (markdown-search-preceding-header)
                (if *markdown-use-setext-style* #\= 1))))
    (if (numberp ph)
        (markdown-atx-header ph)
      (markdown-setext-header ph))))

(defun markdown-set-header (&optional num)
  (interactive "*p")
  (if (eq *prefix-args* 'universal-argument)
      (markdown-unset-header)
    (if (null num)
        (unless (markdown-header-p)
          (markdown-set-header-by-guess))
      (cond
       ((<= 1 num 2)
        (markdown-unset-header)
        (if (or *markdown-use-setext-style* (markdown-setext-header-exists-p))
            (markdown-setext-header (if (= num 1) #\= #\-))
          (markdown-atx-header num)))
       ((<= 3 num 6)
        (markdown-unset-header)
        (markdown-atx-header num))))))

(defun markdown-set-header-1 () (interactive) (markdown-set-header 1))
(defun markdown-set-header-2 () (interactive) (markdown-set-header 2))
(defun markdown-set-header-3 () (interactive) (markdown-set-header 3))
(defun markdown-set-header-4 () (interactive) (markdown-set-header 4))
(defun markdown-set-header-5 () (interactive) (markdown-set-header 5))
(defun markdown-set-header-6 () (interactive) (markdown-set-header 6))

(defvar *markdown-horizontal-rule-re*
  (format nil "^\\(?:~A\\)??\\(\\([-*]\\)\\(?: *\\2\\)\\{2,\\}\\)[ \t]*$" *markdown-quote-re*))

(defun markdown-horizontal-rule-p ()
  (save-excursion
    (goto-bol)
    (looking-at *markdown-horizontal-rule-re*)))

(defun markdown-search-horizontal-rule ()
  (save-excursion
    (goto-char (point-min))
    (while (scan-buffer *markdown-horizontal-rule-re* :regexp t :tail t)
      (let ((hr (match-string 1))
            (ch (char (match-string 2) 0)))
        (unless (and (char= ch #\-)
                     (save-excursion
                       (and (forward-line -1)
                            (markdown-setext-header-p))))
          (return hr))))))

(defun markdown-horizontal-rule ()
  (interactive)
  (save-excursion
    (let ((q (progn (goto-bol) (markdown-quote-skip)))
          (hr (or (markdown-search-horizontal-rule)
                  *markdown-default-horizontal-rule*)))
      (goto-bol)
      (insert q hr #\LFD))))

(defun markdown-preceding-marker-and-spaces ()
  (save-excursion
    (goto-bol)
    (let ((q (markdown-quote-skip)))
      (cond ((and (not (markdown-horizontal-rule-p)) (looking-at "[ \t]*[-+*][ \t]+"))
             (concat q (match-string 0)))
            ((looking-at "\\([ \t]*\\)\\([0-9]+\\)\\.\\([ \t]*\\)")
             (let ((indent (match-string 1))
                   (num (parse-integer (match-string 2)))
                   (ts (match-string 3)))
               (concat q
                       indent
                       (format nil "~D." (1+ num))
                       (unless (string= ts "")
                         (if (find #\TAB ts)
                             ts
                           (if (= (length (format nil "~D" (1+ num)))
                                  (length (format nil "~D" num)))
                               ts
                             (substring ts 1)))))))
            ((looking-at "[ \t]+")
             (match-string 0))
            (t q)))))

(defun markdown-newline ()
  (interactive)
  (insert #\LFD (markdown-preceding-marker-and-spaces)))

(defun markdown-tab-indentation-exists-p ()
  (save-excursion
    (goto-char (point-min))
    (scan-buffer "^\t+[^ \t]" :regexp t)))

(defun markdown-shift-region (start end &optional (num 1))
  (interactive "*r\np")
  (when (eq *prefix-args* 'universal-argument)
    (setq num -1))
  (let ((col (* num (if (markdown-tab-indentation-exists-p)
                        (tab-columns)
                      4))))
    (shift-region start end col)))

(defun markdown-unshift-region (start end &optional (num -1))
  (interactive "*r\np")
  (when (> num 0)
    (setq num (- num)))
  (markdown-shift-region start end num))

(defun markdown-reindent-with-marker-removal ()
  (interactive)
  (let* ((mas (markdown-preceding-marker-and-spaces))
         (indent (progn (string-match "^[ \t]*" mas) (match-string 0)))
         (new-indent (format nil "~A~A" indent (if (or (string-match "^\t+$" indent) (markdown-tab-indentation-exists-p)) "\t" "    "))))
    (save-excursion
      (goto-bol)
      (insert new-indent)
      (let ((p (point)))
        (delete-region p (+ p (length mas)))))))

(defun markdown-unquote-region (from to)
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region from to)
      (goto-char from)
      (replace-buffer "^[ \t]*>[ \t]*" "" :regexp t))))

(defun markdown-quote-region (from to)
  (interactive "*r")
  (if (eq *prefix-args* 'universal-argument)
      (markdown-unquote-region from to)
    (let ((*quotation-prefix* "> "))
      (quote-region from to))))

(defun markdown-search-header (&optional (dir 1))
  (save-excursion
    (while (forward-line dir)
      (when (markdown-header-p)
        (return (point))))))

(defun markdown-next-header ()
  (interactive)
  (let ((p (markdown-search-header)))
    (when p
      (goto-char p))))

(defun markdown-previous-header ()
  (interactive)
  (let ((p (markdown-search-header -1)))
    (when p
      (goto-char p))))


;;; mode definition
(defvar-local ed::*markdown-mode* nil)

(defun ed::markdown-mode (&optional (arg nil sv))
  (interactive "p")
  (setup-keymap)
  (use-keymap *markdown-mode-map*)
  (unless (local-variable-p '#0=regexp-keyword-list)
    (make-local-variable '#0#))
  (setq #0# (append #0# (make-regexp-keyword-list))
	buffer-mode 'ed::markdown-mode
	mode-name "Markdown")
  (run-hooks '*markdown-mode-hook*)
  t)

;;; markdown-mode.l ends here.