Adjust indentation at work.
-requires
-
-#+begin_src sh :eval never
- port install tree-sitter-yaml
-#+end_src
-
#+BEGIN_SRC emacs-lisp
;; load yaml-mode
(require 'yaml-mode)
(add-hook 'yaml-mode-hook
(lambda()
(auto-fill-mode -1)
- (yaml-pro-ts-mode 1)
- (eldoc-mode 1)
;; (stripes-mode 1)
(setq bba-keep-whitespaces 1)))
+++ /dev/null
-;;; yaml-pro-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
-;; Generated by the `loaddefs-generate' function.
-
-;; This file is part of GNU Emacs.
-
-;;; Code:
-
-(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
-
-
-\f
-;;; Generated autoloads from yaml-pro.el
-
-(autoload 'yaml-pro-ts-mode "yaml-pro" "\
-Minor mode to enable yaml-pro treesitter keymap.
-
-\\{yaml-pro-mode-map}
-
-This is a minor mode. If called interactively, toggle the `Yaml-Pro-Ts
-mode' mode. If the prefix argument is positive, enable the mode, and if
-it is zero or negative, disable the mode.
-
-If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
-mode if ARG is nil, omitted, or is a positive number. Disable the mode
-if ARG is a negative number.
-
-To check whether the minor mode is enabled in the current buffer,
-evaluate the variable `yaml-pro-ts-mode'.
-
-The mode's hook is called both when the mode is enabled and when it is
-disabled.
-
-(fn &optional ARG)" t)
-(autoload 'yaml-pro-mode "yaml-pro" "\
-Binds additional functions to aid in editing YAML files.
-
-\\{yaml-pro-mode-map}
-
-This is a minor mode. If called interactively, toggle the `Yaml-Pro
-mode' mode. If the prefix argument is positive, enable the mode, and if
-it is zero or negative, disable the mode.
-
-If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
-mode if ARG is nil, omitted, or is a positive number. Disable the mode
-if ARG is a negative number.
-
-To check whether the minor mode is enabled in the current buffer,
-evaluate the variable `yaml-pro-mode'.
-
-The mode's hook is called both when the mode is enabled and when it is
-disabled.
-
-(fn &optional ARG)" t)
-(register-definition-prefixes "yaml-pro" '("yaml-pro-"))
-
-\f
-;;; Generated autoloads from yaml-pro-edit.el
-
-(autoload 'yaml-pro-edit-scalar "yaml-pro-edit" "\
-Edit the scalar value at the point in a separate buffer.
-If prefix argument P is provided, prompt user for initialization command.
-
-(fn P)" t)
-(register-definition-prefixes "yaml-pro-edit" '("yaml-pro-edit-"))
-
-\f
-;;; Generated autoloads from yaml-pro-format.el
-
-(register-definition-prefixes "yaml-pro-format" '("yaml-pro-format"))
-\f
-;;; End of scraped data
-
-(provide 'yaml-pro-autoloads)
-
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; no-native-compile: t
-;; coding: utf-8-emacs-unix
-;; End:
-
-;;; yaml-pro-autoloads.el ends here
+++ /dev/null
-;;; yaml-pro-edit.el --- Functions for editing functionality -*- lexical-binding: t -*-
-
-;; Author: Zachary Romero
-;; Maintainer: Zachary Romero
-;; Homepage: https://github.com/zkry/yaml-pro
-;; Keywords: tools
-
-;; This file is not part of GNU Emacs
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; M-x yaml-pro-edit-ts-scalar
-
-;;; Code:
-
-(require 'treesit nil t)
-(require 'yaml)
-
-(defconst yaml-pro-edit-mode-map
- (let ((map (make-sparse-keymap)))
- (prog1 map
- ;;(suppress-keymap map)
- (define-key map (kbd "C-c C-k") #'yaml-pro-edit-quit)
- (define-key map (kbd "C-c C-c") #'yaml-pro-edit-complete)
- (define-key map (kbd "C-c C-s") #'yaml-pro-edit-change-output)))
- "Keymap of yaml-edit-mode.")
-
-(defconst yaml-pro-edit-buffer-name "*yaml-pro-edit*")
-(defvar-local yaml-pro-edit-ts-node-position nil)
-(put 'yaml-pro-edit-ts-node-position 'permanent-local t)
-(defvar-local yaml-pro-edit-scalar nil
- "The current scalar being edited on.
-Used to fetch location properties on completion.")
-(put 'yaml-pro-edit-scalar 'permanent-local t)
-(defvar-local yaml-pro-edit-scalar-overlay nil
- "Overlay to go on top of the text currently being edited.")
-(put 'yaml-pro-edit-scalar-overlay 'permanent-local t)
-(defvar-local yaml-pro-edit-parent-buffer nil
- "Reference to the buffer where the edited YAML originated.")
-(put 'yaml-pro-edit-parent-buffer 'permanent-local t)
-(defvar-local yaml-pro-edit-output-type nil
- "When completing an edit buffer, output scalar according to this.")
-(put 'yaml-pro-edit-output-type 'permanent-local t)
-(defvar-local yaml-pro-edit-initialization-cache nil
- "Hashmap of YAML path to initialization function.")
-(put 'yaml-pro-edit-initialization-cache 'permanent-local t)
-
-
-(define-minor-mode yaml-pro-edit-mode
- "Minor-mode for editing a YAML scalar in a separate buffer."
- :lighter " YAML-pro"
- :keymap yaml-pro-edit-mode-map
- (add-hook 'change-major-mode-hook
- (lambda ()
- (let ((buf (current-buffer)))
- ;; Setting the header-line-format in the
- ;; change-major-mode-hook doesn't work. Probably some
- ;; major mode thing is done after the hook call. This
- ;; timer hack makes sure the header-line-format is set
- ;; properly.
- (run-with-timer
- 0.01 nil
- (lambda ()
- (with-current-buffer buf
- (setq header-line-format (yaml-pro-edit--header-line)))))))
- nil t))
-(put 'yaml-pro-edit-mode 'permanent-local t)
-
-(defun yaml-pro-edit-cleanup-parent ()
- "Remove overlay and properties of edited text."
- (with-current-buffer (or yaml-pro-edit-parent-buffer (current-buffer))
- (when yaml-pro-edit-scalar-overlay
- (delete-overlay yaml-pro-edit-scalar-overlay)
- (setq yaml-pro-edit-scalar-overlay nil))))
-
-(defun yaml-pro-edit--infer-scalar-indent (scalar-block-string)
- "Infer the scalar indentation SCALAR-BLOCK-STRING."
- (with-temp-buffer
- (insert scalar-block-string)
- (goto-char (point-min))
- (save-excursion
- (let ((min-indent 10000))
- (while (not (eobp))
- (when (not (looking-at " *\n"))
- (let ((ct 0))
- (while (looking-at-p " ")
- (forward-char 1)
- (cl-incf ct))
- (when (< ct min-indent)
- (setq min-indent ct))))
- (forward-line 1))
- min-indent))))
-
-(defun yaml-pro-edit--infer-indent (&optional pos)
- "Infer the YAML indentation of POS or the current point."
- (save-excursion
- (let ((pos (or pos (point))))
- (goto-char pos)
- (when (and (eobp) ;; fix edge where end of scalar at eop has end after newline
- (eql (char-before (point)) ?\n))
- (forward-line -1))
- (forward-line 0)
- (skip-chars-forward "- \n")
- (current-column))))
-
-(defconst yaml-pro-edit-output-types
- '(("|" . literal)
- ("|-" . literal-strip)
- ("|+" . literal-keep)
- (">" . folded)
- (">-" . folded-strip)
- (">+" . folded-keep)
- ("'" . single)
- ("\"" . double))
- "Alist of selection item to type key.")
-
-(defun yaml-pro-edit--block-style-annotation (v)
- "Return the completion annotation of the selection string V."
- (let ((annotations
- '(("|" . "keep newlines, single newline at end")
- ("|-" . "keep newlines, strip newlines at end")
- ("|+" . "keep newlines, keep newlines at end")
- (">" . "fold newlines to space, single newline at end")
- (">-" . "fold newlines to space, strip newlines at end")
- (">+" . "fold newlines to space, keep newlines at end")
- ("'" . "nothing escaped")
- ("\"" . "newlines escaped"))))
- (concat " " (cdr (assoc v annotations)))))
-
-(defun yaml-pro-edit--block-output (type)
- "Return the block prefix of TYPE if one exists."
- (when (not (memq type '(single double)))
- (car (rassoc type yaml-pro-edit-output-types))))
-
-(defun yaml-pro-edit-apply-indentation (content indent &optional type)
- "Apply an indentation level of INDENT to the string CONTENT and return."
- (with-temp-buffer
- (insert content)
- (goto-char (point-min))
- (let ((indent-str (make-string indent ?\s)))
- (when (eql type 'single)
- (forward-line 1))
- (while (not (eobp))
- (when (not (looking-at-p "^ *\n"))
- (insert indent-str))
- (forward-line 1)))
- (buffer-string)))
-
-(defun yaml-pro-edit--header-line ()
- "Return the string to display in the header line."
- (let* ((base-text (substitute-command-keys "Edit, then exit with \
-`\\[yaml-pro-edit-complete]' or abort with `\\[yaml-pro-edit-quit]'.")))
- (if yaml-pro-edit-output-type
- (let* ((type-str
- (or (yaml-pro-edit--block-output yaml-pro-edit-output-type)
- (and (eql yaml-pro-edit-output-type 'double) "\"\"")
- (and (eql yaml-pro-edit-output-type 'single) "''")))
- (type-str-prp (propertize type-str 'face 'font-lock-string-face)))
- (concat base-text
- "Outputting "
- type-str-prp
- (substitute-command-keys
- ", `\\[yaml-pro-edit-change-output]' to change out type")))
- (concat base-text
- (substitute-command-keys
- "Change output with `\\[yaml-pro-edit-change-output]'")))))
-
-(defun yaml-pro-edit-initialize-buffer
- (parent-buffer buffer initial-text type initialize path)
- "Initialize the YAML edit buffer.
-
-PARENT-BUFFER is the buffer from which the YAML was copied.
-BUFFER is the editing buffer. The buffer is initialized with the
-text INITIAL-TEXT.
-
-TYPE indicates the type of scalar that the block was copied
-from (ex literal or folded).
-
-INITIALIZE, if non-nil, will run before the buffer is
-initialized. The INITIALIZE function will be cached under PATH,
-resulting in the function being ran upon subsequent edits."
- (when (not yaml-pro-edit-initialization-cache)
- (setq-local yaml-pro-edit-initialization-cache
- (make-hash-table :test 'equal)))
- (let* ((init-cache yaml-pro-edit-initialization-cache)
- (init-fn (or initialize (and path (gethash path init-cache)))))
- (with-current-buffer buffer
- (when (functionp init-fn)
- (condition-case e
- (progn
- (funcall init-fn)
- (when (and initialize path)
- (puthash path initialize init-cache)))
- (error (message "Initialization failed with: %S"
- (error-message-string e)))))
- (unless yaml-pro-edit-mode
- (yaml-pro-edit-mode))
- (erase-buffer)
- (setq-local require-final-newline nil)
- (setq-local yaml-pro-edit-parent-buffer parent-buffer)
- (setq-local yaml-pro-edit-output-type nil)
- (when type (setq-local yaml-pro-edit-output-type type))
- (setq header-line-format (yaml-pro-edit--header-line))
- (insert initial-text))))
-
-(defun yaml-pro-edit--extract-scalar-text (scalar-block-string yaml-indentation)
- "Strip SCALAR-BLOCK-STRING of indentation with a basis of YAML-INDENTATION."
- ;; TODO: consider consolidating this logic with that of yaml.el
- (save-match-data
- (let ((indent-ct-num
- (progn (string-match "\\`[^\n]*\\([0-9]+\\) *\n" scalar-block-string)
- (let ((num-str (match-string 1 scalar-block-string)))
- (and num-str (+ (string-to-number num-str)
- yaml-indentation))))))
- (setq scalar-block-string (string-trim-left scalar-block-string ".*\n"))
- (with-temp-buffer
- (insert scalar-block-string)
- (goto-char (point-min))
- (let* ((indentation
- (or indent-ct-num
- (yaml-pro-edit--infer-scalar-indent scalar-block-string)))
- (indentation-regexp
- (regexp-quote (make-string indentation ?\s))))
- (while (not (eobp))
- (when (looking-at-p indentation-regexp)
- (delete-char indentation))
- (forward-line 1)))
- (buffer-string)))))
-
-;; Interactive Functions
-
-(defun yaml-pro-edit-change-output ()
- "Change the selected output type after completing the YAML."
- (interactive)
- (unless yaml-pro-edit-mode
- (user-error "not in yaml-pro edit buffer"))
- (let* ((completion-extra-properties
- '(:annotation-function yaml-pro-edit--block-style-annotation))
- (output-type (completing-read "Output: " yaml-pro-edit-output-types))
- (key (cdr (assoc output-type yaml-pro-edit-output-types 'equal))))
- (setq yaml-pro-edit-output-type key)
- (setq header-line-format (yaml-pro-edit--header-line))))
-
-(defun yaml-pro-edit-quit ()
- "Quit the edit buffer."
- (interactive)
- (unless yaml-pro-edit-mode
- (user-error "not in yaml-pro edit buffer"))
- (yaml-pro-edit-cleanup-parent)
- (let ((b (current-buffer)))
- (quit-window)
- (kill-buffer b)))
-
-(defun yaml-pro-edit-complete ()
- "Deleting edit buffer and move its contents to the original YAML buffer."
- (interactive)
- (unless yaml-pro-edit-mode
- (user-error "not in yaml-pro edit buffer"))
- (unless yaml-pro-edit-parent-buffer
- (error "Buffer not connected with yaml buffer"))
- ;; first ensure that buffer ends with at least one newline
- (let* ((edit-buf (current-buffer))
- (edit-str (buffer-substring-no-properties (point-min) (point-max)))
- (type yaml-pro-edit-output-type))
- (when (not (memq type '(single double)))
- (save-excursion
- (goto-char (point-max))
- (unless (looking-back "\n" (- (point) 2))
- (insert "\n")
- (setq edit-str (buffer-substring-no-properties (point-min) (point-max))))))
- (save-excursion
- (with-current-buffer yaml-pro-edit-parent-buffer
- (let* ((pos (or (and yaml-pro-ts-mode yaml-pro-edit-ts-node-position)
- (get-text-property 0 'yaml-position yaml-pro-edit-scalar)))
- (start (car pos))
- (end (cdr pos))
- (indent (yaml-pro-edit--infer-indent start))
- (scalar-indent (yaml-pro-edit--infer-scalar-indent edit-str))
- (indented-edit-str
- (yaml-pro-edit-apply-indentation edit-str (+ indent 2) type))
- (block-header (or (yaml-pro-edit--block-output type)
- (and (not type)
- (> (length (split-string edit-str "\n")) 1)
- ">-")))
- (extract-string (buffer-substring-no-properties start end))
- (end-newline-p (= (aref extract-string
- (1- (length extract-string)))
- ?\n)))
- (yaml-pro-edit-cleanup-parent)
- (delete-region start end)
- (goto-char start)
- (cond (block-header
- (if (> scalar-indent 0)
- (insert block-header "2\n")
- (insert block-header "\n"))
- (insert indented-edit-str))
- ((or (eql type 'double)
- (and (not type)
- (and (= (length (split-string edit-str "\n")) 1)
- (string-prefix-p " " edit-str))))
- (insert "\"" (replace-regexp-in-string "\"" "\\\\\""
- (replace-regexp-in-string "\n" "\\\\n" edit-str))
- "\""))
- ((eql type 'single)
- (insert "'" (string-trim-right (replace-regexp-in-string
- "'" "''"
- indented-edit-str))
- "'"))
- (t
- (insert edit-str)))
- ;; following blocks are tricky
- ;; if the text being extracted is a block, then it ends in a newline
- ;; meaning the resulting code should return a newline
- ;; if the text being extracted is quoted, we need to make sure that
- ;; the block doesn't add too many lines than needed.
- (when (and (not (memq type '(double single)))
- (not end-newline-p))
- (delete-char 1))
- (when (and (memq type '(double single))
- end-newline-p)
- (insert "\n")))))
- (quit-window)
- (kill-buffer edit-buf)))
-
-(declare-function yaml-pro--value-at-point "yaml-pro")
-(declare-function yaml-pro--fast-value-at-point "yaml-pro")
-(declare-function yaml-pro--path-at-point "yaml-pro")
-(declare-function yaml-pro--use-fast-p "yaml-pro")
-
-(defun yaml-pro-edit-ts-scalar-node-at (point)
- "Return the node at POINT corresponding with editable scalar."
- (let* ((at-node (treesit-node-at point 'yaml)))
- (cond
- ((member (treesit-node-type at-node) '("block_scalar" "string_scalar"))
- at-node)
- ((member (treesit-node-type at-node) '("'" "\"" "escape_sequence"))
- (treesit-node-parent at-node)))))
-
-(defun yaml-pro-edit-ts-strip-quotes (text)
- "Strip the first and last quote character in TEXT."
- (let ((is-single-quote (eql (aref text 0) ?'))
- (base-string (substring text 1 (1- (length text)))))
- (if is-single-quote
- (replace-regexp-in-string " *\n+ *" " " base-string)
- base-string)))
-
-(defun yaml-pro-edit-ts-scalar (p)
- "Edit the scalar value at the point in a separate buffer.
-This command utilizes tree-sitter to detirmine syntax
-locations. If prefix argument P is provided, prompt user for
-initialization command."
- (interactive "p")
- (let* ((init-func)
- (parent-buffer (current-buffer))
- (at-node (yaml-pro-edit-ts-scalar-node-at (point)))
- (start (treesit-node-start at-node))
- (end (treesit-node-end at-node))
- (node-text (treesit-node-text at-node)))
- (when (= 4 p)
- (setq init-func (read-command "Initialization command: ")))
- (unless at-node
- (error "No scalar found at point"))
- (setq yaml-pro-edit-ts-node-position (cons start end))
- (save-excursion
- (goto-char (treesit-node-start at-node))
- (let* ((yaml-indentation (yaml-pro-edit--infer-indent end))
- (folded-block-p (looking-at-p ">"))
- (literal-block-p (looking-at-p "|"))
- (strip-p (looking-at-p ".-[0-9]+\n"))
- (keep-p (looking-at-p ".+[0-9]+\n"))
- (double-quote-string-p (equal "double_quote_scalar" (treesit-node-type at-node)))
- (single-quote-string-p (equal "single_quote_scalar" (treesit-node-type at-node)))
- (type (cond ((and folded-block-p strip-p) 'folded-strip)
- ((and literal-block-p strip-p) 'literal-strip)
- ((and folded-block-p keep-p) 'folded-keep)
- ((and literal-block-p keep-p) 'literal-keep)
- (folded-block-p 'folded)
- (literal-block-p 'literal)
- (single-quote-string-p 'single)
- (double-quote-string-p 'double))))
- (when yaml-pro-edit-scalar-overlay
- (delete-overlay yaml-pro-edit-scalar-overlay))
- (let ((ov (make-overlay start end))
- (read-only
- (list
- (lambda (&rest _) (user-error "Can't modify a scalar being edited in a dedicated buffer")))))
- (overlay-put ov 'modification-hooks read-only)
- (overlay-put ov 'insert-in-front-hooks read-only)
- (overlay-put ov 'insert-behind-hooks read-only)
- (overlay-put ov 'face 'secondary-selection)
- (setq yaml-pro-edit-scalar-overlay ov))
- (let ((b (get-buffer-create yaml-pro-edit-buffer-name)))
- (if (or folded-block-p literal-block-p)
- (yaml-pro-edit-initialize-buffer
- parent-buffer b (yaml-pro-edit--extract-scalar-text node-text yaml-indentation) type init-func nil)
- (yaml-pro-edit-initialize-buffer
- parent-buffer b (yaml-parse-string node-text) type init-func nil))
- (let ((window (display-buffer b)))
- (when window
- (select-window window))))))))
-
-;;;###autoload
-(defun yaml-pro-edit-scalar (p)
- "Edit the scalar value at the point in a separate buffer.
-If prefix argument P is provided, prompt user for initialization command."
- (interactive "p")
- (let* ((init-func)
- (fast-p (yaml-pro--use-fast-p))
- (at-scalar (if fast-p (yaml-pro--fast-value-at-point)
- (yaml-pro--value-at-point)))
- (path (and (not fast-p) (yaml-pro--path-at-point)))
- (parent-buffer (current-buffer)))
- (unless at-scalar
- (user-error "No value found at point"))
- (when (= 4 p)
- (setq init-func (read-command "Initialization command: ")))
- (setq yaml-pro-edit-scalar at-scalar)
- (let* ((bounds (or (get-text-property 0 'yaml-position at-scalar)
- (get-text-property 0 'yaml-position (string-trim at-scalar "[ \n]*"))))
- (start (car bounds))
- (end (cdr bounds))
- (yaml-indentation (yaml-pro-edit--infer-indent start))
- (scalar-text (buffer-substring start end))
- (raw-scalar (yaml-pro-edit--extract-scalar-text
- scalar-text yaml-indentation))
- (folded-block-p
- (string-match-p "\\` *>\\(?:+\\|-\\)?[0-9]*\n" scalar-text))
- (literal-block-p
- (string-match-p "\\` *|\\(?:+\\|-\\)?[0-9]*\n" scalar-text))
- (strip-p
- (string-match-p "\\` *.-[0-9]*\n" scalar-text))
- (keep-p
- (string-match-p "\\` *.\\+[0-9]*\n" scalar-text))
- (double-quote-string-p
- (string-match-p "\\`\".*\"\\'" scalar-text))
- (single-quote-string-p
- (string-match-p "\\`'\\(.\\|\n\\)*'\\'" scalar-text))
- (type (cond ((and folded-block-p strip-p) 'folded-strip)
- ((and literal-block-p strip-p) 'literal-strip)
- ((and folded-block-p keep-p) 'folded-keep)
- ((and literal-block-p keep-p) 'literal-keep)
- (folded-block-p 'folded)
- (literal-block-p 'literal)
- (single-quote-string-p 'single)
- (double-quote-string-p 'double))))
- ;; setup overlay and text properties
- (when yaml-pro-edit-scalar-overlay
- (delete-overlay yaml-pro-edit-scalar-overlay))
- (let ((ov (make-overlay start end))
- (read-only
- (list
- (lambda (&rest _)
- (user-error "Can't modify an scalar being edited in a \
-dedicated buffer")))))
- (overlay-put ov 'modification-hooks read-only)
- (overlay-put ov 'insert-in-front-hooks read-only)
- (overlay-put ov 'insert-behind-hooks read-only)
- (overlay-put ov 'face 'secondary-selection)
- (setq yaml-pro-edit-scalar-overlay ov))
- (let ((b (get-buffer-create yaml-pro-edit-buffer-name)))
- (if (or folded-block-p literal-block-p)
- ;; we need to pass the text in buffer if type is block
- (yaml-pro-edit-initialize-buffer
- parent-buffer b raw-scalar type init-func path)
- ;; otherwise use its scalar value (to not show quotes)
- (yaml-pro-edit-initialize-buffer
- parent-buffer b at-scalar type init-func path))
- (let ((window (display-buffer b)))
- (when window
- (select-window window)))))))
-
-(provide 'yaml-pro-edit)
-
-;;; yaml-pro-edit.el ends here
+++ /dev/null
-;;; yaml-pro-format.el --- Pretty formatting for YAML code -*- lexical-binding: t -*-
-
-;; Author: Zachary Romero
-;; Maintainer: Zachary Romero
-;; Package-Requires: ((emacs "28.1"))
-;; Homepage: https://github.com/zkry/yaml-pro
-;; Keywords: tools
-
-;; This file is not part of GNU Emacs
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; yaml-pro-format-ts is a command which will format the current
-;; buffer to make have uniform styling. The rules the formatter
-;; applies are defined in the `yaml-pro-format-features' variable. By
-;; changing its value you can enable and disable formatting rules.
-;;
-;; The pretty formatter was inspired by the prettier.js YAML formatter
-;; but does have a number of differences, some limited by the
-;; capabilities of Tree Sitter.
-
-;;; Code:
-
-(require 'treesit nil t)
-(require 'cl-lib)
-
-(defvar yaml-pro-indent)
-
-(defcustom yaml-pro-format-print-width 80
- "Width until which to break flow sequences."
- :group 'yaml-pro
- :type 'integer)
-
-(defcustom yaml-pro-format-features
- '(reduce-newlines document-separator-own-line oneline-flow block-formatting
- reduce-spaces bm-fn-next-line clean-doc-end remove-spaces-before-comments
- expand-long-flow single-to-double indent)
- "Features to enable when formatting buffer.
-
-This value should be a list containing any of the following symbols:
-
-- `indent' When present, indent each line by `yaml-pro-indent'.
-
-- `reduce-newlines' When present, remove adjacent newlines so at
- most one one remains. New lines in strings won't be removed.
-
-- `oneline-flow' When present, reduce flow mappings to one line.
-
-- `block-formatting' When present, format the spacing around
- block components' colons and dashes.
-
-- `reduce-spaces' When present, attempt to reduce multiple
- adjacent space characters down to one.
-
-- `bm-fn-next-line' When present, move the value of a key-value pair to the
- next line, indented, if it's width is longer than
- `yaml-pro-format-print-width'.
-
-- `expand-log-flow' When present, flatten flow elements that pass
- column `yaml-pro-format-print-width'.
-
-- `single-to-double' When present, convert single quoted strings
- to double quoted, when it wouldn't change its meaning.
-
-- `remove-spaces-before-comments' When present, remove spaces
- before a comment until it is one space after the preceeding
- content (e.g. \"a: b # space before here\").
-
-- `clean-doc-end' When present, remove unnecessary document-end
- indicators (\"...\").
-
-- `document-separator-own-line' When present, makes sure the
- document separator \"---\" isn't on a line with another element."
- :group 'yaml-pro
- :type '(set (const :tag "Remove adjacent blank lines, leaving at most one"
- reduce-newlines)
- (const :tag "Put document separators (---) are on a line of their own"
- document-separator-own-line)
- (const :tag "Try to reduce flow (JSON-like) elements to one line"
- oneline-flow)
- (const :tag "Format spacing around block elments' colon and dashes"
- block-formatting)
- (const :tag "Reduce spacing down to one when appropriate"
- reduce-spaces)
- (const :tag "Transform \"key: value\" to \"key:\\n value\" if column passes `yaml-pro-format-print-width'"
- bm-fn-next-line)
- (const :tag "Remove unnecessary document end indicator (...)"
- clean-doc-end)
- (const :tag "Leave only one space before comments"
- remove-spaces-before-comments)
- (const :tag "Flatten flow nodes if column passes `yaml-pro-format-print-width'"
- expand-long-flow)
- (const :tag "Convert single-quoted strings to double-quoted strings"
- single-to-double)
- (const :tag "Indent according to treesitter level information"
- indent)))
-
-(defun yaml-pro-format-ts--bm-single-space ()
- "Ensure proper spacing around the colon character in a block mapping."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((block_mapping_pair
- key: (flow_node) @key
- ":" @colon
- value: [(flow_node) (block_node)] @val))))
- (del-ovs '()))
- (while nodes
- (save-excursion
- (let* ((colon-node (alist-get 'colon nodes))
- (key-node (alist-get 'key nodes))
- (val-node (alist-get 'val nodes)))
- (setq nodes (cdddr nodes))
- (when (and (not (= (treesit-node-start colon-node)
- (treesit-node-end key-node)))
- ;; we should only be overwriting blank here
- (string-match-p "\\`[ \n]*\\'"
- (buffer-substring-no-properties
- (treesit-node-end key-node)
- (treesit-node-start colon-node)))
- ;; alias names need a space after them
- (not (equal (treesit-node-type
- (treesit-node-at (treesit-node-end key-node) 'yaml))
- "alias_name")))
- (push (make-overlay (treesit-node-end key-node)
- (treesit-node-start colon-node))
- del-ovs))
- (when
- (and (or (string-suffix-p "_scalar" (treesit-node-type val-node))
- (equal (treesit-node-type val-node) "flow_node"))
- (not (= (1+ (treesit-node-end colon-node))
- (treesit-node-start val-node)))
- ;; the region should only replace blank
- (string-match-p
- "\\`[ \n]*\\'"
- (buffer-substring-no-properties
- (treesit-node-end colon-node)
- (treesit-node-start val-node))))
- (let ((ov (make-overlay (treesit-node-end colon-node)
- (treesit-node-start val-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--oneline-flow ()
- "Compress flow elements to one line."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((document
- (flow_node
- [(flow_mapping) (flow_sequence)] @flow))
- (block_mapping_pair
- (flow_node
- [(flow_mapping) (flow_sequence)] @flow))
- (block_sequence_item
- (flow_node
- [(flow_mapping) (flow_sequence)] @flow)))))
- (del-ovs '()))
- (pcase-dolist (`(_ . ,node) nodes)
- ;; don't compress flow with comments
- (unless (treesit-query-capture node '((comment) @comment))
- (save-match-data
- (save-excursion
- (goto-char (treesit-node-start node))
- (while (search-forward "\n" (treesit-node-end node) t)
- (unless (equal (treesit-node-type
- (treesit-node-at (match-beginning 0) 'yaml))
- "comment")
- (let* ((ov (make-overlay (match-beginning 0) (match-end 0))))
- (push ov del-ovs))))))))
- ;; Following code ensures that compressed flow is pretty formatted
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_mapping "," @comma)))))
- (pcase-dolist (`(_ . ,comma-node) nodes)
- (cond
- ((save-excursion (goto-char (treesit-node-end comma-node))
- (looking-at-p " *\n? *}"))
- (let* ((ov (make-overlay (treesit-node-start comma-node)
- (treesit-node-end comma-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs)))
- ((save-excursion (goto-char (treesit-node-start comma-node))
- (looking-back "[^\n] *" (- (point) 80)))
- (let* ((ov (make-overlay (save-excursion
- (goto-char (treesit-node-start comma-node))
- (skip-chars-backward " ")
- (point))
- (treesit-node-start comma-node))))
- (push ov del-ovs))))))
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_mapping "}" @rbrace)))))
- (pcase-dolist (`(_ . ,rbrace-node) nodes)
- (when (save-excursion (goto-char (treesit-node-start rbrace-node))
- (not (looking-back "[ \n{] ?" (- (point) 4))))
- (let* ((ov (make-overlay (treesit-node-start rbrace-node)
- (treesit-node-start rbrace-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs)))))
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_mapping "{" @lbrace)))))
- (pcase-dolist (`(_ . ,lbrace-node) nodes)
- (when (save-excursion (goto-char (treesit-node-end lbrace-node))
- (not (looking-at-p "[ \n}]")))
- (let* ((ov (make-overlay (treesit-node-end lbrace-node)
- (treesit-node-end lbrace-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs)))))
- del-ovs))
-
-
-(defun yaml-pro-format-ts--no-comments-after-tags ()
- "Move comments to a newline if they occur after a tag (e.g. !!set)."
- (let* ((del-ovs '())
- (nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((_ (tag) @tag :anchor (comment) @comment)))))
- (while nodes
- (let* ((tag-node (alist-get 'tag nodes))
- (comment-node (alist-get 'comment nodes)))
- (setq nodes (cddr nodes))
- (when (= (line-number-at-pos (treesit-node-end tag-node))
- (line-number-at-pos (treesit-node-start comment-node)))
- (let* ((ov (make-overlay (treesit-node-end tag-node)
- (treesit-node-start comment-node))))
- (overlay-put ov 'yaml-pro-format-insert "\n")
- (push ov del-ovs)))))
- del-ovs))
-
-(defun yaml-pro-format-ts--flow-seq-grouping-space ()
- "Remove all whitespace before and after flow nodes' [ ] chars."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_mapping) @flow
- (flow_sequence) @flow)))
- (del-ovs '()))
- (pcase-dolist (`(_ . ,node) nodes)
- (let-alist (treesit-query-capture
- node
- '((flow_sequence "[" @open :anchor (_) @after-open-node
- (_) @before-close-node :anchor "]" @close)))
- (when (and .open .close .after-open-node .before-close-node)
- (if (= (line-number-at-pos (treesit-node-end .open))
- (line-number-at-pos (treesit-node-start .close)))
- ;; If [ ] is on one line, remove spacing after [ and before ].
- (let* ((ov-beg (make-overlay (treesit-node-end .open)
- (treesit-node-start .after-open-node)))
- (ov-end (make-overlay (treesit-node-end .before-close-node)
- (treesit-node-start .close))))
- (push ov-beg del-ovs)
- (unless (equal (treesit-node-type .before-close-node) "comment")
- (push ov-end del-ovs)))
- ;; If [ ] is on multiple lines, ensure [ ] are on their own lines.
- (let* ((after-open-indent
- (yaml-pro-format-ts--node-indent .after-open-node))
- (ov-beg (make-overlay (treesit-node-end .open)
- (treesit-node-start .after-open-node)))
- (ov-end (make-overlay (treesit-node-end .before-close-node)
- (treesit-node-start .close))))
- (overlay-put ov-beg 'yaml-pro-format-insert
- (concat "\n" (make-string
- (* after-open-indent yaml-pro-indent)
- ?\s)))
- (overlay-put ov-end 'yaml-pro-format-insert
- (concat ",\n" (make-string
- (* (- after-open-indent 1)
- yaml-pro-indent)
- ?\s)))
- (push ov-beg del-ovs)
- (unless (equal (treesit-node-type .before-close-node) "comment")
- (push ov-end del-ovs)))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--bm-fn-next-line ()
- "If a flow node passes the 80th column, put it on the next line."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((block_mapping_pair
- ":" @colon :anchor value: (flow_node) @child)
- @parent)))
- (del-ovs '()))
- (while nodes
- (let-alist (seq-take nodes 3)
- (setq nodes (cdddr nodes))
- (when (and (= (line-number-at-pos (treesit-node-start .parent))
- (line-number-at-pos (treesit-node-start .child)))
- (> (save-excursion (goto-char (treesit-node-end .child))
- (current-column))
- 80))
- (let* ((indent (yaml-pro-format-ts--node-indent .child))
- (ov (make-overlay (treesit-node-end .colon)
- (treesit-node-start .child))))
- (overlay-put
- ov 'yaml-pro-format-insert
- (concat "\n" (make-string (* indent yaml-pro-indent) ?\s)))
- (push ov del-ovs)))))
- del-ovs))
-
-(defun yaml-pro-format-ts--clean-doc-end ()
- "Remove the document end symbol (...)."
- (let* ((del-ovs '())
- (capture (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '(("..." @doc-end)))))
- (pcase-dolist (`(_ . ,node) capture)
- (save-excursion
- (goto-char (treesit-node-end node))
- (skip-chars-forward "\n \t")
- (let* ((next-node (treesit-node-at (point) 'yaml)))
- (cond
- ((member (treesit-node-type next-node) '("comment" "directive_name"))
- ;; leave alone if next node is a comment
- )
- ((equal (treesit-node-type next-node) "---")
- (let* ((ov (make-overlay (1- (treesit-node-start node))
- (treesit-node-end node))))
- (push ov del-ovs)))
- (t
- (let* ((ov (make-overlay (treesit-node-start node)
- (treesit-node-end node))))
- (overlay-put ov 'yaml-pro-format-insert "---")
- (push ov del-ovs)))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--remove-spaces-before-comments ()
- "Remove spaces before comments.
-If there is nothing before the comment on a line, move it to col 0.
-If there is other text, ensure one space remains."
- (let* ((del-ovs '())
- (capture (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((comment) @comment))))
- (pcase-dolist (`(_ . ,comment-node) capture)
- (save-excursion
- (save-match-data
- (goto-char (treesit-node-start comment-node))
- (cond
- ((looking-back "\n *" (- (point) 80))
- (let* ((ov (make-overlay (pos-bol) (treesit-node-start comment-node))))
- (push ov del-ovs)))
- ((looking-back "[^\n] *" (- (point) 80))
- (let* ((ov (make-overlay
- (save-excursion (goto-char (treesit-node-start comment-node))
- (skip-chars-backward " \t")
- (point))
- (treesit-node-start comment-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs)))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--expand-long-flow-sequence ()
- "Expand flow sequence to multiple lines if extend past column 80.
-Assumes that flow sequences have been previously reduced to one line."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_sequence) @seq)))
- (ovs '()))
- (pcase-dolist (`(_ . ,node) nodes)
- (when (save-excursion (goto-char (treesit-node-end node))
- (and (looking-at-p ",? *\n")
- (> (current-column) yaml-pro-format-print-width)))
- (let* ((capture (treesit-query-capture
- node
- '((flow_sequence (flow_node) @child)))))
- (pcase-dolist (`(_ . ,child) capture)
- (when (treesit-node-eq (treesit-node-parent child) node)
- (let* ((indent (yaml-pro-format-ts--node-indent child))
- (ov (make-overlay
- (treesit-node-start child) (treesit-node-start child))))
- (overlay-put
- ov 'yaml-pro-format-insert
- (concat "\n" (make-string (* indent yaml-pro-indent) ?\s)))
- (push ov ovs)))))
- (pcase-dolist (`(_ . ,close) (treesit-query-capture
- node
- '((flow_sequence "]" @close :anchor))))
- (when (treesit-node-eq (treesit-node-parent close) node)
- (let* ((ov (make-overlay (treesit-node-start close)
- (treesit-node-start close)))
- (indent (yaml-pro-format-ts--node-indent close))
- (end-str "\n"))
- (when (not (save-excursion (goto-char (treesit-node-start close))
- (looking-back ", *" (- (point) 80))))
- (setq end-str ",\n"))
- (overlay-put ov 'yaml-pro-format-insert
- (concat end-str
- (make-string (* indent yaml-pro-indent)
- ?\s)))
- (push ov ovs))))))
- ovs))
-
-(defun yaml-pro-format-ts--expand-long-flow-mapping ()
- "Expand flow mapping to multiple lines if extend past column 80.
-Assumes that flow mappings have been previously reduced to one line."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((flow_mapping) @map)))
- (ovs '()))
- (pcase-dolist (`(_ . ,node) nodes)
- (when (save-excursion
- (goto-char (treesit-node-end node))
- (and (looking-at-p ",? *\n")
- (or (> (current-column) yaml-pro-format-print-width)
- ;; if the flow is already spanning multiple lines, expand
- ;; it so it looks nice.
- (not (= (line-number-at-pos (treesit-node-start node))
- (line-number-at-pos (treesit-node-end node)))))))
- (let* ((capture (treesit-query-capture
- node
- '((flow_mapping [(flow_pair) (flow_node)] @child)))))
- (pcase-dolist (`(_ . ,child) capture)
- (when (and (treesit-node-eq (treesit-node-parent child) node)
- (save-excursion ;; dont add newline if one already exists
- (goto-char (treesit-node-start child))
- (not (looking-back "\n *" (- (point) 80)))))
- (let* ((indent (yaml-pro-format-ts--node-indent child))
- (ov (make-overlay (treesit-node-start child)
- (treesit-node-start child))))
- (overlay-put ov 'yaml-pro-format-insert
- (concat "\n" (make-string (* indent yaml-pro-indent)
- ?\s)))
- (push ov ovs)))))
- (let* ((capture (treesit-query-capture
- node
- '((flow_mapping "}" @close :anchor)))))
- (pcase-dolist (`(_ . ,close) capture)
- (when (treesit-node-eq (treesit-node-parent close) node)
- (let* ((ov (make-overlay (save-excursion
- (goto-char (treesit-node-start close))
- (skip-chars-backward " ")
- (point))
- (treesit-node-start close)))
- (indent (yaml-pro-format-ts--node-indent close))
- (end-str "\n"))
- ;; we only add this ov if flow is on same line
- (unless (save-excursion (goto-char (treesit-node-start close))
- (looking-back "\n *" (- (point) 80)))
- (when (not (save-excursion (goto-char (treesit-node-start close))
- (looking-back ", *" (- (point) 10))))
- (setq end-str ",\n"))
-
- (overlay-put
- ov 'yaml-pro-format-insert
- (concat end-str (make-string (* indent yaml-pro-indent) ?\s)))
- (push ov ovs))))))))
- ovs))
-
-(defun yaml-pro-format-ts--block-sequence ()
- "Ensure proper spacing around sequences' - character."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- `((block_sequence_item "-" @dash (_) @elt))))
- (groups (seq-group-by
- (lambda (capture)
- (treesit-node-parent (cdr capture)))
- nodes))
- (del-ovs '()))
- (while groups
- (save-excursion
- (let* ((dash-node (alist-get 'dash (cdar groups)))
- (elt-node (alist-get 'elt (cdar groups))))
- (let ((ov (make-overlay (treesit-node-end dash-node)
- (treesit-node-start elt-node))))
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs)))
- (setq groups (cdr groups))))
- del-ovs))
-
-(defun yaml-pro-format-ts--single-to-double ()
- "Convert single quote if it doesn't contain backslashes."
- (let* ((nodes (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((single_quote_scalar) @scalar)))
- (del-ovs '()))
- (pcase-dolist (`(_ . ,node) nodes)
- (save-excursion
- (save-restriction
- (narrow-to-region (treesit-node-start node) (treesit-node-end node))
- (goto-char (treesit-node-start node))
- (unless (search-forward "\\" nil t)
- ;; single quotes are to use backslash w/o escaping. If
- ;; single scalar has backslash, don't convert.
- (while (search-forward "''" nil t)
- (let* ((ov (make-overlay (match-beginning 0) (match-end 0))))
- (overlay-put ov 'yaml-pro-format-insert "'")
- (push ov del-ovs)))
- (let* ((open-ov (make-overlay (treesit-node-start node)
- (1+ (treesit-node-start node))))
- (close-ov (make-overlay (1- (treesit-node-end node))
- (treesit-node-end node))))
- (overlay-put open-ov 'yaml-pro-format-insert "\"")
- (overlay-put close-ov 'yaml-pro-format-insert "\"")
- (push open-ov del-ovs)
- (push close-ov del-ovs))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--reduce-spaces ()
- "Remove multiple spaces when not affecting meaning."
- (let* ((del-ovs '()))
- (save-excursion
- (save-match-data
- (goto-char (point-min))
- (while (search-forward-regexp "[ \t][ \t]+" nil t)
- (when (not (looking-back "\n *" (- (point) 80)))
- (let* ((at-node-type (treesit-node-type (treesit-node-on
- (match-beginning 0)
- (match-end 0)
- 'yaml))))
- (when (not (member at-node-type
- '("string_scalar" "double_quote_scalar"
- "single_quote_scalar" "block_scalar"
- "block_sequence_item" "comment")))
- (let* ((ov (make-overlay (match-beginning 0) (match-end 0))))
-
- (overlay-put ov 'yaml-pro-format-insert " ")
- (push ov del-ovs))))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--after-keep-p (point)
- "Return non-nil of POINT is after a block scalar keep item.
-This is needed due to a mismatch of the TreeSitter grammer and the YAML spec."
- (save-excursion
- (save-match-data
- (goto-char point)
- (while (looking-back "[\n ]" (- (point) 2))
- (forward-char -1))
- (let* ((at-node (treesit-node-at (point) 'yaml)))
- (and (equal (treesit-node-type at-node)
- "block_scalar")
- (yaml-pro-format-ts--node-keep-block-scalar-p at-node))))))
-
-(defun yaml-pro-format-ts--reduce-newlines ()
- "Reduce all appropriate grouped empty lines into one."
- (let* ((del-ovs '()))
- (save-excursion
- (save-match-data
- (goto-char (point-min))
- (while (search-forward-regexp "\\(?:\n[ \t]*\\)\\(?:\n[ \t]*\\)+\n" nil t)
- (let* ((on-node-type
- (treesit-node-type (treesit-node-on (match-beginning 0)
- (match-end 0)
- 'yaml))))
- (when (and (not (member
- on-node-type '("string_scalar" "double_quote_scalar"
- "single_quote_scalar" "block_scalar")))
- (not (yaml-pro-format-ts--after-keep-p (point))))
- (let* ((ov (make-overlay (match-beginning 0 ) (match-end 0))))
- (overlay-put ov 'yaml-pro-format-insert "\n\n")
- (push ov del-ovs)))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--document-separator-own-line ()
- "If document contans ---, make sure it's on its own line."
- (let* ((del-ovs '())
- (capture (treesit-query-capture (treesit-buffer-root-node 'yaml)
- '((document "---" @dashes)))))
- (pcase-dolist (`(_ . ,node) capture)
- (save-excursion
- (save-match-data
- (goto-char (treesit-node-end node))
- (when (looking-at "\\( *\\)[^ \n]")
- (let* ((ov (make-overlay (match-beginning 1) (match-end 1))))
- (overlay-put ov 'yaml-pro-format-insert "\n")
- (push ov del-ovs))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--node-numbered-block-scalar-p (node)
- "Return non-nil if NODE is a block scalar with an indent count."
- (and (equal (treesit-node-type node) "block_scalar")
- (string-match-p "^[>|][0-9]+" (treesit-node-text node))))
-
-(defun yaml-pro-format-ts--node-keep-block-scalar-p (node)
- "Return non-nil if NODE is a block scalar with an indent count."
- (and (equal (treesit-node-type node) "block_scalar")
- (string-match-p "^[>|][0-9]*\\+" (treesit-node-text node))))
-
-(defun yaml-pro-format-ts--lowest-block-scalar-indent (node)
- "Return the lowest indentation of text in NODE."
- (save-match-data
- (apply #'min
- (cdr (seq-map (lambda (line)
- (when (string-match "^ *" line)
- (length (match-string 0 line))))
- (string-lines (treesit-node-text node) t))))))
-
-(defun yaml-pro-format-ts--commenting-next-node (node)
- "If NODE is a comment, return the node next in the tree if commenting it.
-Often times a comment block will be commenting on something below
-it. We infer this if a comment is part of a block where there is
-a blank line above it."
- (when (equal (treesit-node-type node) "comment")
- (let* ((comment-block-start node)
- (comment-block-end node))
- (catch 'out
- (while t
- (let* ((next-sib (treesit-node-next-sibling comment-block-end)))
- (if (and (equal (treesit-node-type next-sib) "comment")
- (= (line-number-at-pos (treesit-node-start next-sib))
- (1+ (line-number-at-pos (treesit-node-start comment-block-end)))))
- (setq comment-block-end next-sib)
- (throw 'out nil)))))
- (catch 'out
- (while t
- (let* ((prev-sib (treesit-node-prev-sibling comment-block-start)))
- (if (and (equal (treesit-node-type prev-sib) "comment")
- (= (line-number-at-pos (treesit-node-start prev-sib))
- (1- (line-number-at-pos (treesit-node-start comment-block-start)))))
- (setq comment-block-start prev-sib)
- (throw 'out nil)))))
- (when (save-excursion
- (goto-char (treesit-node-start comment-block-start))
- (forward-line -1)
- (looking-at-p " *\n"))
- (let* ((next-block-node
- (save-excursion
- (goto-char (treesit-node-start comment-block-end))
- (forward-line 1)
- (back-to-indentation)
- (and (looking-at-p " *[^ \n\t-]")
- (treesit-node-at (point) 'yaml)))))
- (when (not (equal (treesit-node-type next-block-node) "comment"))
- next-block-node))))))
-
-(defun yaml-pro-format-ts--node-indent (root-node)
- "Return the number of indent parents of ROOT-NODE."
- (let* ((ct 0)
- (node root-node))
- ;; base count calculation
- (while node
- (when (and (equal (treesit-node-field-name node) "key")
- (not (equal (treesit-node-type (treesit-node-parent node))
- "flow_pair")))
- (cl-decf ct))
- (when (member (treesit-node-type node) '("-" "{" "[" "}" "]"))
- (cl-decf ct))
- (when (member (treesit-node-type node)
- '("block_mapping_pair" "block_sequence_item"
- "flow_mapping" "flow_sequence"))
- (cl-incf ct))
- (setq node (treesit-node-parent node)))
-
- ;; When a non-numbered block scalar is at indent level-0, indent
- ;; body contents.
- (when (and (= 0 ct)
- (equal (treesit-node-type root-node) "block_scalar")
- (not (yaml-pro-format-ts--node-numbered-block-scalar-p root-node)))
- (cl-incf ct))
-
- ;; Block scalars' text that is past the most indent needs to keep
- ;; its extra indentation
- (when (and (equal (treesit-node-type root-node) "block_scalar")
- (> (current-column)
- (yaml-pro-format-ts--lowest-block-scalar-indent root-node)))
- (cl-incf ct (/ (- (current-column)
- (yaml-pro-format-ts--lowest-block-scalar-indent root-node))
- yaml-pro-indent)))
- ct))
-
-(defun yaml-pro-format-ts--should-indent-p (node)
- "Return non-nil if NODE should be indented according to tree parse."
- (cond
- ((yaml-pro-format-ts--node-numbered-block-scalar-p node) nil)
- ((equal (treesit-node-type node) ":") nil)
- (t t)))
-
-(defun yaml-pro-format-ts--indent ()
- "Indent elements according to tree position."
- (let* ((del-ovs '()))
- (save-excursion
- (save-match-data
- (goto-char (point-min))
- (while (search-forward-regexp "\\(\n *\\)[^ \n]" nil t)
- (forward-char -1)
- (let* ((at-node (treesit-node-at (point) 'yaml)))
- (when (yaml-pro-format-ts--should-indent-p at-node)
- ;; in certain cases, a comment should be indented by the node
- ;; after it.
- (setq at-node (or (yaml-pro-format-ts--commenting-next-node at-node)
- at-node))
- (let* ((indent (yaml-pro-format-ts--node-indent at-node))
- (indent-str
- (make-string (* indent yaml-pro-indent) ?\s))
- (ov (make-overlay (1+ (match-beginning 0)) (point))))
- (overlay-put ov 'yaml-pro-format-insert indent-str)
- (push ov del-ovs)))))))
- del-ovs))
-
-(defun yaml-pro-format-ts--process-overlay (ov)
- "Delete characters in OV. Insert text of property `yaml-pro-format-insert'.
-OV is deleted after this function finishes."
- (let* ((insert-text (overlay-get ov 'yaml-pro-format-insert)))
- (goto-char (overlay-start ov))
- (delete-region (overlay-start ov) (overlay-end ov))
- (when insert-text
- (insert insert-text))
- (delete-overlay ov)))
-
-(defun yaml-pro-format-ts--run-while-changing (functions)
- "Run FUNCTIONS in order. Keep running FUNCTIONS until no change made."
- (catch 'done
- (while t
- (let ((changed nil))
- (dolist (f functions)
- (let* ((ovs (funcall f)))
- (when (> (length ovs) 0)
- (setq changed t))
- (save-excursion
- (seq-map #'yaml-pro-format-ts--process-overlay ovs))))
- (if (not changed)
- (throw 'done nil)
- (setq changed nil))))))
-
-(defvar-local yaml-pro-format-ts-indent-groups '()
- "List of nodes that need to be indented together at the same time.")
-
-(defun yaml-pro-format-ts--create-indent-groups ()
- "Populate `yaml-pro-format-ts-indent-groups' based on initial tree."
- (setq yaml-pro-format-ts-indent-groups nil)
- (let* ((capture (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((block_sequence_item "-") @item)))
- (groups (seq-group-by (pcase-lambda (node)
- (treesit-node-parent node))
- (seq-map #'cdr capture))))
- (pcase-dolist (`(_ . ,items) groups)
- (when (> (length items) 1)
- (push (seq-map
- (pcase-lambda (node)
- (make-overlay (treesit-node-start node)
- (treesit-node-end node) nil t))
- items)
- yaml-pro-format-ts-indent-groups))))
- (let* ((capture (treesit-query-capture
- (treesit-buffer-root-node 'yaml)
- '((block_mapping_pair ":") @item)))
- (groups (seq-group-by (pcase-lambda (node)
- (treesit-node-parent node))
- (seq-map #'cdr capture))))
- (pcase-dolist (`(_ . ,items) groups)
- (when (> (length items) 1)
- (push (seq-map (pcase-lambda (node)
- (make-overlay (treesit-node-start node)
- (treesit-node-end node) nil t))
- items)
- yaml-pro-format-ts-indent-groups)))))
-
-(defun yaml-pro-format-ts--ensure-indent-groups ()
- "Ensure that indent groups are on same level of indentation."
- (let* ((ovs '()))
- (dolist (group yaml-pro-format-ts-indent-groups)
- (let* ((indent (save-excursion (goto-char (overlay-start (car group)))
- (current-column))))
- (dolist (node (cdr group))
- (let* ((node-indent (save-excursion (goto-char (overlay-start node))
- (current-column)))
- (indent-diff (- indent node-indent)))
- (cond
- ((< indent-diff 0)
- (let* ((ov (make-overlay (+ (overlay-start node) indent-diff)
- (overlay-start node))))
- (push ov ovs)))
- ((< 0 indent-diff)
- (let* ((ov (make-overlay (overlay-start node)
- (overlay-start node))))
- (overlay-put ov 'yaml-pro-format-insert
- (make-string indent-diff ?\s))
- (push ov ovs))))))))
- ovs))
-
-(defconst yaml-pro-format-ts-functions
- '((reduce-newlines . yaml-pro-format-ts--reduce-newlines)
- (document-separator-own-line . yaml-pro-format-ts--document-separator-own-line)
- (oneline-flow . yaml-pro-format-ts--oneline-flow)
- (block-formatting . yaml-pro-format-ts--bm-single-space)
- ((or oneline-flow expand-flow) . yaml-pro-format-ts--flow-seq-grouping-space)
- (reduce-spaces . yaml-pro-format-ts--reduce-spaces)
- (block-formatting . yaml-pro-format-ts--block-sequence)
- (bm-fn-next-line . yaml-pro-format-ts--bm-fn-next-line)
- (clean-doc-end . yaml-pro-format-ts--clean-doc-end)
- (remove-spaces-before-comments . yaml-pro-format-ts--remove-spaces-before-comments)
- (expand-long-flow .
- (lambda ()
- (yaml-pro-format-ts--run-while-changing
- '(yaml-pro-format-ts--expand-long-flow-sequence
- yaml-pro-format-ts--expand-long-flow-mapping))))
- (single-to-double .
- yaml-pro-format-ts--single-to-double)
- ;; yaml-pro-format-ts--prose-wrap TODO
- (indent . yaml-pro-format-ts--indent))
- "Alist of feature symbol and formatting functions.")
-
-
-(defun yaml-pro-format ()
- "Format the YAML buffer according to pre-defined rules."
- (interactive)
- (when (treesit-query-capture (treesit-buffer-root-node 'yaml) '((ERROR) @err))
- (user-error "Error encountered when parsing buffer with treesitter. Please ensure your syntax is correct and try again"))
- (save-excursion
- (goto-char (point-max))
- (insert "\n"))
- (yaml-pro-format-ts--create-indent-groups)
- (let* ((fmt-functions
- (seq-map
- #'cdr
- (seq-filter
- (pcase-lambda (`(,sym . _))
- (pcase sym
- (`(or . ,elts)
- (seq-find (lambda (sym) (member sym yaml-pro-format-features))
- elts))
- (sym (member sym yaml-pro-format-features))))
- yaml-pro-format-ts-functions))))
- (dolist (f fmt-functions)
- (let* ((ovs (funcall f)))
- (save-excursion
- (seq-map #'yaml-pro-format-ts--process-overlay ovs)))
- (let* ((ovs (yaml-pro-format-ts--ensure-indent-groups)))
- (save-excursion
- (seq-map #'yaml-pro-format-ts--process-overlay ovs))))
- (delete-trailing-whitespace (point-min) (point-max))))
-
-(defalias 'yaml-pro-format-ts #'yaml-pro-format)
-
-(provide 'yaml-pro-format)
-
-;;; yaml-pro-format.el ends here
+++ /dev/null
-;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "yaml-pro" "20241223.1723"
- "Parser-aided YAML editing features."
- '((emacs "26.1")
- (yaml "0.5.1"))
- :url "https://github.com/zkry/yaml-pro"
- :commit "f7706ea170de98d29b7cdd5a4f189bd038b1e27b"
- :revdesc "f7706ea170de"
- :keywords '("tools"))
+++ /dev/null
-;;; yaml-pro.el --- Parser-aided YAML editing features -*- lexical-binding: t -*-
-
-;; Author: Zachary Romero
-;; Maintainer: Zachary Romero
-;; Package-Version: 20241223.1723
-;; Package-Revision: f7706ea170de
-;; Package-Requires: ((emacs "26.1") (yaml "0.5.1"))
-;; Homepage: https://github.com/zkry/yaml-pro
-;; Keywords: tools
-
-;; This file is not part of GNU Emacs
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; yaml-pro contains a new mode which provides conveniences when
-;; editing YAML. Running `yaml-pro-mode' switches the mode and the
-;; following commands are available:
-;; - `yaml-pro-move-subtree-up' and `yaml-pro-move-subtree-down'
-;; - `yaml-pro-next-subtree' and `yaml-pro-prev-subtree',
-;; - `yaml-pro-kill-subtree'
-;; - `yaml-pro-up-level'
-;; - `yaml-pro-fold-at-point' and `yaml-pro-unfold-at-point'.
-;; - `yaml-pro-edit-scalar'
-;; - `yaml-pro-jump' or if consult exists `yaml-pro-consult-jump'
-
-;;; Code:
-
-(require 'yaml)
-(require 'yaml-pro-edit)
-(require 'yaml-pro-format)
-(require 'treesit nil t)
-(require 'consult nil t)
-
-(defgroup yaml-pro nil
- "YAML editing tools."
- :prefix "yaml-pro-"
- :group 'convenience)
-
-
-;;; yaml-pro tree sitter
-
-(defcustom yaml-pro-ts-yank-subtrees t
- "Non-nil means when yanking subtrees, adjust the level."
- :group 'yaml-pro
- :type 'boolean)
-
-(defcustom yaml-pro-ts-path-element-separator ?.
- "Character separating path elements when generating node labels."
- :group 'yaml-pro
- :type 'character)
-
-(defun yaml-pro-ts--until-mapping (node)
- "Recursively look up from NODE returning first `block_mapping_pair'."
- (treesit-parent-until
- node
- (lambda (node)
- (equal (treesit-node-type node) "block_mapping_pair"))))
-
-(defun yaml-pro-ts--until-mapping-or-list (node)
- "Recursively look up from NODE returning first `block_mapping_pair'."
- (treesit-parent-until
- node
- (lambda (node)
- (or (equal (treesit-node-type node) "block_mapping_pair")
- (equal (treesit-node-type node) "block_sequence_item")))))
-
-(defun yaml-pro-ts--until-list (node)
- "Recursively look up from NODE returning first `block_sequence_item'."
- (treesit-parent-until
- node
- (lambda (node)
- (equal (treesit-node-type node) "block_sequence_item"))))
-
-(defun yaml-pro-ts--until-mapping-or-list (node)
- "Recursively look up from NODE returning first mapping or sequence item."
- (treesit-parent-until
- node
- (lambda (node)
- (or
- (equal (treesit-node-type node) "block_mapping_pair")
- (equal (treesit-node-type node) "block_sequence_item")))))
-
-(defun yaml-pro-ts-kill-subtree ()
- "Kill the entire subtree located at the current-point."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (tree-top (yaml-pro-ts--until-mapping-or-list at-node)))
- (when tree-top
- (kill-region (treesit-node-start tree-top)
- (treesit-node-end tree-top)))))
-
-(defun yaml-pro-copy-node-path-at-point ()
- "Copy node path at point to clipboard."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (path (yaml-pro-ts--imenu-node-label at-node)))
- (kill-new path)
- (message "%s was copied to clipboard" (propertize path 'face '(bold default)))))
-
-(defun yaml-pro-ts-up-level ()
- "Move the point to the parent tree."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (tree-top (yaml-pro-ts--until-mapping-or-list at-node))
- (parent-tree-top (and tree-top (yaml-pro-ts--until-mapping-or-list tree-top))))
- (when parent-tree-top
- (goto-char (treesit-node-start parent-tree-top)))))
-
-(defun yaml-pro-ts-down-level ()
- "Move the point down to first child of current item."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (tree-top (yaml-pro-ts--until-mapping-or-list at-node))
- (nodes (seq-map #'cdr
- (treesit-query-capture tree-top '((block_sequence_item) @match
- (block_mapping_pair) @match))))
- (children (seq-sort-by
- #'treesit-node-start
- #'<
- (seq-filter
- (lambda (node)
- (treesit-node-eq tree-top (yaml-pro-ts--until-mapping-or-list node)))
- nodes))))
- (if (car children)
- (goto-char (treesit-node-start (car children)))
- (beep))))
-
-(defun yaml-pro-ts-first-sibling ()
- "Move the point to the first sibling."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (at-sibling (yaml-pro-ts--until-mapping-or-list at-node))
- (parent (treesit-node-parent at-sibling))
- (all-siblings (treesit-node-children parent))
- (first-sibling (car all-siblings)))
- (if first-sibling
- (goto-char (treesit-node-start first-sibling))
- (beep))))
-
-(defun yaml-pro-ts-last-sibling ()
- "Move the point to the last sibling."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (at-sibling (yaml-pro-ts--until-mapping-or-list at-node))
- (parent (treesit-node-parent at-sibling))
- (all-siblings (treesit-node-children parent))
- (last-sibling (car (last all-siblings))))
- (if last-sibling
- (goto-char (treesit-node-start last-sibling))
- (beep))))
-
-(defun yaml-pro-ts-prev-mapping-node (tree-top type)
- "Return nearest previous sibling node of TREE-TOP of type TYPE."
- (interactive)
- (setq tree-top (treesit-node-prev-sibling tree-top))
- (while (and tree-top
- (not (equal (treesit-node-type tree-top) type)))
- (setq tree-top (treesit-node-prev-sibling tree-top)))
- tree-top)
-
-(defun yaml-pro-ts-next-mapping-node (tree-top type)
- "Return nearest next sibling node of TREE-TOP of type TYPE."
- (interactive)
- (setq tree-top (treesit-node-next-sibling tree-top))
- (while (and tree-top
- (not (equal (treesit-node-type tree-top) type)))
- (setq tree-top (treesit-node-next-sibling tree-top)))
- tree-top)
-
-
-(defun yaml-pro-ts-prev-subtree ()
- "Move the point to the previous subtree or list."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (prev-node
- (if (and (equal (treesit-node-type at-node) "-")
- (equal (treesit-node-type (treesit-node-parent at-node))
- "block_sequence_item"))
- (yaml-pro-ts-prev-mapping-node (yaml-pro-ts--until-list at-node) "block_sequence_item")
- (yaml-pro-ts-prev-mapping-node (yaml-pro-ts--until-mapping at-node) "block_mapping_pair"))))
- (if prev-node
- (goto-char (treesit-node-start prev-node))
- (ding))))
-
-(defun yaml-pro-ts-backward-sentence ()
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (starting-point (point)))
- (unless (bobp)
- (cond
- ((or (equal (treesit-node-type at-node) "\"")
- (equal (treesit-node-type at-node) "'")
- (equal (treesit-node-type at-node) "block_scalar"))
- (let ((sentence-end "\\. "))
- (backward-sentence)
- (when (not (equal
- (treesit-node-type at-node)
- (treesit-node-type (treesit-node-at (point) 'yaml))))
- (goto-char (treesit-node-start at-node))
- (forward-line -1)
- (yaml-pro-ts-backward-sentence))))
- (t
- (let ((ring-bell-function #'ignore))
- (forward-line -1)
- (while (looking-at "^ *\\(#.*\\)?$")
- (forward-line -1))
- (when (not (bobp))
- (cl-flet ((move-to-leaf ()
- (let ((start-point (point)))
- (catch 'done
- (while t
- (yaml-pro-ts-down-level)
- (when (eql (point) start-point)
- (throw 'done t))
- (setq start-point (point))))
- (goto-char (pos-eol)))))
- (let ((start (point)))
- (while (progn (move-to-leaf)
- (>= (point) starting-point))
- (goto-char start)
- (forward-line -1)
- (while (and (looking-at "^ *\\(#.*\\)?$")
- (not (bobp)))
- (forward-line -1))
- (setq start (point))))))))))))
-
-(defun yaml-pro-ts-forward-sentence ()
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml)))
- (cond
- ((or (equal (treesit-node-type at-node) "\"")
- (equal (treesit-node-type at-node) "'")
- (equal (treesit-node-type at-node) "block_scalar"))
- (let ((sentence-end "\\. "))
- (forward-sentence)
- (when (not (equal
- (treesit-node-type at-node)
- (treesit-node-type (treesit-node-at (point) 'yaml))))
- (goto-char (treesit-node-end at-node))
- (forward-line 1)
- (yaml-pro-ts-forward-sentence))))
- (t
- (let ((ring-bell-function #'ignore))
- (forward-line 1)
- (while (and (looking-at "^ *\\(#.*\\)?$")
- (not (eobp)))
- (forward-line 1))
- (let ((start-point (point)))
- (catch 'done
- (while t
- (yaml-pro-ts-down-level)
- (when (or (eql (point) start-point)
- (eobp))
- (throw 'done t))
- (setq start-point (point))))
- (goto-char (pos-eol))))))))
-
-(defun yaml-pro-ts-next-subtree ()
- "Move the point to the next subtree or list."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (next-node
- (if (and (equal (treesit-node-type at-node) "-")
- (equal (treesit-node-type (treesit-node-parent at-node))
- "block_sequence_item"))
- (yaml-pro-ts-next-mapping-node (yaml-pro-ts--until-list at-node) "block_sequence_item")
- (yaml-pro-ts-next-mapping-node (yaml-pro-ts--until-mapping at-node) "block_mapping_pair"))))
- (if next-node
- (goto-char (treesit-node-start next-node))
- (ding))))
-
-(defun yaml-pro-ts-move-subtree (dir)
- "Get the current and DIR node and swap the contents of the two."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (tree-top (yaml-pro-ts--until-mapping-or-list at-node))
- (tree-top-type (treesit-node-type tree-top))
- (sibling-node (if (eq dir 'down)
- (yaml-pro-ts-next-mapping-node tree-top tree-top-type)
- (yaml-pro-ts-prev-mapping-node tree-top tree-top-type)))
- (at-start-marker (make-marker))
- (at-end-marker (make-marker))
- (sibling-start-marker (make-marker))
- (sibling-end-marker (make-marker))
- (sibling-end-trailing-newline nil))
- (when (and tree-top sibling-node)
- (set-marker at-start-marker (treesit-node-start tree-top))
- (set-marker at-end-marker (treesit-node-end tree-top))
- (set-marker sibling-start-marker (treesit-node-start sibling-node))
- (set-marker sibling-end-marker (treesit-node-end sibling-node))
- ;; Check if there's a trailing newline after the last node. We
- ;; do this because we don't want to insert a trailing newline if
- ;; the user doesn't have a trailing newline.
- (save-excursion
- (goto-char sibling-end-marker)
- (setq sibling-end-trailing-newline (equal (char-before) ?\n)))
- (let* ((at-tree-text (buffer-substring-no-properties
- at-start-marker at-end-marker))
- (sibling-tree-text (buffer-substring-no-properties
- sibling-start-marker sibling-end-marker)))
- (delete-region at-start-marker at-end-marker)
- (delete-region sibling-start-marker sibling-end-marker)
- (goto-char sibling-start-marker)
- ;; Empty newlines that are after the last node are moved along
- ;; with the last node, so after text has been deleted from
- ;; at-node and sibling-node, there's no newline for
- ;; at-node. We only do this when the last item has a trailing
- ;; newline.
- (when (and (eobp) sibling-end-trailing-newline)
- (save-excursion
- (insert "\n")))
- (insert at-tree-text)
- (goto-char at-start-marker)
- ;; We delete the last newline (if there's one) because when we
- ;; move to `at-start-marker', there's already an empty line.
- (insert (replace-regexp-in-string "\n\\'" "" sibling-tree-text))
- (goto-char sibling-start-marker)))))
-
-(defun yaml-pro-ts-move-subtree-up ()
- "Swap the current tree with that of the next sibling's."
- (interactive)
- (yaml-pro-ts-move-subtree 'up))
-
-(defun yaml-pro-ts-move-subtree-down ()
- "Swap the current tree with that of the previous sibling's."
- (interactive)
- (yaml-pro-ts-move-subtree 'down))
-
-(defun yaml-pro-ts-meta-return ()
- "Insert new list item after current item."
- (interactive)
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (list-item-top (yaml-pro-ts--until-list at-node))
- (list-item-end-in-newline nil))
- (when list-item-top
- (let* ((indentation (save-excursion
- (goto-char (treesit-node-start list-item-top))
- (current-column))))
- (goto-char (treesit-node-end list-item-top))
- ;; If the file didn't have a newline at the end of the item,
- ;; then we are looking at ^$
- (setq list-item-end-in-newline (looking-at "^$"))
- (cond
- ;; After visiting the end of the top item, we check if we are
- ;; in a newline or not. If we are not, we start a new line.
- ((not (looking-at "^$"))
- (insert "\n" (make-string indentation ?\s) "- "))
- ;; When there are empty lines above the point after going to
- ;; the end of the element. When in the top last element of a
- ;; list, treesit-node-end considers empty lines as part of
- ;; the list element.
- ((save-excursion
- (forward-line -1)
- (looking-at "^$"))
- (while (save-excursion
- (forward-line -1)
- (looking-at "^$"))
- (forward-line -1))
- (insert (make-string indentation ?\s) "- "))
- ;; If none of the cases are true, we are at the beginning of
- ;; a line just one line below the previous item, so we just
- ;; start another item.
- (t
- (insert (make-string indentation ?\s) "- ")))
- ;; If the the user inserted a newline at the end of the item,
- ;; we insert a newline. If the user didn't, we don't insert a
- ;; newline. We do this to conform with the POSIX definition of
- ;; a line and at the same time to act according the user's
- ;; preferences.
- (when list-item-end-in-newline
- (save-excursion
- (insert "\n")))))))
-
-(defun yaml-pro-convolute-tree ()
- "Swap the keys of the parent of the item at point and the parent's parent."
- (interactive)
- (let* ((at-node (yaml-pro-ts--until-mapping (treesit-node-at (point) 'yaml)))
- (parent-tree (yaml-pro-ts--until-mapping at-node))
- (grandparent-tree (yaml-pro-ts--until-mapping
- (treesit-node-parent parent-tree))))
- (when (and parent-tree grandparent-tree)
- (let* ((query '((block_mapping_pair key: (_) @key)))
- (parent-key (alist-get 'key (treesit-query-capture parent-tree query)))
- (parent-start (treesit-node-start parent-key))
- (parent-end (treesit-node-end parent-key))
- (parent-text (buffer-substring-no-properties parent-start parent-end))
- (grandparent-key (alist-get 'key (treesit-query-capture grandparent-tree query)))
- (grandparent-start (treesit-node-start grandparent-key))
- (grandparent-end (treesit-node-end grandparent-key))
- (grandparent-text (buffer-substring-no-properties
- grandparent-start grandparent-end)))
- (save-excursion
- (delete-region parent-start parent-end)
- (goto-char parent-start)
- (insert grandparent-text)
- (delete-region grandparent-start grandparent-end)
- (goto-char grandparent-start)
- (insert parent-text))))))
-
-(defun yaml-pro-ts-indent-subtree (prefix)
- "Indent the current subtree by one level.
-
-This function uses tree-sitter. Indentation is controlled by the
-variable `yaml-pro-indent'."
- (interactive "p\n")
- (let* ((at-subtree (yaml-pro-ts--until-mapping (treesit-node-at (point) 'yaml)))
- (origin-marker (make-marker))
- (end-marker (make-marker))
- (indent-str (make-string yaml-pro-indent ?\s))
- (original-content (concat
- (buffer-substring-no-properties
- (save-excursion (goto-char (treesit-node-start at-subtree)) (pos-bol))
- (treesit-node-start at-subtree))
- (treesit-node-text at-subtree t)))
- (original-point (point))
- (start-point (save-excursion (goto-char (treesit-node-start at-subtree)) (pos-bol))))
- (set-marker origin-marker (point))
- (set-marker end-marker (treesit-node-end at-subtree))
- (goto-char start-point)
- (forward-line 0)
- (while (< (point) end-marker)
- (when (not (looking-at " *$"))
- (insert indent-str))
- (forward-line 1))
- (goto-char origin-marker)
- (when (and
- (= prefix 1)
- (treesit-query-capture (treesit-buffer-root-node 'yaml) '((ERROR) @err)))
- (delete-region start-point end-marker)
- (goto-char start-point)
- (insert original-content)
- (goto-char original-point)
- (beep)
- (message "indent would result in broken tree. Prefix command with `C-u' to force indent."))
- (set-marker origin-marker nil)
- (set-marker end-marker nil)))
-
-(defun yaml-pro-ts-unindent-subtree (prefix)
- "Unindent the current subtree by one level.
-
-This function uses tree-sitter. Indentation is controlled by the
-variable `yaml-pro-indent'."
- (interactive "p\n")
- (let* ((at-subtree (yaml-pro-ts--until-mapping (treesit-node-at (point) 'yaml)))
- (origin-marker (make-marker))
- (end-marker (make-marker))
- (indent-str (make-string yaml-pro-indent ?\s))
- (original-content (concat
- (buffer-substring-no-properties
- (save-excursion (goto-char (treesit-node-start at-subtree)) (pos-bol))
- (treesit-node-start at-subtree))
- (treesit-node-text at-subtree t)))
- (original-point (point))
- (start-point (save-excursion (goto-char (treesit-node-start at-subtree))
- (pos-bol))))
- (set-marker origin-marker (point))
- (set-marker end-marker (treesit-node-end at-subtree))
- (goto-char start-point)
- (forward-line 0)
- (while (< (point) end-marker)
- (when (looking-at (regexp-quote indent-str))
- (delete-char yaml-pro-indent))
- (forward-line 1))
- (goto-char origin-marker)
- (when (and
- (= 1 prefix)
- (treesit-query-capture (treesit-buffer-root-node 'yaml) '((ERROR) @err)))
- (delete-region start-point end-marker)
- (goto-char start-point)
- (insert original-content)
- (goto-char original-point)
- (beep)
- (message "unindent would result in broken tree. Prefix command with `C-u' to force indent."))
- (set-marker origin-marker nil)
- (set-marker end-marker nil)))
-
-(defun yaml-pro-ts-mark-subtree (up)
- "Mark the current subtree.
-This puts point at the start of the current subtree, and mark at
-the end. If a numeric prefix UP is given, move up into the
-hierarchy of headlines by UP levels before marking the subtree."
- (interactive "P")
- (while (and up (> up 0))
- (yaml-pro-ts-up-level)
- (cl-decf up))
- (let* ((at-subtree (yaml-pro-ts--until-mapping-or-list (treesit-node-at (point) 'yaml))))
- (if (and (not up)
- (or (and (eq last-command this-command) (mark t))
- (and transient-mark-mode mark-active)))
- (progn
- (while (and at-subtree (<= (treesit-node-end at-subtree) (mark)))
- (setq at-subtree
- (yaml-pro-ts-next-mapping-node
- at-subtree (treesit-node-type at-subtree))))
- (when at-subtree
- (set-mark (treesit-node-end at-subtree))))
- (push-mark (treesit-node-end at-subtree))
- (goto-char (treesit-node-start at-subtree))
- (activate-mark))))
-
-(defun yaml-pro-ts--kill-is-subtree (&optional tree)
- "Return non-nil if TREE (or current kill) is a valid tree."
- (unless tree
- (setq tree (and kill-ring (current-kill 0))))
- (when (and tree (> (length (string-split tree "\n")) 1))
- (let ((node (treesit-parse-string tree 'yaml)))
- (treesit-query-capture node '((block_mapping_pair) @key)))))
-
-(defun yaml-pro-ts--kill-is-sequence (&optional tree)
- "Return non-nil if TREE (or current kill) is a valid sequence."
- (unless tree
- (setq tree (and kill-ring (current-kill 0))))
- (let ((first-line (car (string-split (string-trim-left tree) "\n"))))
- (when (and tree (> (length (string-split tree "\n")) 1))
- (let ((node (treesit-parse-string first-line 'yaml)))
- (treesit-query-capture node '((block_sequence) @key))))))
-
-(defun yaml-pro-ts-paste-sequence (&optional remove)
- "Insert the current kill into the buffer, preserving sequence structure.
-If REMOVE is non-nil, pop item off `kill-ring'."
- (interactive)
- (let ((seq (current-kill 0)))
- (unless (yaml-pro-ts--kill-is-sequence seq)
- (user-error
- (substitute-command-keys
- "The kill is not a YAML-sequence. Use `\\[yank]' to yank anyways")))
- (let* ((base-indent (current-column))
- (seq (string-trim seq))
- (seq-lines (split-string seq "\n"))
- (indent-lengths (save-match-data
- (or (seq-map
- (lambda (line)
- (string-match "^\\( *\\)" line)
- (length (match-string 1 line)))
- (seq-filter
- (lambda (line)
- (string-match-p "^ *-" line))
- (cdr seq-lines)))
- (list (* yaml-pro-indent 2)))))
- (smallest-indent (apply #'min indent-lengths))
- (smallest-indent-string (make-string smallest-indent ?\s))
- (seq-rest-lines-at-indent (string-join
- (seq-map
- (lambda (line)
- (concat
- (make-string base-indent ?\s)
- (string-remove-prefix smallest-indent-string line)))
- (cdr seq-lines))
- "\n")))
- (push-mark (point) 'nomsg)
- (insert (car seq-lines) "\n")
- (insert seq-rest-lines-at-indent))))
-
-(defun yaml-pro-ts-paste-subtree (&optional remove)
- "Insert the current kill into the buffer, preserving tree structure.
-If REMOVE is non-nil, pop item off `kill-ring'."
- (interactive)
- (let ((tree (current-kill 0)))
- (unless (yaml-pro-ts--kill-is-subtree tree)
- (user-error
- (substitute-command-keys
- "The kill is not a YAML-tree. Use `\\[yank]' to yank anyways")))
- (let* ((base-indent (current-column))
- (indent-lengths (save-match-data
- (seq-map
- (lambda (line)
- (string-match "^\\( *\\)" line)
- (length (match-string 1 line)))
- (seq-filter
- (lambda (line)
- (string-match-p "^ *[a-zA-Z0-9\"'_-]+:" line))
- (cdr (split-string tree "\n")))))))
- (if (not indent-lengths)
- (progn
- (push-mark (point) 'nomsg)
- (insert tree))
- (let* (;; does the killed text have more than one top level?
- ;; if so we need to calculate indentation differently.
- (single-top-lvl-p
- (seq-every-p
- (lambda (len)
- (<= (car indent-lengths) len))
- (cdr indent-lengths)))
- ;; indent that the rest of kill text should have
- (kill-indent (max (+ (apply #'min indent-lengths)
- (if single-top-lvl-p -2 0))
- 0))
- (kill-indent-string (make-string kill-indent ?\s))
- (base-indent-string (make-string base-indent ?\s))
- (insertion-string (with-temp-buffer
- (insert tree)
- (goto-char (point-min))
- (forward-line 1)
- (while (not (eobp))
- (when (looking-at kill-indent-string)
- (delete-char kill-indent)
- (insert base-indent-string))
- (forward-line 1))
- (buffer-string))))
- (push-mark (point) 'nomsg)
- (insert insertion-string)))))
- (when remove (pop kill-ring)))
-
-(defun yaml-pro-ts-yank (&optional arg)
- "Yank text on kill ring. If YAML-subtree, then indent it correctly.
-This command will look at the current kill and check if it is a
-subtree, or series of subtrees. If so, and ARG is nil, the
-subtree is yanked with the appropriate amount of whitespace
-inserted to make the tree retain its original structure."
- (interactive "P")
- (setq this-command 'yank)
- (if arg
- (call-interactively #'yank)
- (let* ((subtreep (yaml-pro-ts--kill-is-subtree))
- (seqp (yaml-pro-ts--kill-is-sequence))
- (pos (point))
- ;; Is point on a placeholder for a block node?
- (block-allowed-p
- (and
- ;; The line must not have nothing but spaces after the point.
- (looking-at "[ \t]*$")
- (and (save-excursion
- (skip-chars-backward " \t")
- (or
- ;; The line is blank.
- (bolp)
- ;; The point is preceded by a block struct indicator.
- ;; Note that compact collections cannot be preceded by
- ;; anchors or tags.
- (and (memq (char-before) '(?- ?: ??))
- ;; Block struct indicators must be followed by spaces.
- (memq (char-before pos) '(?\s ?\t)))))))))
- (cond
- ((and seqp block-allowed-p yaml-pro-ts-yank-subtrees)
- (yaml-pro-ts-paste-sequence))
- ((and subtreep block-allowed-p yaml-pro-ts-yank-subtrees)
- (yaml-pro-ts-paste-subtree))
- (t (call-interactively #'yank))))))
-
-(defun yaml-pro-ts-newline (&optional arg interactive)
- (interactive "*P\np")
- (barf-if-buffer-read-only)
- (cond
- ((or (looking-at-p " *[^ \n]")
- (equal (treesit-node-type (treesit-node-at (point) 'yaml)) ":")
- (equal (treesit-node-type (treesit-node-parent (treesit-node-at (point) 'yaml)))
- "block_scalar"))
- (let* ((indent (yaml-pro-format-ts--node-indent (treesit-node-at (point) 'yaml)))
- (indent-column (* indent yaml-pro-indent)))
- (call-interactively #'newline)
- (when (< (current-column) indent-column)
- (insert (make-string (- indent-column (current-column)) ?\s)))))
- (t (call-interactively #'newline))))
-
-(defun yaml-pro-ts--imenu-node-label (node)
- "Return an imenu label for NODE."
- (let ((top node)
- (root (treesit-buffer-root-node 'yaml))
- (label ""))
- (while (not (treesit-node-eq node root))
- (cond
- ((equal (treesit-node-type node) "block_mapping_pair")
- (let ((key-node (treesit-node-child-by-field-name node "key")))
- (when key-node
- (setq label (concat (treesit-node-text key-node)
- (if (equal label "") "" (string yaml-pro-ts-path-element-separator))
- label)))))
- ((equal (treesit-node-type node) "block_sequence_item")
- (setq label (format "[%d]%c%s" (treesit-node-index node) yaml-pro-ts-path-element-separator label))))
- (setq node (treesit-node-parent node)))
- label))
-
-(defun yaml-pro-ts-create-index ()
- "Create imenu index of YAML file using treesitter."
- (let ((all-keys (treesit-query-capture (treesit-buffer-root-node 'yaml) '((block_mapping_pair key: (_) @key))))
- (imenu-items '()))
- (dolist (key-item all-keys)
- (let* ((key-node (cdr key-item))
- (key-label (yaml-pro-ts--imenu-node-label key-node)))
- (push (cons key-label (treesit-node-start key-node)) imenu-items)))
- (seq-reverse imenu-items)))
-
-(defun yaml-pro-ts-eldoc (&rest _ignored)
- "Return eldoc message of current point."
- (let* ((at-tree (yaml-pro-ts--until-mapping-or-list (treesit-node-at (point) 'yaml))))
- (when at-tree
- (yaml-pro-ts--imenu-node-label at-tree))))
-
-(defun yaml-pro-ts--path-to-imenu-key (path)
- "Stringify path to the same format that imenu uses.
-E.g. the path (\"one\" 0 \"two\") results in the key string \"one.[0].two\"."
- (string-join
- (seq-map
- (lambda (elt) (if (numberp elt) (format "[%d]" elt) elt))
- path)
- (string yaml-pro-ts-path-element-separator)))
-
-(defun yaml-pro-ts-jump-to-definition (&rest parts)
- "Jump to a part of the YAML file based on PARTS.
-If element is a sting, use it as block mapping key.
-If element is a number, use it as a sequence index."
- (imenu (yaml-pro-ts--path-to-imenu-key parts)))
-
-(defun yaml-pro-ts-add-mapping (&rest keys)
- "Add KEYS as levels beneath current node's block mapping.
-KEYS are added as increasingly nested levels."
- (let* ((paths (seq-map #'car (yaml-pro-ts-create-index)))
- (to-go keys)
- (to-add'()))
- (while (and (not (member (yaml-pro-ts--path-to-imenu-key to-go) paths))
- to-go)
- (setq to-add (append (last to-go) to-add))
- (setq to-go (butlast to-go)))
- (when to-go
- (apply #'yaml-pro-ts-jump-to-definition to-go))
- (when to-add
- (let* ((at-node (treesit-node-at (point) 'yaml))
- (parent (treesit-parent-until
- at-node
- (lambda (node)
- (equal (treesit-node-type node) "block_mapping_pair"))
- t))
- (parent-indent (if to-go
- (save-excursion
- (goto-char (treesit-node-start parent))
- (current-column))
- (- yaml-pro-indent))))
- (if (or (not to-go)
- (or (not (treesit-node-child-by-field-name parent "value"))
- (equal (treesit-node-type (car (treesit-node-children (treesit-node-child-by-field-name parent "value"))))
- "block_mapping")))
- (progn
- (if to-go
- (goto-char (treesit-node-end parent))
- (goto-char (point-max))
- (unless (looking-back "\n" (- (point) 2))
- (insert "\n")))
- (while to-add
- (insert "\n")
- (insert (make-string (+ yaml-pro-indent parent-indent) ?\s))
- (insert (car to-add) ":")
- (setq to-add (cdr to-add))
- (cl-incf parent-indent yaml-pro-indent)))
- (user-error "unable to to insert element at position"))))))
-
-(defconst yaml-pro-ts-mode-map
- (let ((map (make-sparse-keymap)))
- (prog1 map
- (define-key map (kbd "C-c C-x C-w") #'yaml-pro-ts-kill-subtree)
- (define-key map (kbd "C-c C-u") #'yaml-pro-ts-up-level)
- (define-key map (kbd "C-c C-d") #'yaml-pro-ts-down-level)
-
- (define-key map (kbd "C-c C-p") #'yaml-pro-ts-prev-subtree)
- (define-key map (kbd "C-c C-n") #'yaml-pro-ts-next-subtree)
-
- (define-key map (kbd "M-a") #'yaml-pro-ts-backward-sentence)
- (define-key map (kbd "M-e") #'yaml-pro-ts-forward-sentence)
-
- (define-key map (kbd "s-<up>") #'yaml-pro-ts-move-subtree-up)
- (define-key map (kbd "s-<down>") #'yaml-pro-ts-move-subtree-down)
-
- (define-key map (kbd "C-c >") #'yaml-pro-ts-indent-subtree)
- (define-key map (kbd "C-c <") #'yaml-pro-ts-unindent-subtree)
-
- (define-key map (kbd "M-<return>") #'yaml-pro-ts-meta-return)
- (define-key map (kbd "M-?") #'yaml-pro-convolute-tree)
- (define-key map (kbd "C-c @") #'yaml-pro-ts-mark-subtree)
- (define-key map (kbd "C-c C-x C-y") #'yaml-pro-ts-paste-subtree)
-
- (define-key map [remap yank] #'yaml-pro-ts-yank)
-
- (define-key map (kbd "C-c '") #'yaml-pro-edit-ts-scalar)))
- "Map for minor mode `yaml-pro-ts-mode'.")
-
-;;;###autoload
-(define-minor-mode yaml-pro-ts-mode
- "Minor mode to enable yaml-pro treesitter keymap.
-
-\\{yaml-pro-mode-map}"
- :init-value nil
- :group 'yaml-pro
- :keymap yaml-pro-ts-mode-map
-
- (when yaml-pro-ts-mode
- (unless (featurep 'treesit)
- (user-error "Tree-sitter not supported in current Emacs version"))
- (unless (treesit-ready-p 'yaml)
- (user-error "YAML tree-sitter not ready"))
- (treesit-parser-create 'yaml)
- (setq imenu-generic-expression nil)
- (setq imenu-create-index-function #'yaml-pro-ts-create-index)
- (if (boundp 'eldoc-documentation-functions)
- (add-hook 'eldoc-documentation-functions #'yaml-pro-ts-eldoc nil t)
- (setq-local eldoc-documentation-function #'yaml-pro-ts-eldoc))))
-
-\f
-;;; yaml-pro parser
-
-(defcustom yaml-pro-max-parse-size 5000
- "Size of buffer for which any size greater than use heuristic to parse.
-
-Note that this isn't fully compatable with every command."
- :group 'yaml-pro
- :type 'number
- :package-version '(yaml-pro "0.2.0"))
-
-(defface yaml-pro-fold-replacement-face
- '((t :inherit 'font-lock-comment-face))
- "Face for fold replacement text.")
-
-(defcustom yaml-pro-indent (if (boundp 'yaml-indent)
- yaml-indent
- 2)
- "Default indentation to use for yaml-pro."
- :group 'yaml-pro
- :type 'integer)
-
-(defvar-local yaml-pro-buffer-tree nil)
-
-(defun yaml-pro--get-yaml-position (string)
- "Return the property `yaml-position' of STRING.
-This function is needed as the parser may insert unpropertized
-spacing before the match."
- (or (get-text-property 0 'yaml-position string)
- (get-text-property 0 'yaml-position (string-trim-left string "[ \n]*"))))
-
-(defun yaml-pro--offset-parse-tree (tree offset)
- "Offset all TREE values of `yaml-position' property by OFFSET."
- (cond
- ((or (listp tree) (vectorp tree))
- (seq-map
- (lambda (elt)
- (yaml-pro--offset-parse-tree elt offset))
- tree))
- ((stringp tree)
- (let* ((yaml-position (yaml-pro--get-yaml-position tree)))
- (when yaml-position
- (let ((offset-position (cons (+ (car yaml-position) offset)
- (+ (cdr yaml-position) offset))))
- (set-text-properties 0
- (length tree)
- (list 'yaml-position offset-position)
- tree)))))))
-
-(defun yaml-pro--use-fast-p ()
- "Return non nil if buffer size is larger than `yaml-pro-max-parse-size'."
- (>= (buffer-size) yaml-pro-max-parse-size))
-
-(defun yaml-pro--fast-parse-bounds (&optional point)
- "Return a list of the start and end point of subsection to parse.
-
-Find subsection based off of POINT if provided."
- (let* ((point-indent
- (save-excursion
- (beginning-of-line)
- (skip-chars-forward " ")
- (current-column)))
- (indent-regexp (make-string point-indent ?\s))
- (start-point)
- (end-point))
- (if (= point-indent 0)
- (setq start-point (point-min)
- end-point (point-max))
- (save-excursion
- (beginning-of-line)
- (while (not (or (bobp)
- (and (looking-at " *[a-zA-Z_0-9-]+:\\s-*$")
- (not (looking-at indent-regexp)))))
- (forward-line -1))
- (setq start-point (point)))
- (save-excursion
- (beginning-of-line)
- (while (not (or (eobp)
- (and (not (looking-at indent-regexp))
- (not (looking-at " *$")))))
- (forward-line 1))
- (setq end-point (point))))
- (list start-point end-point)))
-
-(defun yaml-pro--get-buffer-tree ()
- "Return the cached buffer-tree if exists, else regenerate it."
- (or yaml-pro-buffer-tree
- (if (not (yaml-pro--use-fast-p))
- (let ((tree (yaml-parse-tree (buffer-string))))
- (setq yaml-pro-buffer-tree tree)
- tree)
- (seq-let (start-point end-point) (yaml-pro--fast-parse-bounds)
- (let* ((subsection-string (buffer-substring start-point end-point))
- (tree (yaml-parse-tree subsection-string)))
- (yaml-pro--offset-parse-tree tree (1- start-point))
- (when (and (= start-point (point-min))
- (= end-point (point-max)))
- (setq yaml-pro-buffer-tree tree))
- tree)))))
-
-(defun yaml-pro--after-change-hook (_ _ _)
- "Delete cached tree on buffer change."
- (setq yaml-pro-buffer-tree nil))
-
-(defun yaml-pro--find-node (parse point)
- "Recursively look through PARSE to find scalar at POINT."
- (catch 'done
- (cond
- ((vectorp parse)
- (seq-do
- (lambda (item)
- (let ((res (yaml-pro--find-node item point)))
- (when res
- (throw 'done res))))
- parse)
- nil)
- ((listp parse)
- (dolist (item parse)
- (let ((res (yaml-pro--find-node (cdr item) point)))
- (when res
- (throw 'done res)))))
- ((stringp parse)
- (let* ((bounds (yaml-pro--get-yaml-position parse))
- (start (and bounds (car bounds)))
- (end (and bounds (cdr bounds))))
- (if (and start end (<= start point end))
- parse
- nil))))))
-
-(defun yaml-pro--fast-value-at-point ()
- "Return the scalar under the current point.
-
-This function uses a heuristic to limit the amount of parsing
-that has to be done."
-
- (seq-let (start-point end-point) (yaml-pro--fast-parse-bounds)
- (let* ((subsection-string (buffer-substring start-point end-point))
- (parse (yaml-parse-string-with-pos subsection-string))
- (val (yaml-pro--find-node parse (1+ (- (point) start-point)))))
- (when val
- (let* ((yaml-position (yaml-pro--get-yaml-position val))
- (new-position (cons (1- (+ (car yaml-position) start-point))
- (1- (+ (cdr yaml-position) start-point)))))
- (set-text-properties 0 (length val) (list 'yaml-position new-position) val)
- val)))))
-
-(defun yaml-pro--value-at-point ()
- "Return the scalar under the current point."
- (let* ((parse (yaml-parse-string-with-pos (buffer-string))))
- (yaml-pro--find-node parse (point))))
-
-(defun yaml-pro--get-parent-block* (tree point)
- "Return subtree from TREE that best contain POINT."
- (if (not (listp tree))
- nil
- (let ((sub-blocks
- (seq-filter #'identity
- (seq-map (lambda (st)
- (yaml-pro--get-parent-block* st point))
- tree))))
- (cond
- ((and sub-blocks
- (stringp (car tree))
- (let* ((bounds (yaml-pro--get-yaml-position (cadr tree)))
- (start (car bounds))
- (end (cdr bounds)))
- (and (numberp start) (<= start point end))))
- (let* ((bounds (yaml-pro--get-yaml-position (cadr tree)))
- (start (car bounds))
- (end (cdr bounds)))
- (throw 'result (list start end))))
- (sub-blocks
- (car sub-blocks))
- ((stringp (car tree))
- (let* ((bounds (yaml-pro--get-yaml-position (cadr tree)))
- (start (and bounds (car bounds)))
- (end (and bounds (cdr bounds))))
- (if (and (numberp start) (<= start point end))
- (list start end)
- nil)))
- (t nil)))))
-
-(defun yaml-pro-get-parent-block (tree point)
- "Return the nearest parent block in TREE to node in POINT."
- (catch 'result
- (yaml-pro--get-parent-block* tree point)))
-
-(defun yaml-pro-get-block-bounds (tree point)
- "Return subtree from TREE that best contain POINT."
- (if (not (listp tree))
- nil
- (let ((sub-blocks
- (seq-filter #'identity
- (seq-map (lambda (st) (yaml-pro-get-block-bounds st point))
- tree))))
- (cond
- (sub-blocks
- ;; TODO should find best match instead of firt (?)
- (car sub-blocks))
- ((and (stringp (car tree)) (not (equal (car tree) "")))
- (let* ((bounds (yaml-pro--get-yaml-position (cadr tree)))
- (start (and bounds (car bounds)))
- (end (and bounds (cdr bounds))))
- (if (and
- (numberp start)
- (<= start point end)
- (not (= (save-excursion
- (goto-char start) (beginning-of-line) (point))
- (save-excursion
- (goto-char end) (beginning-of-line) (point)))))
- (list start end)
- nil)))
- (t nil)))))
-
-(defun yaml-pro-get-block (tree point)
- "Return subtree from TREE that best contain POINT."
- (if (not (listp tree))
- nil
- (let ((sub-blocks
- (seq-filter #'identity
- (seq-map (lambda (st) (yaml-pro-get-block st point))
- tree))))
- (cond
- (sub-blocks
- ;; TODO should find best match instead of firt (?)
- (car sub-blocks))
- ((stringp (car tree))
- (let* ((bounds (yaml-pro--get-yaml-position (cadr tree)))
- (start (and bounds (car bounds)))
- (end (and bounds (cdr bounds))))
- (if (and (numberp start)
- (<= start point end)
- ;; hack to get small maps to not get selected
- (yaml-pro--fix-bounds (list start end)))
- (list start end)
- nil)))
- (t nil)))))
-
-(defun yaml-pro--fix-bounds (bounds)
- "Adjust BOUNDS to proper fold points."
- (seq-let (beg end) bounds
- (save-excursion
- (goto-char beg)
- (cond
- ((looking-at-p "[ \t]*-")
- (setq beg (1- (point))))
- ((and (not (looking-at "{"))
- (not (looking-at "\\[")))
- (end-of-line)
- (setq beg (point)))
- ((looking-at-p "\\(\\[\\|{\\)")
- (setq beg (1+ (point))))))
- (save-excursion
- (goto-char end)
- (cond
- ((looking-back "\n" (- (point) 2))
- (setq end (1- end)))
- ((looking-back "\\(\\]\\|\\}\\)" (- (point) 2))
- (setq end (1- end)))))
- (if (>= beg end)
- nil
- (list beg end))))
-
-(defun yaml-pro--search-location (tree point path)
- "Return path up to POINT of TREE having visited at PATH."
- (cond
- ((stringp tree)
- (let ((pos (yaml-pro--get-yaml-position tree)))
- (when (<= (car pos) point (cdr pos))
- path)))
- (t
- (seq-find #'identity
- (seq-map
- (lambda (tuple)
- (let* ((key (car tuple))
- (key-pos (and (stringp key)
- (yaml-pro--get-yaml-position key)))
- (val (cdr tuple))
- (val-pos (and (stringp val)
- (yaml-pro--get-yaml-position val))))
- (cond
- ((and key-pos (<= (car key-pos) point (cdr key-pos)))
- path)
- ((and val-pos (<= (car val-pos) point (cdr val-pos)))
- (cons key path))
- ((vectorp val)
- (catch 'found
- (dotimes (i (length val))
- (let* ((elt (aref val i))
- (res (yaml-pro--search-location
- elt
- point
- (cons (number-to-string i)
- (cons key path)))))
- (when res
- (throw 'found res))))
- nil))
- ((listp val)
- (yaml-pro--search-location val point (cons key path)))
- (t nil))))
- tree)))))
-
-(defun yaml-pro--path-at-point ()
- "Return the object path to current point.
-
-NOTE: This is an experimental feature."
- ;; first look for current position
- (let* ((parse (yaml-parse-string-with-pos (buffer-string)))
- (path (yaml-pro--search-location parse (point) '())))
- (seq-map
- (lambda (s)
- (set-text-properties 0 (length s) nil s)
- s)
- (or (nreverse path)
- ;; if not found, go back before ":" and try again
- (save-excursion
- (when (looking-back "[ \"a-zA-Z_-]+: +[ \"a-zA-Z_-]+" (- (point) 60))
- (beginning-of-line)
- (skip-chars-forward " ")
- (let ((path (yaml-pro--search-location parse (point) '())))
- (nreverse path))))))))
-
-(defun yaml-pro--flatten-tree (tree)
- "Return a \"flattened\" copy of TREE. Copied from Emacs 27.1."
- (let (elems)
- (while (consp tree)
- (let ((elem (pop tree)))
- (while (consp elem)
- (push (cdr elem) tree)
- (setq elem (car elem)))
- (if elem (push elem elems))))
- (if tree (push tree elems))
- (nreverse elems)))
-
-(defun yaml-pro--extract-paths (tree &optional path)
- "Given TREE of parse, return all paths of tree to leaf nodes.
-
-PATH is the current path we have already traversed down."
- (cond
- ((listp tree)
- (yaml-pro--flatten-tree
- (seq-map (lambda (key+val)
- (yaml-pro--extract-paths (cdr key+val)
- (append path (list (car key+val)))))
- tree)))
- ((vectorp tree)
- (yaml-pro--flatten-tree
- (seq-mapn
- (lambda (n val)
- (yaml-pro--extract-paths val (append path (list (format "[%d]" n)))))
- (number-sequence 0 (1- (length tree)))
- tree)))
- (t (concat (string-join path " ") ": " tree))))
-
-(defun yaml-pro-hide-overlay (ov)
- "Put fold-related properties on overlay OV."
- (overlay-put ov 'invisible 'yaml-pro)
- (overlay-put ov 'display "...")
- (overlay-put ov 'face 'yaml-pro-fold-replacement-face))
-
-(defun yaml-pro-show-overlay (ov)
- "Remove fold-related properties of overlay OV."
- (overlay-put ov 'invisible nil)
- (overlay-put ov 'display nil)
- (overlay-put ov 'face nil))
-
-(defun yaml-pro--get-last-yaml-pos (str)
- "Return the last-most text-property `yaml-position' of STR."
- (let ((i (1- (length str)))
- (pos))
- (while (or (not pos) (< i 0))
- (let ((at-pos (get-text-property i 'yaml-position str)))
- (when at-pos
- (setq pos at-pos))
- (cl-decf i)))
- pos))
-
-(defun yaml-pro-jump ()
- "Jump to a specified path."
- (interactive)
- (let* ((tree (yaml-parse-string-with-pos (buffer-string)))
- (paths (yaml-pro--extract-paths tree))
- (selected (completing-read "Jump to: " paths nil t))
- ;; get original string which has properties intact
- (original-str (seq-find (lambda (s) (string= s selected)) paths))
- (pos (yaml-pro--get-last-yaml-pos original-str)))
- (goto-char (car pos))))
-
-(declare-function consult--read "consult")
-(declare-function consult--overlay "consult")
-(declare-function consult--invisible-open-temporarily "consult")
-
-(defun yaml-pro--consult-jump-preview ()
- "Return a consult function for displaying current selection."
- (let ((invisible)
- (overlays)
- (saved-pos (point-marker))
- (saved-min (point-min-marker))
- (saved-max (point-max-marker)))
- (lambda (cand restore)
- (mapc #'funcall invisible)
- (mapc #'delete-overlay overlays)
- (cond
- (restore
- (let ((saved-buffer (marker-buffer saved-pos)))
- (set-buffer saved-buffer)
- (narrow-to-region saved-min saved-max)
- (goto-char saved-pos)))
- (cand
- (let ((pos (and (not (string-blank-p cand))
- (yaml-pro--get-last-yaml-pos cand))))
- (when pos
- (widen)
- (goto-char (car pos))
- (run-hooks 'consult-after-jump-hook)
- (setq invisible (consult--invisible-open-temporarily)
- overlays
- (list (consult--overlay (car pos) (cdr pos)
- 'face 'consult-preview-cursor
- 'window (selected-window)))))))))))
-
-;;; Interactive commands
-
-(defun yaml-pro-consult-jump ()
- "Jump to a specified path."
- (interactive)
- (let* ((tree (yaml-parse-string-with-pos (buffer-string)))
- (paths (yaml-pro--extract-paths tree))
- (sorted-paths (seq-sort-by (lambda (path)
- (car (yaml-pro--get-last-yaml-pos path)))
- #'< paths))
- (selected (consult--read
- sorted-paths
- :prompt "Jump to: "
- :history 'yaml-pro-jump
- :require-match t
- :sort nil
- :state (let ((preview (yaml-pro--consult-jump-preview)))
- (lambda (str restore)
- (funcall preview str restore)))))
- (original-str (seq-find (lambda (s) (string= s selected)) paths)))
- (goto-char (car (yaml-pro--get-last-yaml-pos original-str)))))
-
-(defun yaml-pro-fold-at-point ()
- "Fold YAML at point."
- (interactive)
- (save-excursion
- (skip-syntax-forward " " (line-end-position))
- (let ((parse-tree (yaml-pro--get-buffer-tree)))
- (let* ((bounds (yaml-pro--fix-bounds
- (yaml-pro-get-block parse-tree (point))))
- (beg (car bounds))
- (end (cadr bounds)))
- (when bounds
- ;; Delete all inner folds before creating outer one
- (let ((ovs (overlays-in beg end)))
- (dolist (ov ovs)
- (when (eql (overlay-get ov 'creator) 'yaml-pro)
- (delete-overlay ov))))
- (let ((ov (make-overlay beg end)))
- (overlay-put ov 'creator 'yaml-pro)
- (overlay-put ov 'invisible 'yaml-pro)
- (overlay-put ov 'isearch-open-invisible 'yaml-pro-isearch-show)
- (overlay-put ov 'isearch-open-invisible-temporary
- (lambda (ov hide-p)
- (if hide-p (yaml-pro-hide-overlay ov)
- (yaml-pro-show-overlay ov))))
- (overlay-put ov 'display "...")
- (overlay-put ov 'face 'yaml-pro-fold-replacement-face)))))))
-
-(defun yaml-pro-unfold-at-point ()
- "Unfold YAML at point."
- (interactive)
- (save-excursion
- (cond
- ((looking-at ".*:")
- (let ((ovs (overlays-in (point)
- (save-excursion (end-of-line) (1+ (point))))))
- (dolist (ov ovs)
- (when (eql (overlay-get ov 'creator) 'yaml-pro)
- (delete-overlay ov)))))
- (t
- (let ((ovs (overlays-at (1+ (point)))))
- (dolist (ov ovs)
- (when (eql (overlay-get ov 'creator) 'yaml-pro)
- (delete-overlay ov))))))))
-
-(defun yaml-pro-up-level ()
- "Move the point to the parent tree."
- (interactive)
- (if (and (bolp) (not (looking-at "[ \n\t#]")))
- (goto-char (point-min))
- (let* ((start (point))
- (parse-tree (yaml-pro--get-buffer-tree))
- (bounds (yaml-pro-get-block-bounds parse-tree (point))))
- (goto-char (car bounds))
- (when (= start (point))
- (let* ((parse-tree (yaml-pro--get-buffer-tree))
- (bounds (yaml-pro-get-parent-block parse-tree (point))))
- (goto-char (car bounds))
- (when (= start (point))
- ;; the block we're at and it's parent have the same start,
- ;; move back one char and try again
- (forward-char -1)
- (yaml-pro-up-level))))
- (when (and (bolp) (looking-at "[ \t]"))
- ;; Don't let the command end at a block that begins a line
- (yaml-pro-up-level)))))
-
-(defun yaml-pro-kill-subtree ()
- "Kill the entire subtree located at the current point."
- (interactive)
- (let* ((parse-tree (yaml-pro--get-buffer-tree))
- (bounds (yaml-pro-get-block-bounds parse-tree (point)))
- (start (car bounds))
- (end (cadr bounds)))
- (when (save-excursion
- (goto-char end)
- (looking-back "\n" (- (point) 2)))
- (setq end (1- end)))
- (kill-region start end)))
-
-(defun yaml-pro-prev-subtree ()
- "Move the point to the previous sibling subtree."
- (interactive)
- (let* ((start-pos (point))
- (parse-tree (yaml-pro--get-buffer-tree))
- (at-bounds (yaml-pro-get-block-bounds parse-tree (point))))
- (goto-char (car at-bounds))
- (let ((at-col (current-column))
- (at-dash-p (looking-at "-")))
- (catch 'done
- (while (not (bobp))
- (forward-line -1)
- (while (looking-at "[ \n]*$")
- (forward-line -1))
- (if at-dash-p
- (skip-chars-forward " \n")
- (skip-chars-forward " \n-"))
- (when (and (< (current-column) at-col)
- (not (looking-at "#")))
- (goto-char start-pos)
- (ding)
- (throw 'done nil))
- (when (and (= (current-column) at-col)
- (not (looking-at "#")))
- (throw 'done t)))
- (if (looking-at "#")
- (progn
- (goto-char start-pos)
- (ding)
- nil)
- t)))))
-
-(defun yaml-pro-next-subtree ()
- "Move the point to the next sibling subtree."
- (interactive)
- (let* ((start-pos (point))
- (start-col (current-column))
- (parse-tree (yaml-pro--get-buffer-tree))
- (at-bounds (yaml-pro-get-block-bounds parse-tree (point))))
- (goto-char (cadr at-bounds))
- (skip-chars-forward " \n")
- (if (or (not (= start-col (current-column)))
- (eobp))
- (progn
- (ding)
- (goto-char start-pos)
- nil)
- t)))
-
-(defun yaml-pro-indent-subtree ()
- "Indent the current subtree by one level.
-
-Indentation is controlled by the variable `yaml-pro-indent'."
- (interactive)
- (save-excursion
- (back-to-indentation)
- (let* ((parse-tree (yaml-pro--get-buffer-tree))
- (at-bounds (yaml-pro-get-block-bounds parse-tree (point))))
- (goto-char (car at-bounds))
- (if (not (looking-back "^[ ]*" nil))
- (progn
- (forward-line 0)
- (skip-chars-forward " ")
- (yaml-pro-indent-subtree))
- (let ((beginning-line (line-number-at-pos)))
- (goto-char (cadr at-bounds))
- (when (looking-back "\n" (- (point) 2))
- (forward-char -1))
- (forward-line 0)
- (while (>= (line-number-at-pos) beginning-line)
- (insert (make-string yaml-pro-indent ?\s))
- (forward-line -1)))))))
-
-(defun yaml-pro-unindent-subtree ()
- "Unindent the current subtree by one level.
-
-Indentation is controlled by the variable `yaml-pro-indent'."
- (interactive)
- (let* ((parse-tree (yaml-pro--get-buffer-tree))
- (at-bounds (yaml-pro-get-block-bounds parse-tree (point))))
- (save-excursion
- (goto-char (car at-bounds))
- ;; ensure that the subtree can be unintented
- (save-excursion
- (forward-line 0)
- (unless (looking-at-p (make-string yaml-pro-indent ?\s))
- (error "Subtree can't be unintented further")))
- (if (not (looking-back "^[ ]*" nil))
- (progn
- (forward-line 0)
- (skip-chars-forward " ")
- (yaml-pro-indent-subtree))
- (let ((beginning-line (line-number-at-pos)))
- (goto-char (cadr at-bounds))
- (when (looking-back "\n" (- (point) 2))
- (forward-char -1))
- (forward-line 0)
- (while (>= (line-number-at-pos) beginning-line)
- (when (looking-at-p (make-string yaml-pro-indent ?\s))
- (delete-char yaml-pro-indent))
- (forward-line -1)))))))
-
-(defun yaml-pro-move-subtree-up ()
- "Swap the current subtree with the previous one."
- (interactive)
- (let* ((parse-tree (yaml-pro--get-buffer-tree))
- (at-bounds (yaml-pro-get-block-bounds parse-tree (point)))
- (at-contents (buffer-substring (car at-bounds) (cadr at-bounds)))
- (prev-bounds (save-excursion
- (let ((ok (yaml-pro-prev-subtree)))
- (and ok (yaml-pro-get-block-bounds parse-tree
- (point))))))
- (prev-contents (and prev-bounds
- (buffer-substring (car prev-bounds)
- (cadr prev-bounds)))))
- (when (not prev-bounds)
- (error "Can't move subtree"))
- (goto-char (car at-bounds))
- (delete-region (car at-bounds) (cadr at-bounds))
- (insert prev-contents)
- (goto-char (car prev-bounds))
- (delete-region (car prev-bounds) (cadr prev-bounds))
- (insert at-contents)
- (goto-char (car prev-bounds))))
-
-(defun yaml-pro-move-subtree-down ()
- "Swap the current subtree with the previous one."
- (interactive)
- (yaml-pro-next-subtree)
- (yaml-pro-move-subtree-up)
- (yaml-pro-next-subtree))
-
-(defun yaml-pro-create-index ()
- "Create an imenu index using the legacy parser."
- (let* ((tree (yaml-parse-string-with-pos (buffer-string)))
- (paths (yaml-pro--extract-paths tree))
- (sorted-paths (seq-sort-by (lambda (path)
- (car (yaml-pro--get-last-yaml-pos path)))
- #'< paths)))
- (seq-map
- (lambda (item)
- (let ((pos (car (yaml-pro--get-last-yaml-pos item))))
- (cons item pos)))
- sorted-paths)))
-
-(defconst yaml-pro-mode-map
- (let ((map (make-sparse-keymap)))
- (prog1 map
- (define-key map (kbd "C-c C-x C-w") #'yaml-pro-kill-subtree)
-
- (define-key map (kbd "C-c C-u") #'yaml-pro-up-level)
-
- (define-key map (kbd "C-c C-p") #'yaml-pro-prev-subtree)
- (define-key map (kbd "C-c C-n") #'yaml-pro-next-subtree)
-
- (define-key map (kbd "C-c C-f") #'yaml-pro-fold-at-point)
- (define-key map (kbd "C-c C-o") #'yaml-pro-unfold-at-point)
-
- (define-key map (kbd "s-<up>") #'yaml-pro-move-subtree-up)
- (define-key map (kbd "s-<down>") #'yaml-pro-move-subtree-down)
-
- (define-key map (kbd "C-c '") #'yaml-pro-edit-scalar)
-
- (define-key map (kbd "C-c >") #'yaml-pro-indent-subtree)
-
- (define-key map (kbd "C-c <") #'yaml-pro-unindent-subtree)
-
- (define-key map (kbd "C-c C-j") (if (featurep 'consult)
- #'yaml-pro-consult-jump
- #'yaml-pro-jump)))))
-
-(make-obsolete 'yaml-pro-consult-jump "Use imenu feature instead of this command." "0.3.2")
-
-(defconst yaml-pro-required-yaml-parser-version "0.5.1")
-
-;;;###autoload
-(define-minor-mode yaml-pro-mode
- "Binds additional functions to aid in editing YAML files.
-
-\\{yaml-pro-mode-map}"
- :init-value nil
- :group 'yaml-pro
- :keymap yaml-pro-mode-map
- (if yaml-pro-mode
- (progn
- (when (or (not (boundp 'yaml-parser-version))
- (not yaml-parser-version)
- (version< yaml-parser-version
- yaml-pro-required-yaml-parser-version))
- (error "Unsupported yaml.el version. \
-Ensure that yaml.el package installed and at version %s"
- yaml-pro-required-yaml-parser-version))
- (setq imenu-generic-expression nil)
- (setq imenu-create-index-function #'yaml-pro-create-index)
- (when (equal mode-name "YAML")
- (add-hook 'after-change-functions #'yaml-pro--after-change-hook nil t)))
- (remove-hook 'after-change-functions #'yaml-pro--after-change-hook t)))
-
-(provide 'yaml-pro)
-
-;;; yaml-pro.el ends here
projects / emacsconfig.git / commitdiff