208 lines
7.6 KiB

;;; simple-comment-markup.el --- Simple markup fontification in comments -*- lexical-binding: t; -*-
;; Copyright (C) 2022 TEC
;; Author: TEC <>
;; Maintainer: TEC <>
;; Created: August 11, 2022
;; Modified: August 11, 2022
;; Version: 0.0.1
;; Keywords: faces
;; Homepage:
;; Package-Requires: ((emacs "26.3"))
;; This file is not part of GNU Emacs.
;;; Commentary:
;; Simple markup fontification in comments
;;; Code:
(defgroup simple-comment-markup nil
"Simple markup fontification in comments."
:group 'text
:prefix "simple-comment-markup-")
(defcustom simple-comment-markup-patterns
(:start "*" :end "*" :face bold)
(:start "/" :end "/" :face italic)
(:start "_" :end "_" :face underline)
(:start "~" :end "~" :face font-lock-doc-markup-face)
(:start "=" :end "=" :face font-lock-doc-markup-face))
(:start "*" :end "*" :face italic)
(:start "_" :end "_" :face italic)
(:start "**" :end "**" :face bold)
(:start "__" :end "__" :face bold)
(:start "***" :end "***" :face (bold italic))
(:start "`" :end "`" :face font-lock-doc-markup-face))
(:start "`" :end "`" :face font-lock-doc-markup-face))
(:start "`" :end "'" :face font-lock-doc-markup-face))
(:start "<" :body "https?:[^>\n]*[^ >\n]" :end ">" :face link))
(:start "\\(" :end "\\)" :face font-lock-string-face))
(:start "$" :end "$" :face font-lock-string-face)))
"Named sets of simple markup constructs."
:type '(alist :key-type (symbol :tag "Name")
(choice (const :start)
(const :end)
(const :face)
(const :function))
:value-type sexp)))
(defcustom simple-comment-markup-set '(org url)
"The markup pattern sets to use (see `simple-comment-markup-patterns')."
:type '(choice symbol (repeat symbol))
:safe (lambda (value)
(and (listp value)
(null (delq t (mapcar #'symbolp value))))))
(defcustom simple-comment-markup-pre-rx
(rx (any space ?- ?\( ?' ?\" ?\{))
"Regexp that must occur immediately before a markup pattern.
This must not include any capturing groups."
:type 'regexp
:safe #'stringp)
(defcustom simple-comment-markup-post-rx
(rx (or (any space ?- ?. ?, ?\; ?: ?! ?? ?' ?\" ?\) ?\} ?\\ ?\[) line-end))
"Regexp that must occur immediately after a markup pattern.
This must not include any capturing groups."
:type 'regexp
:safe #'stringp)
(defface simple-comment-markup-face
'((t :inherit shadow))
"Face used for markup characters.")
(defun simple-comment-markup--get-patterns (&optional set)
"Return a flattened and sorted list of markup patterns from SET."
(let ((set (or set simple-comment-markup-set)))
(apply #'append
(lambda (pset)
(alist-get pset simple-comment-markup-patterns))
(if (consp set) set (list set)))))
(lambda (a b)
(string-lessp (plist-get b :start) (plist-get a :start))))))
(defvar-local simple-comment-markup--rx-patterns nil)
(defun simple-comment-markup--construct-rx-patterns (&optional set)
"Return a font-lock construct for markup patterns from SET."
(let ((patterns (simple-comment-markup--get-patterns set)))
(lambda (pattern)
(let* ((confounding-start-characters
(delq nil
(lambda (pat)
(and (> (length (plist-get pat :start))
(length (plist-get pattern :start)))
(string= (plist-get pattern :start)
(plist-get pat :start)
0 (length (plist-get pattern :start))))
(aref (plist-get pat :start)
(length (plist-get pattern :start)))))
(or (plist-get pattern :body)
`(seq (not (any space ,@confounding-start-characters))
(*? not-newline)
(not space)))))))
(rx (regexp simple-comment-markup-pre-rx)
(group (literal (plist-get pattern :start)))
(group (regexp body-rx))
(group (literal (plist-get pattern :end)))
(regexp simple-comment-markup-post-rx))
(plist-get pattern :face))))
(defun simple-comment-markup--fontify (&optional limit)
"Apply comment markup up to LIMIT, based on `simple-comment-markup--rx-patterns'."
(let ((syntax-ppss-table (syntax-table))
(markup-start nil)
(markup-end 0)
(multiline nil))
(while (re-search-forward (rx (syntax comment-start)) limit t)
(when (nth 8 (syntax-ppss)) ; Inside comment or string
(unless markup-start
(setq markup-start (point)))
(let ((continue t))
(while continue
(setq markup-end
(max markup-end
(simple-comment-markup--fontify-line limit)))
(if (eobp)
(setq continue nil)
(forward-line 1)
(setq continue (nth 8 (syntax-ppss)))
(when (and continue (not multiline))
(setq multiline
(rx point (syntax comment-start)) nil t))))))))))
(when multiline
(put-text-property markup-start markup-end 'font-lock-multiline t))
(set-match-data (and markup-start (list markup-start markup-end)))))
(defun simple-comment-markup--fontify-line (&optional limit)
"Apply comment markup up to LIMIT or the end of the current line."
(let ((start (point))
(max-end 0)
(line-limit (min (or limit (point-max)) (line-end-position)))
(dolist (pattern simple-comment-markup--rx-patterns)
(goto-char start)
(setq continue t)
(while continue
(setq continue nil)
(when (re-search-forward (car pattern) line-limit t)
(setq continue (nth 8 (syntax-ppss)))
(when continue
(match-beginning 1) (match-end 1) 'simple-comment-markup-face)
(match-beginning 2) (match-end 2) (cdr pattern))
(match-beginning 3) (match-end 3) 'simple-comment-markup-face)
(setq max-end (max max-end (match-end 0)))))))
(defvar simple-comment-markup--font-lock-keywords
(define-minor-mode simple-comment-markup-mode
"Simple markup fontification in comments."
:global nil
:group 'simple-comment-markup
(setq simple-comment-markup--rx-patterns
(font-lock-add-keywords nil simple-comment-markup--font-lock-keywords 'append))
(t (font-lock-remove-keywords nil simple-comment-markup--font-lock-keywords)))
(provide 'simple-comment-markup)
;;; simple-comment-markup.el ends here