;;; simple-comment-markup.el --- Simple markup fontification in comments -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2022 TEC
;;
;; Author: TEC <https://git.tecosaur.net/tec>
;; Maintainer: TEC <contact@tecosaur.net>
;; Created: August 11, 2022
;; Modified: August 11, 2022
;; Version: 0.0.1
;; Keywords: faces
;; Homepage: https://git.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))
    (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)
  "docstring"
  :type '(choice symbol (repeat symbol)))

(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)

(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)

(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))))))

(defun simple-comment-markup--construct-font-lock (&optional set)
  "Return a font-lock construct for markup patterns from SET."
  (let ((patterns (simple-comment-markup--get-patterns set)))
    (list
     (apply #'append
            (list (rx line-start (* blank) (literal comment-start)))
            (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)))))))
                 `((,(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))
                    (beginning-of-line)
                    nil
                    (1 'simple-comment-markup-face t)
                    (2 '(face ,(plist-get pattern :face)) prepend)
                    (3 'simple-comment-markup-face t)))))
             patterns)))))

(defvar-local simple-comment-markup--font-lock-keywords nil)

;;;###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--font-lock-keywords
          (simple-comment-markup--construct-font-lock))
    (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