From: Andreas Gerler Date: Thu, 6 Feb 2025 14:40:05 +0000 (+0100) Subject: Revert "install yaml-pro-mode" X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=7fdd7d9654c732831c5d4bc23863e794044727c6;p=emacsconfig.git Revert "install yaml-pro-mode" This reverts commit 184661a1a3219eb148e1e3924dc1c91972c251dc. yaml-pro crashes emacs --- diff --git a/bba-programming.org b/bba-programming.org index 840f6c56..3503d4c8 100644 --- a/bba-programming.org +++ b/bba-programming.org @@ -302,12 +302,6 @@ 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) @@ -318,8 +312,6 @@ requires (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 deleted file mode 100644 index cb8a7dce..00000000 --- a/elpa/yaml-pro-20241223.1723/yaml-pro-autoloads.el +++ /dev/null @@ -1,83 +0,0 @@ -;;; 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 deleted file mode 100644 index 3368ea72..00000000 --- a/elpa/yaml-pro-20241223.1723/yaml-pro-edit.el +++ /dev/null @@ -1,487 +0,0 @@ -;;; 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 deleted file mode 100644 index 58c89ee3..00000000 --- a/elpa/yaml-pro-20241223.1723/yaml-pro-format.el +++ /dev/null @@ -1,840 +0,0 @@ -;;; 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 deleted file mode 100644 index b99cf216..00000000 --- a/elpa/yaml-pro-20241223.1723/yaml-pro-pkg.el +++ /dev/null @@ -1,9 +0,0 @@ -;; -*- 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 deleted file mode 100644 index 8b78505a..00000000 --- a/elpa/yaml-pro-20241223.1723/yaml-pro.el +++ /dev/null @@ -1,1532 +0,0 @@ -;;; 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