Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
(eval-when-compile
(require 'cl)
(unless (fboundp 'cl-letf) (defalias 'cl-letf 'letf)))
(require 'sgml-mode)
(defgroup hatena-markup nil
"Major mode for Hantea markup language."
:prefix "hatena-markup-"
:group 'hypermedia)
(defface hatena:markup:title
'((((class color) (min-colors 8) (background dark))
:foreground "#dfaf8f")
(((class color) (min-colors 8) (background light))
:foreground "#4f1f0f"))
"Face for Hatena markup title."
:group 'hatena-markup)
(defface hatena:markup:title-name
'((t (:inherit hatena:markup:title :foreground "LemonChiffon4")))
"Face for Hatena markup title."
:group 'hatena-markup)
(defface hatena:markup:title-time
'((t (:inherit hatena:markup:title-name)))
"Face for Hatena markup title."
:group 'hatena-markup)
(defface hatena:markup:title-category
'((t (:inherit hatena:markup:title :foreground "LemonChiffon4")))
"Face for Hatena markup title."
:group 'hatena-markup)
(defface hatena:markup:headline1
'((((class color) (min-colors 8) (background dark))
:foreground "#8fb28f" :underline t)
(((class color) (min-colors 8) (background light))
:foreground "#0f320f" :underline t))
"Face for Hatena markup headlines."
:group 'hatena-markup)
(defface hatena:markup:headline2
'((((class color) (min-colors 8) (background dark))
:foreground "#7cb8bb")
(((class color) (min-colors 8) (background light))
:foreground "#0c484b"))
"Face for Hatena markup small headlines."
:group 'hatena-markup)
(defface hatena:markup:list-item
'((t (:inherit font-lock-string-face)))
"Face for Hatena markup list items."
:group 'hatena-markup)
(defface hatena:markup:list-item-text
'((t (:inherit default)))
"Face for Hatena markup list item texts."
:group 'hatena-markup)
(defface hatena:markup:definition-term
'((t (:inherit font-lock-string-face)))
"Face for Hatena markup definition terms."
:group 'hatena-markup)
(defface hatena:markup:definition-description
'((t (:inherit default)))
"Face for Hatena markup definition descriptions."
:group 'hatena-markup)
(defface hatena:markup:table-field
'((((class color) (min-colors 8) (background dark))
:foreground "#9fc59f")
(((class color) (min-colors 8) (background light))
:foreground "#1f451f"))
"Face for Hatena markup table fields."
:group 'hatena-markup)
(defface hatena:markup:table-head
'((((class color) (min-colors 8) (background dark))
:foreground "#94bff3")
(((class color) (min-colors 8) (background light))
:foreground "#142f73"))
"Face for Hatena markup table heads."
:group 'hatena-markup)
(defface hatena:markup:table-separator
'((t (:inherit hatena:markup:table-field)))
"Face for Hatena markup table separators."
:group 'hatena-markup)
(defface hatena:markup:blockquote
'((t (:foreground "DarkKhaki")))
"Face for Hatena markup blockquotes."
:group 'hatena-markup)
(defface hatena:markup:pre
'((((class color) (min-colors 8) (background dark))
:foreground "DarkKhaki")
(((class color) (min-colors 8) (background light))
:foreground "khaki4"))
"Face for Hatena markup preformatted text indicators."
:group 'hatena-markup)
(defface hatena:markup:pre-language
'((t (:foreground "tomato")))
"Face for Hatena markup preformatted text language specification."
:group 'hatena-markup)
(defface hatena:markup:footnote
'((((class color) (min-colors 8) (background dark))
:foreground "#93e0e3")
(((class color) (min-colors 8) (background light))
:foreground "#136063"))
"Face for Hatena markup footenotes."
:group 'hatena-markup)
(defface hatena:markup:read-more
'((t (:inherit font-lock-comment-face)))
"Face for Hatena markup read more indicators."
:group 'hatena-markup)
(defface hatena:markup:url
'((((class color) (min-colors 8) (background dark))
:foreground "#d0bf8f" :underline t)
(((class color) (min-colors 8) (background light))
:foreground "#503f0f" :underline t))
"Face for Hatena markup urls."
:group 'hatena-markup)
(defface hatena:markup:link
'((((class color) (min-colors 8) (background dark))
:foreground "IndianRed2")
(((class color) (min-colors 8) (background light))
:foreground "IndianRed4"))
"Face for Hatena markup links."
:group 'hatena-markup)
(defconst hatena-markup-auto-links
'("mailto" "map" "twitter"
"id" "question" "a:id" "b:id" "d:id" "f:id" "g" "idea" "i:id" "graph:id"
"isbn" "ISBN" "asin" "ASIN" "jan" "JAN" "ean" "EAN" "ugomemo"))
(defconst hatena-markup-links
`("niconico" "google" "amazon" "wikipedia" "search"
"b:t" "b:keyword" "h:keyword" "h:id" "i:t" "graph:t" "keyword" "tex" "uke"
"rakuten" ,@hatena-markup-auto-links))
(defconst hatena-markup-url "s?https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+")
(defconst hatena-markup-font-lock-keywords
`(;; title
("^\\*[^*].*$" 0 'hatena:markup:title)
("^\\*\\([-_a-zA-Z0-9]+\\)\\*" 1 'hatena:markup:title-name t)
("^\\*\\([0-9]+\\)\\*" 1 'hatena:markup:title-time t)
("^\\*[^*]+\\*\\(\\(?:\\[.*?\\]\\)+\\)" 1 'hatena:markup:title-category t)
("^\\*\\(\\(?:\\[.*?\\]\\)+\\)" 1 'hatena:markup:title-category t)
;; headline1
("^\\*\\*[^*].*$" 0 'hatena:markup:headline1)
;; headline2
("^\\*\\*\\*.*$" 0 'hatena:markup:headline2)
;; list item
("^\\([-+]+\\)\\(.*\\)$"
(1 'hatena:markup:list-item)
(2 'hatena:markup:list-item-text))
;; definition list
("^\\(:[^:]*?:\\)\\(.*\\)$"
(1 'hatena:markup:definition-term)
(2 'hatena:markup:definition-description))
;; table
("^|"
(0 'hatena:markup:table-separator)
("\\(*[^|]*\\)\\(|\\)"
nil (progn (re-search-backward "^|") (forward-char)) ; reset
(1 'hatena:markup:table-head)
(2 'hatena:markup:table-separator))
("\\([^|]*\\)\\(|\\)" nil nil
(1 'hatena:markup:table-field)
(2 'hatena:markup:table-separator)))
;; blockquote
(,(format "^\\(>>\\|>%s>\\|>%s%s>\\|<<\\)$"
hatena-markup-url hatena-markup-url
"\\(?::title\\|:title=.*\\|:bookmark\\)*")
1 'hatena:markup:blockquote)
;; pre
("^\\(>|\\)\\([a-zA-Z0-9_?]+\\)\\(|\\)$"
(1 'hatena:markup:pre t)
(2 'hatena:markup:pre-language t)
(3 'hatena:markup:pre t))
("^\\(>||\\|||<\\)$" (1 'hatena:markup:pre t))
("^\\(>|\\||<\\)$" 1 'hatena:markup:pre t)
;; footnote
("\\(((.*?))\\|((\\|))\\)" 0 'hatena:markup:footnote t)
;; read more
("^=====?$" 0 'hatena:markup:read-more)
;; url
(,hatena-markup-url 0 'hatena:markup:url t)
(,(concat "\\[" hatena-markup-url "\\]") 0 'hatena:markup:url t)
;; link without []
(,(concat "\\[" (regexp-opt hatena-markup-links) ":.*?\\]")
0 'hatena:markup:link t)
;; link with []
("\\[\\]" 0 'hatena:markup:link)
(,(concat (regexp-opt hatena-markup-auto-links) ":[a-zA-Z0-9:_+#]+")
0 'hatena:markup:link t)
("\\[\\[.*?\\]\\]" 0 'hatena:markup:link t)
;; comment
("\\(><!--\\|--><\\)" 0 'font-lock-comment-delimiter-face t)))
;;;###autoload
(define-derived-mode hatena:markup-mode html-mode "Hatena"
"Major mode for Hatena markup language."
(font-lock-add-keywords 'hatena:markup-mode hatena-markup-font-lock-keywords)
(font-lock-mode 1)
(set (make-local-variable 'indent-line-function) 'hatena-markup-indent-line))
(defalias 'sgml-parse-tag-backward-orig
(symbol-function 'sgml-parse-tag-backward))
(defun hatena-markup-parse-tag-backward (&optional limit)
(let ((savep (point)))
(prog1 (sgml-parse-tag-backward-orig limit)
(when (save-excursion (re-search-forward "^||?<$" (1+ savep) t))
(goto-char savep)
(error "No tag found")))))
(defun hatena-markup-indent-line ()
(let ((lcon (sgml-lexical-context)))
(cond
((save-excursion (beginning-of-line) ; pre and super-pre
(looking-at-p "^\\(>|[a-zA-Z0-9_?]*|?\\||?|<\\)$"))
'noindent)
((and (integerp (cdr lcon))
(or (eq (car lcon) 'tag)
(and (eq (car lcon) 'text)
(save-excursion
(skip-chars-forward " \t\n")
(not (looking-at-p "</")))))
(save-excursion
(goto-char (cdr lcon))
(or (looking-back "^>")
(looking-at-p "<$")
(let ((lcon2 (sgml-lexical-context)))
(when (integerp (cdr lcon2)) (goto-char (cdr lcon2)))
(and (integerp (cdr lcon2))
(eq (car lcon2) 'tag) (looking-at-p "<$"))))))
(let* ((here (point))
(savep (save-excursion (back-to-indentation) (< (point) here)))
(context
(cl-letf (((symbol-function 'sgml-parse-tag-backward)
(symbol-function 'hatena-markup-parse-tag-backward)))
(goto-char (cdr lcon))
(prog1 (nreverse (sgml-get-context nil))
(when (save-excursion (beginning-of-line)
(looking-at-p "||?<$"))
(beginning-of-line)))))
(col (+ (current-column) (* sgml-basic-offset (length context)))))
(goto-char here)
(if savep
(save-excursion (indent-line-to col))
(indent-line-to col))))
(t (sgml-indent-line)))))
(defun hatena-markup-filter-context (context)
(loop for tag in context
when (> (length (sgml-tag-name tag)) 0)
collect tag into result
finally return result))
(defadvice sgml-get-context (around dont-count-empty-tag activate)
(let ((context ad-do-it))
(setq ad-return-value (hatena-markup-filter-context context))))
(provide 'hatena-markup-mode)
;;; hatena-markup-mode.el ends here
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.