From 184661a1a3219eb148e1e3924dc1c91972c251dc Mon Sep 17 00:00:00 2001 From: Andreas Gerler Date: Wed, 5 Feb 2025 17:13:31 +0100 Subject: [PATCH] install yaml-pro-mode Signed-off-by: Andreas Gerler --- bba-programming.org | 8 + .../yaml-pro-autoloads.el | 83 + elpa/yaml-pro-20241223.1723/yaml-pro-edit.el | 487 ++++++ .../yaml-pro-20241223.1723/yaml-pro-format.el | 840 +++++++++ elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el | 9 + elpa/yaml-pro-20241223.1723/yaml-pro.el | 1532 +++++++++++++++++ 6 files changed, 2959 insertions(+) create mode 100644 elpa/yaml-pro-20241223.1723/yaml-pro-autoloads.el create mode 100644 elpa/yaml-pro-20241223.1723/yaml-pro-edit.el create mode 100644 elpa/yaml-pro-20241223.1723/yaml-pro-format.el create mode 100644 elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el create mode 100644 elpa/yaml-pro-20241223.1723/yaml-pro.el diff --git a/bba-programming.org b/bba-programming.org index 3503d4c8..840f6c56 100644 --- a/bba-programming.org +++ b/bba-programming.org @@ -302,6 +302,12 @@ Vagrant files are Ruby, so use ruby-mode for them: 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) @@ -312,6 +318,8 @@ Adjust indentation at work. (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))) diff --git a/elpa/yaml-pro-20241223.1723/yaml-pro-autoloads.el b/elpa/yaml-pro-20241223.1723/yaml-pro-autoloads.el new file mode 100644 index 00000000..cb8a7dce --- /dev/null +++ b/elpa/yaml-pro-20241223.1723/yaml-pro-autoloads.el @@ -0,0 +1,83 @@ +;;; 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))) + + + +;;; 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-")) + + +;;; 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-")) + + +;;; Generated autoloads from yaml-pro-format.el + +(register-definition-prefixes "yaml-pro-format" '("yaml-pro-format")) + +;;; 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 diff --git a/elpa/yaml-pro-20241223.1723/yaml-pro-edit.el b/elpa/yaml-pro-20241223.1723/yaml-pro-edit.el new file mode 100644 index 00000000..3368ea72 --- /dev/null +++ b/elpa/yaml-pro-20241223.1723/yaml-pro-edit.el @@ -0,0 +1,487 @@ +;;; 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 . + +;;; 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 diff --git a/elpa/yaml-pro-20241223.1723/yaml-pro-format.el b/elpa/yaml-pro-20241223.1723/yaml-pro-format.el new file mode 100644 index 00000000..58c89ee3 --- /dev/null +++ b/elpa/yaml-pro-20241223.1723/yaml-pro-format.el @@ -0,0 +1,840 @@ +;;; 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 . + +;;; 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 diff --git a/elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el b/elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el new file mode 100644 index 00000000..b99cf216 --- /dev/null +++ b/elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el @@ -0,0 +1,9 @@ +;; -*- 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")) diff --git a/elpa/yaml-pro-20241223.1723/yaml-pro.el b/elpa/yaml-pro-20241223.1723/yaml-pro.el new file mode 100644 index 00000000..8b78505a --- /dev/null +++ b/elpa/yaml-pro-20241223.1723/yaml-pro.el @@ -0,0 +1,1532 @@ +;;; 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 . + + +;;; 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-") #'yaml-pro-ts-move-subtree-up) + (define-key map (kbd "s-") #'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-") #'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)))) + + +;;; 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-") #'yaml-pro-move-subtree-up) + (define-key map (kbd "s-") #'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 -- 2.47.3