path: root/.config/emacs/site-lisp/emmet.el

;;; tree-exp-mode.el --- Minor mode for expanding tree-like syntax  -*- lexical-binding: t; -*-

(eval-when-compile
  (require 'cl-macs)
  (require 'tempo))

(defgroup tree-exp nil
  "Customization group for `emmet-mode'."
  :group 'convenience)

(defcustom tree-exp-html-self-closing-style ""
  "Self-closing tag style for HTML.
This setting specifies how `tree-exp' should generate self-closing tags
when expanding to HTML.  When generating a self-closing tag the value of
`tree-exp-html-self-closing-style' is inserted verbatim between the end
of the element attributes and the closing angle-bracket.

Note that the variable of this setting has no bearing on the validity of
the generated HTML; infact the HTML standard instructs parsers to ignore
a trailing slash."
  :type '(choice (const :tag "")
                 (const :tag "/")
                 (const :tag " /"))
  :package-version '(tree-exp . "1.0.0")
  :group 'tree-exp)

(defcustom tree-exp-set-marks t
  "TODO"
  :type 'boolean
  :package-version '(tree-exp . "1.0.0")
  :group 'tree-exp)

(defvar-keymap tree-exp-mode-map
  :doc "TODO")

(defvar tree-exp-expand-functions
  '(((html-mode mhtml-mode html-ts-mode) . tree-exp-expand-html)
    (gsp-ts-mode . tree-exp-expand-gsp))
  "TODO")

(defvar tree-exp-operator-alist-alist
  '(((html-mode mhtml-mode html-ts-mode gsp-ts-mode)
     . ((?+ . sibling)
        (?^ . parent)
        (?> . child)
        (?. . extra)
        (?# . extra)
        (?@ . extra)
        (?* . repeat))))
  "TODO")

(defvar tree-exp-after-expansion-hook nil
  "TODO")

^L
;; Private Variables

(defvar-local tree-exp--mark-index 0)

(defconst tree-exp--html-void-elements
  #s(hash-table size 13
                test equal
                purecopy t
                data ("area"   t
                      "base"   t
                      "br"     t
                      "col"    t
                      "embed"  t
                      "hr"     t
                      "img"    t
                      "input"  t
                      "link"   t
                      "meta"   t
                      "source" t
                      "track"  t
                      "wbr"    t)))

^L
;; Parsing

(defun tree-exp--pattern-start ()
  (max (save-excursion
         (skip-syntax-backward "^ ")
         (point))
       (pos-bol)))

(defun tree-exp--pattern-bounds ()
  (if (use-region-p)
      (progn
        (when (region-noncontiguous-p)
          (error "Noncontiguous regions are not supported yet."))
        (car (region-bounds)))
    (cons (tree-exp--pattern-start) (point))))

(defun tree-exp--symbol-end (operator-alist)
  (while (and (memq (car (syntax-after (point))) '(2 3))
              (not (assq (char-after (point)) operator-alist)))
    (goto-char (1+ (point))))
  (point))

(defun tree-exp--set-children-of-leaves (tree values)
  (dolist (node tree)
    (if-let ((children (nth 2 node)))
        (tree-exp--set-children-of-leaves children values)
      (setf (nth 2 node) values)))
  tree)

(defun tree-exp--append-extra-to-leaves (tree value)
  (dolist (node tree)
    (if-let ((children (nth 2 node)))
        (tree-exp--append-extra-to-leaves children value)
      (setf
       (nth 1 node)
       (append (nth 1 node) (cons value nil)))))
  tree)

(defun tree-exp--parse-count ()
  (let* ((start (point))
         (end (+ start (skip-chars-forward "0-9")))
         (num (string-to-number
               (buffer-substring-no-properties start end)
               10)))
    (unless (zerop num)
      num)))

(defun tree-exp--parse-atom (operator-alist)
  (let ((start (point))
        (end (tree-exp--symbol-end operator-alist)))
    (if (= start end)
        (when (= ?\( (char-after end))
          (goto-char (1+ end))
          (let ((tree (tree-exp--parse-expr operator-alist))
                (char (char-after (point))))
            (if (eq ?\) char)
                (progn
                  (goto-char (1+ (point)))
                  tree)
              (message (if char
                           (format "Invalid operator `%c'" char)
                         "Missing closing parenthesis"))
              nil)))
      (list (list (buffer-substring-no-properties start end) nil nil)))))

(defun tree-exp--parse-term (operator-alist)
  (let ((terms (tree-exp--parse-atom operator-alist)))
    (catch 'loop
      (while t
        (let* ((operator (assq (char-after (point)) operator-alist))
               (op-char (car-safe operator))
               (op-type (cdr-safe operator))
               start end)
          (unless (eq op-type 'extra)
            (throw 'loop terms))
          (setq
           start (goto-char (1+ (point)))
           end (tree-exp--symbol-end operator-alist))
          (when (= start end)
            (message "Operator `%c' missing right-hand side" op-char)
            (throw 'loop nil))
          (tree-exp--append-extra-to-leaves
           terms (cons op-char (buffer-substring-no-properties start end))))))))

;; Gross hack
(defun tree-exp--parse-expr-with-lhs (operator-alist lhs)
  (let* ((op-char (char-after (point)))
         (op-type (alist-get op-char operator-alist))
         rhs)
    (cond
     ((not lhs)
      nil)
     ((or (not op-char)
          (not op-type))
      lhs)
     (t
      (goto-char (1+ (point)))
      (setq rhs (if (eq op-type 'repeat)
                    (tree-exp--parse-count)
                  (tree-exp--parse-expr operator-alist)))
      (when rhs
        (pcase op-type
          ('child  (tree-exp--set-children-of-leaves lhs rhs))
          ('parent (tree-exp--set-children-of-leaves rhs lhs))
          ('sibling (append lhs rhs))
          ('repeat (tree-exp--parse-expr-with-lhs
                    operator-alist
                    ;; FIXME: We need to call ‘copy-tree’ or else the
                    ;; generated AST has cycles in it… why is that?  How
                    ;; can we fix it?
                    (cl-loop for _ from 1 to rhs append (copy-tree lhs))))))))))

(defun tree-exp--parse-expr (operator-alist)
  (tree-exp--parse-expr-with-lhs
   operator-alist
   (tree-exp--parse-term operator-alist)))

(defun tree-exp--build-ast (bounds)
  (save-excursion
    (with-restriction (car bounds) (cdr bounds)
      (goto-char 1)
      (when-let* ((operator-alist (tree-exp--alist-get
                                   major-mode tree-exp-operator-alist-alist))
                  (tree (tree-exp--parse-expr operator-alist)))
        (if (= (point) (point-max))
            tree
          (message "Superfluous character `%c'" (char-after (point)))
          nil)))))

^L
;; Expansion

(defun tree-exp--alist-get (key alist)
  (cdr (or (assq key alist)
           (catch 'tree-exp--break
             (dolist (pair alist)
               (when (and (listp (car pair))
                          (memq key (car pair)))
                 (throw 'tree-exp--break pair)))))))

(defun tree-exp--ast-siblings-p (ast)
  (cond ((not ast) nil)
        ((length> ast 1) t)
        (t (tree-exp--ast-siblings-p (caddar ast)))))

(defun tree-exp-expand-html--format-attr (attr)
  (declare ((pure t) (side-effect-free t)))
  (let* ((parts (string-split attr "="))
         (name        (car parts))
         (value-parts (cdr parts)))
    (if value-parts
        (format "%s=\"%s\"" name (string-join value-parts "="))
      name)))

(defun tree-exp-expand-html--helper (ast indentp)
  (dolist (node ast)
    (let* ((name     (nth 0 node))
           (attrs    (nth 1 node))
           (children (nth 2 node))
           (classes (cl-loop for (op . attr) in attrs
                             if (= ?. op)
                             collect attr)))
      (insert (format "<%s" name))
      (when classes
        (insert (format " class=\"%s\"" (string-join classes " "))))
      (cl-loop for (op . attr) in attrs
               if (= ?# op)
                 do (insert (format " id=\"%s\"" attr))
               else if (= ?@ op)
                 do (thread-last
                      attr
                      (tree-exp-expand-html--format-attr)
                      (concat " ")
                      (insert)))
      (if (and (not children)
               (gethash name tree-exp--html-void-elements))
          (insert (format "%s>" tree-exp-html-self-closing-style))
        (insert ?>)
        (if children
            (progn
              (when indentp
                (insert ?\n))
              (tree-exp-expand-html--helper children indentp))
          (when tree-exp-set-marks
            (insert #x1B)))
        (insert (format "</%s>" name))))
    (when indentp
      (insert ?\n))))

(defun tree-exp-expand-html (ast)
  "TODO"
  (tree-exp-expand-html--helper ast (tree-exp--ast-siblings-p ast))
  (when (= ?\n (char-before (point-max)))
    (delete-region (1- (point-max)) (point-max)))
  (when tree-exp-set-marks
    (insert #x1B)))

;; (defun tree-exp-expand-gsp--helper (ast indentp)
;;   (dolist (node ast)
;;     (let ((name     (nth 0 node))
;;           (attrs    (nth 1 node))
;;           (children (nth 2 node)))


;;       ;; (insert (format "<%s" name))
;;       ;; (dolist (attr attrs)
;;       ;;   (insert (format " %s" (cdr attr))))
;;       ;; (if (and (not children)
;;       ;;          (gethash name tree-exp--html-void-elements))
;;       ;;     (insert (format "%s>" tree-exp-html-self-closing-style))
;;       ;;   (insert ?>)
;;       ;;     (if children
;;       ;;         (progn
;;       ;;           (when indentp
;;       ;;             (insert ?\n))
;;       ;;           (tree-exp-expand-html--helper children indentp))
;;       ;;       (when tree-exp-set-marks
;;       ;;         (insert #x1B)))
;;       ;;     (insert (format "</%s>" name)))
;;       )
;;     (when indentp
;;       (insert ?\n))))

(defun tree-exp-expand-gsp (ast)
  "TODO"
  (tree-exp-expand-gsp--helper ast (tree-exp--ast-siblings-p ast))
  (when (= ?\n (char-before (point-max)))
    (delete-region (1- (point-max)) (point-max)))
  (when tree-exp-set-marks
    (insert #x1B)))

;;;###autoload
(defun tree-exp-expand ()
  "TODO"
  (interactive)
  (when-let* ((current-buffer (current-buffer))
              (bounds (tree-exp--pattern-bounds))
              (ast (tree-exp--build-ast bounds))
              (expander (tree-exp--alist-get
                         major-mode tree-exp-expand-functions)))
    (delete-region (car bounds) (cdr bounds))
    (with-temp-buffer
      (funcall expander ast)
      (insert-into-buffer current-buffer))
    (let ((start-pos (car bounds))
          (end-pos (point-marker))
          (delete-active-region nil)    ; For ‘delete-backward-char’
          marks)
      (when tree-exp-set-marks
        (save-excursion
          (goto-char start-pos)
          (while (search-forward "\x1B" end-pos :noerror)
            (delete-backward-char 1)
            (push (point-marker) marks)))
        (push (point-marker) marks)
        (setq marks (nreverse marks))
        (goto-char (car marks))
        (mapc #'tempo-insert-mark marks))
      ;; Set the start of the region to the start bound
      (unless (region-active-p)
        (set-mark start-pos))
      (indent-region start-pos end-pos)
      (run-hooks tree-exp-after-expansion-hook))))

;;;###autoload
(define-minor-mode tree-exp-mode
  "TODO"
  :lighter " Tree-Expand"
  :keymap tree-exp-mode-map)

(provide 'tree-exp)