;;; 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: https://code.tecosaur.net/tec/simple-comment-markup ;; 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 '((org (: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)) (markdown (: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)) (markdown-code (:start "`" :end "`" :face font-lock-doc-markup-face)) (asciiquote-code (:start "`" :end "'" :face font-lock-doc-markup-face)) (url (:start "<" :body "https?:[^>\n]*[^ >\n]" :end ">" :face link)) (latex (:start "\\(" :end "\\)" :face font-lock-string-face)) (tex (:start "$" :end "$" :face font-lock-string-face))) "Named sets of simple markup constructs." :type '(alist :key-type (symbol :tag "Name") :value-type (plist :key-type (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))) (sort (copy-sequence (apply #'append (mapcar (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))) (mapcar (lambda (pattern) (let* ((confounding-start-characters (delq nil (mapcar (lambda (pat) (and (> (length (plist-get pat :start)) (length (plist-get pattern :start))) (string= (plist-get pattern :start) (substring (plist-get pat :start) 0 (length (plist-get pattern :start)))) (aref (plist-get pat :start) (length (plist-get pattern :start))))) patterns))) (body-rx (or (plist-get pattern :body) (rx-to-string `(seq (not (any space ,@confounding-start-characters)) (optional (*? not-newline) (not space))))))) (cons (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)))) patterns))) (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 (save-excursion (not (re-search-forward (rx point (syntax comment-start)) nil t)))))))))) (when (and multiline (< markup-start markup-end)) (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))) continue) (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 (add-face-text-property (match-beginning 1) (match-end 1) 'simple-comment-markup-face) (add-face-text-property (match-beginning 2) (match-end 2) (cdr pattern)) (add-face-text-property (match-beginning 3) (match-end 3) 'simple-comment-markup-face) (setq max-end (max max-end (match-end 0))))))) max-end)) (defvar simple-comment-markup--font-lock-keywords '((simple-comment-markup--fontify))) ;;;###autoload (define-minor-mode simple-comment-markup-mode "Simple markup fontification in comments." :global nil :group 'simple-comment-markup (cond (simple-comment-markup-mode (setq simple-comment-markup--rx-patterns (simple-comment-markup--construct-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))) (save-restriction (widen) (font-lock-flush))) (provide 'simple-comment-markup) ;;; simple-comment-markup.el ends here