/markdown-mode.l
Created Nov 4, 2011
| ;; -*- mode:lisp; package:markdown-mode -*- | |
| ;; markdown.l ( http://www.geocities.jp/kiaswebsite/xyzzy/markdown.html ) | |
| ;; Rev: 227 を元に改変 | |
| ;; | |
| ;; License | |
| ;; ======= | |
| ;; | |
| ;; Copyright (c) 2011 Yousuke Ushiki <citrus.yubeshi@gmail.com> | |
| ;; 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 | |
| `(("^# .+" nil ,*h1-style*) | |
| ("^## .+" nil ,*h2-style*) | |
| ("^### .+" nil ,*h3-style*) | |
| ("^#### .+" nil ,*h4-style*) | |
| ("^##### .+" nil ,*h5-style*) | |
| ("^###### .+" nil ,*h6-style*) | |
| ("^[ \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. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment