From 215097dbdb81e2d50603f77e96a1e486619c64e2 Mon Sep 17 00:00:00 2001 From: liding Date: Tue, 26 Aug 2025 18:12:39 +0800 Subject: [PATCH] Remove unused parts and reorganize config files. --- .gitmodules | 27 - site-lisp/extensions-local/company-ctags.el | 95 +- .../extensions-local/dired-display-buffer.el | 87 - .../extensions-local/dired-hacks-utils.el | 273 - site-lisp/extensions-local/dired-narrow.el | 356 - site-lisp/extensions-local/dired-subtree.el | 784 -- site-lisp/extensions-local/force-indent.el | 12 +- .../extensions-local/goto-last-change.el | 141 - .../extensions-local/goto-line-preview.el | 4 +- site-lisp/extensions-local/jsonian.el | 2272 ++++ site-lisp/extensions-local/ld-delete-block.el | 38 - ...ns.el => ld-file-and-buffer-operations.el} | 15 + .../extensions-local/ld-file-operations.el | 14 - .../extensions-local/ld-goto-cursor-stack.el | 39 - .../extensions-local/ld-toggle-one-window.el | 22 - site-lisp/extensions-local/markdown-mode.el | 10422 ++++++++++++++++ site-lisp/extensions-local/neotree.el | 2228 ---- site-lisp/extensions-local/outline-toc.el | 361 + ...xt-window.el => scroll-adjacent-window.el} | 37 +- site-lisp/extensions-local/undo-tree.el | 34 +- site-lisp/extensions-submodule/ace-window | 1 - site-lisp/extensions-submodule/avy | 2 +- site-lisp/extensions-submodule/citre | 2 +- site-lisp/extensions-submodule/company-mode | 2 +- site-lisp/extensions-submodule/dash.el | 1 - .../extensions-submodule/emacs-which-key | 1 - site-lisp/extensions-submodule/go-mode.el | 1 - site-lisp/extensions-submodule/jsonian | 1 - site-lisp/extensions-submodule/lua-mode | 1 - site-lisp/extensions-submodule/markdown-mode | 1 - site-lisp/extensions-submodule/modus-themes | 1 - .../extensions-submodule/multiple-cursors.el | 2 +- site-lisp/extensions-submodule/swiper | 1 - site-lisp/extensions-submodule/web-mode | 2 +- site-lisp/extensions-submodule/yasnippet | 2 +- site-lisp/init-config/init-ace-window.el | 10 - site-lisp/init-config/init-company-mode.el | 10 + site-lisp/init-config/init-dired.el | 14 - site-lisp/init-config/init-font.el | 16 + site-lisp/init-config/init-mode.el | 50 +- site-lisp/init-config/init-neotree.el | 12 - site-lisp/init-config/init-shortcut.el | 174 +- site-lisp/init-config/init-swiper.el | 34 - site-lisp/init-config/init-theme.el | 11 - site-lisp/init-config/init-which-key.el | 1 - site-lisp/init-config/init.el | 9 +- site-start.el | 18 +- 47 files changed, 13301 insertions(+), 4340 deletions(-) delete mode 100644 site-lisp/extensions-local/dired-display-buffer.el delete mode 100644 site-lisp/extensions-local/dired-hacks-utils.el delete mode 100644 site-lisp/extensions-local/dired-narrow.el delete mode 100644 site-lisp/extensions-local/dired-subtree.el delete mode 100644 site-lisp/extensions-local/goto-last-change.el create mode 100644 site-lisp/extensions-local/jsonian.el delete mode 100644 site-lisp/extensions-local/ld-delete-block.el rename site-lisp/extensions-local/{ld-buffer-operations.el => ld-file-and-buffer-operations.el} (81%) delete mode 100644 site-lisp/extensions-local/ld-file-operations.el delete mode 100644 site-lisp/extensions-local/ld-goto-cursor-stack.el delete mode 100644 site-lisp/extensions-local/ld-toggle-one-window.el create mode 100644 site-lisp/extensions-local/markdown-mode.el delete mode 100644 site-lisp/extensions-local/neotree.el create mode 100644 site-lisp/extensions-local/outline-toc.el rename site-lisp/extensions-local/{scroll-next-window.el => scroll-adjacent-window.el} (50%) delete mode 160000 site-lisp/extensions-submodule/ace-window delete mode 160000 site-lisp/extensions-submodule/dash.el delete mode 160000 site-lisp/extensions-submodule/emacs-which-key delete mode 160000 site-lisp/extensions-submodule/go-mode.el delete mode 160000 site-lisp/extensions-submodule/jsonian delete mode 160000 site-lisp/extensions-submodule/lua-mode delete mode 160000 site-lisp/extensions-submodule/markdown-mode delete mode 160000 site-lisp/extensions-submodule/modus-themes delete mode 160000 site-lisp/extensions-submodule/swiper delete mode 100644 site-lisp/init-config/init-ace-window.el create mode 100644 site-lisp/init-config/init-font.el delete mode 100644 site-lisp/init-config/init-neotree.el delete mode 100644 site-lisp/init-config/init-swiper.el diff --git a/.gitmodules b/.gitmodules index a074062..b393a6b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,33 +1,6 @@ -[submodule "site-lisp/extensions-submodule/go-mode.el"] - path = site-lisp/extensions-submodule/go-mode.el - url = git@github.com:dominikh/go-mode.el.git -[submodule "site-lisp/extensions-submodule/jsonian"] - path = site-lisp/extensions-submodule/jsonian - url = git@github.com:iwahbe/jsonian.git -[submodule "site-lisp/extensions-submodule/ace-window"] - path = site-lisp/extensions-submodule/ace-window - url = git@github.com:abo-abo/ace-window.git -[submodule "site-lisp/extensions-submodule/dash.el"] - path = site-lisp/extensions-submodule/dash.el - url = git@github.com:magnars/dash.el.git [submodule "site-lisp/extensions-submodule/avy"] path = site-lisp/extensions-submodule/avy url = git@github.com:abo-abo/avy.git -[submodule "site-lisp/extensions-submodule/emacs-which-key"] - path = site-lisp/extensions-submodule/emacs-which-key - url = git@github.com:justbur/emacs-which-key.git -[submodule "site-lisp/extensions-submodule/lua-mode"] - path = site-lisp/extensions-submodule/lua-mode - url = git@github.com:immerrr/lua-mode.git -[submodule "site-lisp/extensions-submodule/markdown-mode"] - path = site-lisp/extensions-submodule/markdown-mode - url = git@github.com:jrblevin/markdown-mode.git -[submodule "site-lisp/extensions-submodule/modus-themes"] - path = site-lisp/extensions-submodule/modus-themes - url = git@github.com:protesilaos/modus-themes.git -[submodule "site-lisp/extensions-submodule/swiper"] - path = site-lisp/extensions-submodule/swiper - url = git@github.com:abo-abo/swiper.git [submodule "site-lisp/extensions-submodule/web-mode"] path = site-lisp/extensions-submodule/web-mode url = git@github.com:fxbois/web-mode.git diff --git a/site-lisp/extensions-local/company-ctags.el b/site-lisp/extensions-local/company-ctags.el index 2969402..72cece9 100644 --- a/site-lisp/extensions-local/company-ctags.el +++ b/site-lisp/extensions-local/company-ctags.el @@ -1,12 +1,12 @@ ;;; company-ctags.el --- Fastest company-mode completion backend for ctags -*- lexical-binding: t -*- -;; Copyright (C) 2019,2020 Chen Bin +;; Copyright (C) 2019-2024 Chen Bin ;; Author: Chen Bin ;; URL: https://github.com/redguardtoo/company-ctags -;; Version: 0.0.7 +;; Version: 0.1.1 ;; Keywords: convenience -;; Package-Requires: ((emacs "25.1") (company "0.9.0")) +;; Package-Requires: ((emacs "27.1") (company "0.9.0")) ;; This file is NOT part of GNU Emacs. @@ -90,8 +90,7 @@ buffer automatically." (defcustom company-ctags-ignore-case nil "Non-nil to ignore case in completion candidates." - :type 'boolean - :package-version '(company . "0.7.3")) + :type 'boolean) (defcustom company-ctags-extra-tags-files nil "List of extra tags files which are loaded only once. @@ -120,16 +119,15 @@ Set it to t or to a list of major modes." :type '(choice (const :tag "Off" nil) (const :tag "Any supported mode" t) (repeat :tag "Some major modes" - (symbol :tag "Major mode"))) - :package-version '(company . "0.9.0")) + (symbol :tag "Major mode")))) (defcustom company-ctags-check-tags-file-interval 30 "The interval (seconds) to check tags file. Default value is 30 seconds." :type 'integer) -(defcustom company-ctags-tags-file-name "TAGS" - "The name of tags file." +(defcustom company-ctags-tags-file-name '("tags" "TAGS") + "The name or name list of tags file." :type 'string) (defcustom company-ctags-tag-name-valid-characters @@ -163,25 +161,25 @@ the candidate." (defvar company-ctags-tags-file-caches nil "The cached tags files.") +(defvar company-ctags-debug nil + "Enable debug logging") + (defvar company-ctags-cached-candidates nil "The cached candidates searched with certain prefix.") -(defconst company-ctags-fast-pattern - "\177\\([^\177\001\n]+\\)\001" - "Pattern to extract tag name created by Ctags only.") - -(defconst company-ctags-slow-pattern - "\\([^\f\t\n\r()=,; ]*\\)[\f\t\n\r()=,; ]*\177\\\(?:\\([^\n\001]+\\)\001\\)?" - "Pattern to extract tag name created by Ctags/Etags.") - (defun company-ctags-find-table () "Find tags file." - (let* ((file (expand-file-name - company-ctags-tags-file-name - (locate-dominating-file (or buffer-file-name - default-directory) - company-ctags-tags-file-name)))) - (when (and file (file-regular-p file)) + (let* ((file-name company-ctags-tags-file-name) + (file-names (if (stringp file-name) (list file-name) file-name)) + file) + (when (cl-find-if (lambda (fn) + (setq file (expand-file-name + fn + (locate-dominating-file (or buffer-file-name + default-directory) + fn))) + (and file (file-regular-p file))) + file-names) (list file)))) (defun company-ctags-buffer-table () @@ -252,20 +250,27 @@ the candidate." (setq i (1+ i))) dict)) -(defun company-ctags-parse-tags (text &optional dict) - "Extract tag names from TEXT. +(defun company-ctags-parse-tags (text emacs-tags-file-p &optional dict) + "Extract tag names from TEXT of tags file. +If EMACS-TAGS-FILE-P is t, the tags file in Emacs format. Or else Vim format. DICT is the existing lookup dictionary contains tag names. If it's nil, return a dictionary, or else return the existing dictionary." (let* ((start 0) + (emacs-regex "\177\\([^\177\001\n]+\\)\001") + (etags-regex "\\([^\f\t\n\r()=,; ]*\\)[\f\t\n\r()=,; ]*\177\\\(?:\\([^\n\001]+\\)\001\\)?") + (vim-regex "^\\([^!\f\t\n\r()=,; ]+\\)\t\\(.+\\)$") (case-fold-search company-ctags-ignore-case)) + + (when company-ctags-debug (message "company-ctags-parse-tags called")) (unless dict (setq dict (company-ctags-init-tagname-dict))) ;; Code inside the loop should be optimized. ;; Please avoid calling lisp function inside the loop. (cond - (company-ctags-support-etags + ;; tags file is in emacs format with support on some legacy stuff + ((and company-ctags-support-etags emacs-tags-file-p) ;; slow algorithm, need support both explicit and implicit tags name - (while (string-match company-ctags-slow-pattern text start) + (while (string-match etags-regex text start) (cond ((match-beginning 2) ;; There is an explicit tag name. @@ -277,12 +282,21 @@ If it's nil, return a dictionary, or else return the existing dictionary." (company-ctags-push-tagname (substring text (match-beginning 1) (match-end 1)) dict))) (setq start (+ 4 (match-end 0))))) - (t + + ;; tags file is in emacs format + (emacs-tags-file-p ;; fast algorithm, support explicit tags name only - (while (string-match company-ctags-fast-pattern text start) + (while (string-match emacs-regex text start) (company-ctags-push-tagname (substring text (match-beginning 1) (match-end 1)) dict) - (setq start (+ 4 (match-end 0)))))) + (setq start (+ 4 (match-end 0))))) + + ;; tags file is in vim format + (t + (while (string-match vim-regex text start) + (company-ctags-push-tagname (substring text (match-beginning 1) (match-end 1)) + dict) + (setq start (match-end 2))))) dict)) @@ -330,8 +344,13 @@ If `company-ctags-fuzzy-match-p' is t, check if the match contains STRING." (t (company-ctags-fetch-by-first-char (elt prefix 0) prefix tagname-dict)))) +(defun company-ctags-check-tags-file-format (content) + "Check tags file's format by analyzing CONTENT." + ;; Emacs tags file has character "Form Feed" + (string-match-p "\014" content)) + (defun company-ctags-load-tags-file (file static-p &optional force no-diff-prog) - "Load tags from FILE. + "Load tags from FILE. Tags file generated by Emacs and Vim is supported. If STATIC-P is t, the corresponding tags file is read only once. If FORCE is t, tags file is read without `company-ctags-tags-file-caches'. If NO-DIFF-PROG is t, do NOT use diff on tags file. @@ -343,6 +362,7 @@ This function return t if any tag file is reloaded." file-info (plist-get file-info :raw-content) (executable-find diff-command))) + emacs-tags-file-p tagname-dict reloaded) @@ -381,15 +401,20 @@ This function return t if any tag file is reloaded." ;; should be merged with old tag names (setq tagname-dict (company-ctags-parse-tags diff-output + (plist-get file-info :emacs-tags-file-p) (plist-get file-info :tagname-dict))))) (t (unless company-ctags-quiet (message "Please be patient when loading %s" file)) (setq raw-content (with-temp-buffer (insert-file-contents file) (buffer-string))) + (setq emacs-tags-file-p (company-ctags-check-tags-file-format raw-content)) ;; collect all tag names - (setq tagname-dict (company-ctags-parse-tags raw-content)) - (unless company-ctags-quiet (message "%s is loaded." file)))) + (setq tagname-dict (company-ctags-parse-tags raw-content emacs-tags-file-p)) + (unless company-ctags-quiet + (message "%s with %s format is loaded." + file + (if emacs-tags-file-p "Emacs" "Vim"))))) ;; initialize hash table if needed (unless company-ctags-tags-file-caches @@ -403,6 +428,7 @@ This function return t if any tag file is reloaded." (list :raw-content (unless static-p raw-content) :tagname-dict tagname-dict :static-p static-p + :emacs-tags-file-p emacs-tags-file-p :timestamp (float-time (current-time)) :filesize (nth 7 (file-attributes file))) company-ctags-tags-file-caches)) @@ -422,6 +448,9 @@ This function return t if any tag file is reloaded." (defun company-ctags--candidates (prefix) "Get candidate with PREFIX." + (when company-ctags-debug + (message "company-ctags--candidates called => %s" prefix)) + (when (and prefix (> (length prefix) 0)) (let* ((file (and tags-file-name (file-truename tags-file-name))) (completion-ignore-case company-ctags-ignore-case) diff --git a/site-lisp/extensions-local/dired-display-buffer.el b/site-lisp/extensions-local/dired-display-buffer.el deleted file mode 100644 index 4794543..0000000 --- a/site-lisp/extensions-local/dired-display-buffer.el +++ /dev/null @@ -1,87 +0,0 @@ -;; -*- coding: utf-8; -*- -;;; Require: - -;;; Code: -(defcustom dired-display-buffer-switch-window t - "Switch focus to the newly created buffer window. nil to disable." - :type 'boolean - ) - -(defun ld-display-buffer (buffer-or-name alist direction &optional size pixelwise) - "BUFFER: The buffer that will be displayed. -ALIST: See the doc-string of `display-buffer' for more information. -DIRECTION: Must use one of these symbols: 'left 'right 'below 'above -SIZE: See the doc-string for `split-window'. -PIXELWISE: See the doc-string for `split-window'. -There are three possibilities: -- (1) If a window on the frame already displays the target buffer, -then just reuse the same window. -- (2) If there is already a window in the specified direction in relation -to the selected window, then display the target buffer in said window. -- (3) If there is no window in the specified direction, then create one -in that direction and display the target buffer in said window." - (let* ((buffer - (if (bufferp buffer-or-name) - buffer-or-name - (get-buffer buffer-or-name))) - (window - (cond - ((get-buffer-window buffer (selected-frame))) - ((window-in-direction direction)) - (t - (split-window (selected-window) size direction pixelwise))))) - ;; (window--display-buffer buffer window 'window alist display-buffer-mark-dedicated) - (window--display-buffer buffer window 'window alist) - (if dired-display-buffer-switch-window - (select-window window)) - )) - -(defun dired-display-buffer (&optional direction alist) - "Display a dired-mode buffer or a file underneath point in a dired-mode buffer." - (interactive) - (let* ((file-or-dir (or (and (eq major-mode 'dired-mode) (dired-get-file-for-visit)) - (read-directory-name "Directory: "))) - (buffer (find-file-noselect file-or-dir)) - (direction - (if direction - direction - (let ((char (read-char-exclusive (concat - "[" - (propertize "l" 'face '(:foreground "red")) - "]" - (propertize "eft" 'face '(:foreground "blue")) - " | [" - (propertize "r" 'face '(:foreground "red")) - "]" - (propertize "ight" 'face '(:foreground "blue")) - " | [" - (propertize "a" 'face '(:foreground "red")) - "]" - (propertize "bove" 'face '(:foreground "blue")) - " | [" - (propertize "b" 'face '(:foreground "red")) - "]" - (propertize "elow" 'face '(:foreground "blue")))))) - (cond - ((eq char ?l) - 'left) - ((eq char ?r) - 'right) - ((eq char ?a) - 'above) - ((eq char ?b) - 'below) - ;;; FIXME: @lawlist may add a loop similar to `org-capture' - ;;; whereby a new `read-char-exclusive' will be initiated if - ;;; a user did not initially choose a valid option (l/r/a/b). - (t - (let ((debug-on-quit nil) - (msg (concat "dired-display-buffer: " - "You did not select l/r/a/b " - "-- exiting."))) - (signal 'quit `(,msg))))))))) - (ld-display-buffer buffer alist direction))) - -(provide 'dired-display-buffer) - -;;; dired-display-buffer.el ends here diff --git a/site-lisp/extensions-local/dired-hacks-utils.el b/site-lisp/extensions-local/dired-hacks-utils.el deleted file mode 100644 index d283312..0000000 --- a/site-lisp/extensions-local/dired-hacks-utils.el +++ /dev/null @@ -1,273 +0,0 @@ -;;; dired-hacks-utils.el --- Utilities and helpers for dired-hacks collection - -;; Copyright (C) 2014-2015 Matúš Goljer - -;; Author: Matúš Goljer -;; Maintainer: Matúš Goljer -;; Keywords: files -;; Version: 0.0.1 -;; Created: 14th February 2014 -;; Package-Requires: ((dash "2.5.0")) - -;; 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: - -;; Utilities and helpers for `dired-hacks' collection of dired -;; improvements. - -;; This package also provides these interactive functions: -;; * `dired-hacks-next-file' - go to next file, skipping empty and non-file lines -;; * `dired-hacks-previous-file' - go to previous file, skipping empty -;; and non-file lines -;; * `dired-utils-format-information-line-mode' - Format the information -;; (summary) line file sizes to be human readable (e.g. 1GB instead of 1048576). - - -;; See https://github.com/Fuco1/dired-hacks for the entire collection - -;;; Code: - -(require 'dash) -(require 'dired) - -(defgroup dired-hacks () - "Collection of useful dired additions." - :group 'dired - :prefix "dired-hacks-") - -(defcustom dired-hacks-file-size-formatter #'file-size-human-readable - "The function used to format file sizes. - -See `dired-utils-format-file-sizes'." - :type 'function - :group 'dired-hacks) - -(defcustom dired-hacks-datetime-regexp - "\\sw\\sw\\sw....\\(?:[0-9][0-9]:[0-9][0-9]\\|.[0-9]\\{4\\}\\)" - "A regexp matching the date/time in the dired listing. - -It is used to determine where the filename starts. It should -*not* match any characters after the last character of the -timestamp. It is assumed that the timestamp is preceded and -followed by at least one space character. You should only use -shy groups (prefixed with ?:) because the first group is used by -the font-lock to determine what portion of the name should be -colored." - :type 'regexp - :group 'dired-hacks) - -(defalias 'dired-utils--string-trim - (if (and (require 'subr-x nil t) - (fboundp 'string-trim)) - #'string-trim - (lambda (string) - (let ((s string)) - (when (string-match "\\`[ \t\n\r]+" s) - (setq s (replace-match "" t t s))) - (when (string-match "[ \t\n\r]+\\'" s) - (setq s (replace-match "" t t s))) - s))) - "Trim STRING of trailing whitespace. - -\(fn STRING)") - -(defun dired-utils-get-filename (&optional localp) - "Like `dired-get-filename' but never signal an error. - -Optional arg LOCALP with value `no-dir' means don't include -directory name in result." - (dired-get-filename localp t)) - -(defun dired-utils-get-all-files (&optional localp) - "Return all files in this dired buffer as a list. - -LOCALP has same semantics as in `dired-get-filename'." - (save-excursion - (goto-char (point-min)) - (let (r) - (while (= 0 (forward-line)) - (--when-let (dired-utils-get-filename localp) - (push it r))) - (nreverse r)))) - -(defconst dired-utils-file-attributes-keywords - '(:isdir :nlinks :uid :gid :atime :mtime :ctime :size :modes :gidchg :inode :devnum) - "List of keywords to map with `file-attributes'.") - -(defconst dired-utils-info-keywords - `(:name :issym :target ,@dired-utils-file-attributes-keywords) - "List of keywords available for `dired-utils-get-info'.") - -(defun dired-utils--get-keyword-info (keyword) - "Get file information about KEYWORD." - (let ((filename (dired-utils-get-filename))) - (cl-case keyword - (:name filename) - (:isdir (file-directory-p filename)) - (:issym (and (file-symlink-p filename) t)) - (:target (file-symlink-p filename)) - (t - (nth (-elem-index keyword dired-utils-file-attributes-keywords) - (file-attributes filename)))))) - -(defun dired-utils-get-info (&rest keywords) - "Query for info about the file at point. - -KEYWORDS is a list of attributes to query. - -When querying for one attribute, its value is returned. When -querying for more than one, a list of results is returned. - -The available keywords are listed in -`dired-utils-info-keywords'." - (let ((attributes (mapcar 'dired-utils--get-keyword-info keywords))) - (if (> (length attributes) 1) - attributes - (car attributes)))) - -(defun dired-utils-goto-line (filename) - "Go to line describing FILENAME in listing. - -Should be absolute file name matched against -`dired-get-filename'." - (goto-char (point-min)) - (let (stop) - (while (and (not stop) - (= (forward-line) 0)) - (when (equal filename (dired-utils-get-filename)) - (setq stop t) - (dired-move-to-filename))) - stop)) - -(defun dired-utils-match-filename-regexp (filename alist) - "Match FILENAME against each car in ALIST and return first matched cons. - -Each car in ALIST is a regular expression. - -The matching is done using `string-match-p'." - (let (match) - (--each-while alist (not match) - (when (string-match-p (car it) filename) - (setq match it))) - match)) - -(defun dired-utils-match-filename-extension (filename alist) - "Match FILENAME against each car in ALIST and return first matched cons. - -Each car in ALIST is a string representing file extension -*without* the delimiting dot." - (let (done) - (--each-while alist (not done) - (when (string-match-p (concat "\\." (regexp-quote (car it)) "\\'") filename) - (setq done it))) - done)) - -(defun dired-utils-format-information-line () - "Format the disk space on the Dired information line." - (save-excursion - (goto-char (point-min)) - (forward-line) - (let ((inhibit-read-only t) - (limit (line-end-position))) - (while (re-search-forward "\\(?:directory\\|available\\) \\(\\<[0-9]+$\\>\\)" nil t) - (replace-match - (save-match-data - (propertize (dired-utils--string-trim - (funcall dired-hacks-file-size-formatter - (* 1024 (string-to-number (match-string 1))) t)) - 'invisible 'dired-hide-details-information)) - t nil nil 1))))) - - -;;; Predicates -(defun dired-utils-is-file-p () - "Return non-nil if the line at point is a file or a directory." - (dired-utils-get-filename 'no-dir)) - -(defun dired-utils-is-dir-p () - "Return non-nil if the line at point is a directory." - (--when-let (dired-utils-get-filename) - (file-directory-p it))) - - -;;; Interactive -;; TODO: add wrap-around option -(defun dired-hacks-next-file (&optional arg) - "Move point to the next file. - -Optional prefix ARG says how many lines to move; default is one -line." - (interactive "p") - (unless arg (setq arg 1)) - (if (< arg 0) - (dired-hacks-previous-file (- arg)) - (--dotimes arg - (forward-line) - (while (and (or (not (dired-utils-is-file-p)) - (get-text-property (point) 'invisible)) - (= (forward-line) 0)))) - (if (not (= (point) (point-max))) - (dired-move-to-filename) - (forward-line -1) - (dired-move-to-filename) - nil))) - -(defun dired-hacks-previous-file (&optional arg) - "Move point to the previous file. - -Optional prefix ARG says how many lines to move; default is one -line." - (interactive "p") - (unless arg (setq arg 1)) - (if (< arg 0) - (dired-hacks-next-file (- arg)) - (--dotimes arg - (forward-line -1) - (while (and (or (not (dired-utils-is-file-p)) - (get-text-property (point) 'invisible)) - (= (forward-line -1) 0)))) - (if (not (= (point) (point-min))) - (dired-move-to-filename) - (dired-hacks-next-file) - nil))) - -(defun dired-hacks-compare-files (file-a file-b) - "Test if two files FILE-A and FILE-B are the (probably) the same." - (interactive (let ((other-dir (dired-dwim-target-directory))) - (list (read-file-name "File A: " default-directory (car (dired-get-marked-files)) t) - (read-file-name "File B: " other-dir (with-current-buffer (cdr (assoc other-dir dired-buffers)) - (car (dired-get-marked-files))) t)))) - (let ((md5-a (with-temp-buffer - (shell-command (format "md5sum %s" file-a) (current-buffer)) - (buffer-string))) - (md5-b (with-temp-buffer - (shell-command (format "md5sum %s" file-b) (current-buffer)) - (buffer-string)))) - (message "%s%sFiles are %s." md5-a md5-b - (if (equal (car (split-string md5-a)) - (car (split-string md5-b))) - "probably the same" "different")))) - -(define-minor-mode dired-utils-format-information-line-mode - "Toggle formatting of disk space in the Dired information line." - :group 'dired-utils - :lighter "" - (if dired-utils-format-information-line-mode - (add-hook 'dired-after-readin-hook #'dired-utils-format-information-line) - (remove-hook 'dired-after-readin-hook #'dired-utils-format-information-line))) - -(provide 'dired-hacks-utils) - -;;; dired-hacks-utils.el ends here diff --git a/site-lisp/extensions-local/dired-narrow.el b/site-lisp/extensions-local/dired-narrow.el deleted file mode 100644 index 1c3eda2..0000000 --- a/site-lisp/extensions-local/dired-narrow.el +++ /dev/null @@ -1,356 +0,0 @@ -;;; dired-narrow.el --- Live-narrowing of search results for dired - -;; Copyright (C) 2014-2015 Matúš Goljer - -;; Author: Matúš Goljer -;; Maintainer: Matúš Goljer -;; Version: 0.0.1 -;; Created: 14th February 2014 -;; Package-Requires: ((dash "2.7.0") (dired-hacks-utils "0.0.1")) -;; Keywords: files - -;; 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: - -;; This package provides live filtering of files in dired buffers. In -;; general, after calling the respective narrowing function you type a -;; filter string into the minibuffer. After each change the changes -;; automatically reflect in the buffer. Typing C-g will cancel the -;; narrowing and restore the original view, typing RET will exit the -;; live filtering mode and leave the dired buffer in the narrowed -;; state. To bring it back to the original view, you can call -;; `revert-buffer' (usually bound to `g'). - -;; During the filtering process, several special functions are -;; available. You can customize the binding by changing -;; `dired-narrow-map'. - -;; * `dired-narrow-next-file' ( or C-n) - move the point to the -;; next file -;; * `dired-narrow-previous-file' ( or C-p) - move the point to the -;; previous file -;; * `dired-narrow-enter-directory' ( or C-j) - descend into the -;; directory under point and immediately go back to narrowing mode - -;; You can customize what happens after exiting the live filtering -;; mode by customizing `dired-narrow-exit-action'. - -;; These narrowing functions are provided: - -;; * `dired-narrow' -;; * `dired-narrow-regexp' -;; * `dired-narrow-fuzzy' - -;; You can also create your own narrowing functions quite easily. To -;; define new narrowing function, use `dired-narrow--internal' and -;; pass it an apropriate filter. The filter should take one argument -;; which is the filter string from the minibuffer. It is then called -;; at each line that describes a file with point at the beginning of -;; the file name. If the filter returns nil, the file is removed from -;; the view. As an inspiration, look at the built-in functions -;; mentioned above. - -;; See https://github.com/Fuco1/dired-hacks for the entire collection. - -;;; Code: - -(require 'dash) -(require 'dired-hacks-utils) - -(require 'delsel) - -(defgroup dired-narrow () - "Live-narrowing of search results for dired." - :group 'dired-hacks - :prefix "dired-narrow-") - -(defvar dired-narrow-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "") 'dired-narrow-previous-file) - (define-key map (kbd "") 'dired-narrow-next-file) - (define-key map (kbd "") 'dired-narrow-enter-directory) - (define-key map (kbd "C-p") 'dired-narrow-previous-file) - (define-key map (kbd "C-n") 'dired-narrow-next-file) - (define-key map (kbd "C-j") 'dired-narrow-enter-directory) - (define-key map (kbd "C-g") 'minibuffer-keyboard-quit) - (define-key map (kbd "RET") 'exit-minibuffer) - (define-key map (kbd "") 'exit-minibuffer) - map) - "Keymap used while `dired-narrow' is reading the pattern.") - -(defcustom dired-narrow-exit-action 'ignore - "Function to call after exiting minibuffer. - -Function takes no argument and is called with point over the file -we should act on." - :type '(choice (const :tag "Open file under point" dired-narrow-find-file) - (function :tag "Use custom function.")) - :group 'dired-narrow) - -(defcustom dired-narrow-exit-when-one-left nil - "If there is only one file left while narrowing, -exit minibuffer and call `dired-narrow-exit-action'." - :type 'boolean - :group 'dired-narrow) - -(defcustom dired-narrow-enable-blinking t - "If non-nil, highlight the chosen file shortly. -Only works when `dired-narrow-exit-when-one-left' is non-nil." - :type 'boolean - :group 'dired-narrow) - -(defcustom dired-narrow-blink-time 0.2 - "How many seconds should a chosen file be highlighted." - :type 'number - :group 'dired-narrow) - -(defface dired-narrow-blink - '((t :background "#eadc62" - :foreground "black")) - "The face used to highlight a chosen file -when `dired-narrow-exit-when-one-left' and `dired-narrow-enable-blinking' are true." - :group 'dired-narrow) - - -;; Utils - -;; this is `gnus-remove-text-with-property' -(defun dired-narrow--remove-text-with-property (prop) - "Delete all text in the current buffer with text property PROP." - (let ((start (point-min)) - end) - (unless (get-text-property start prop) - (setq start (next-single-property-change start prop))) - (while start - (setq end (text-property-any start (point-max) prop nil)) - (delete-region start (or end (point-max))) - (setq start (when end - (next-single-property-change start prop)))))) - -(defvar dired-narrow-filter-function 'identity - "Filter function used to filter the dired view.") - -(defvar dired-narrow--current-file nil - "Value of point just before exiting minibuffer.") - -(defun dired-narrow--update (filter) - "Make the files not matching the FILTER invisible. - Return the count of visible files that are left after update." - - (let ((inhibit-read-only t) - (visible-files-cnt 0)) - (save-excursion - (goto-char (point-min)) - ;; TODO: we might want to call this only if the filter gets less - ;; specialized. - (dired-narrow--restore) - (while (dired-hacks-next-file) - (if (funcall dired-narrow-filter-function filter) - (progn - (setq visible-files-cnt (1+ visible-files-cnt)) - (when (fboundp 'dired-insert-set-properties) - (dired-insert-set-properties (line-beginning-position) (1+ (line-end-position))))) - (put-text-property (line-beginning-position) (1+ (line-end-position)) :dired-narrow t) - (put-text-property (line-beginning-position) (1+ (line-end-position)) 'invisible :dired-narrow)))) - (unless (dired-hacks-next-file) - (dired-hacks-previous-file)) - (unless (dired-utils-get-filename) - (dired-hacks-previous-file)) - visible-files-cnt)) - -(defun dired-narrow--restore () - "Restore the invisible files of the current buffer." - (let ((inhibit-read-only t)) - (remove-list-of-text-properties (point-min) (point-max) - '(invisible :dired-narrow)) - (when (fboundp 'dired-insert-set-properties) - (dired-insert-set-properties (point-min) (point-max))))) - - -(defun dired-narrow--blink-current-file () - (let* ((beg (line-beginning-position)) - (end (line-end-position)) - (overlay (make-overlay beg end))) - (overlay-put overlay 'face 'dired-narrow-blink) - (redisplay) - (sleep-for dired-narrow-blink-time) - (discard-input) - (delete-overlay overlay))) - - -;; Live filtering - -(defvar dired-narrow-buffer nil - "Dired buffer we are currently filtering.") - -(defvar dired-narrow--minibuffer-content "" - "Content of the minibuffer during narrowing.") - -(defun dired-narrow--minibuffer-setup () - "Set up the minibuffer for live filtering." - (when dired-narrow-buffer - (add-hook 'post-command-hook 'dired-narrow--live-update nil :local))) - -(add-hook 'minibuffer-setup-hook 'dired-narrow--minibuffer-setup) - -(defun dired-narrow--live-update () - "Update the dired buffer based on the contents of the minibuffer." - (when dired-narrow-buffer - (let ((current-filter (minibuffer-contents-no-properties)) - visible-files-cnt) - (with-current-buffer dired-narrow-buffer - (setq visible-files-cnt - (unless (equal current-filter dired-narrow--minibuffer-content) - (dired-narrow--update current-filter))) - - (setq dired-narrow--minibuffer-content current-filter) - (setq dired-narrow--current-file (dired-utils-get-filename)) - (set-window-point (get-buffer-window (current-buffer)) (point)) - - (when (and dired-narrow-exit-when-one-left - visible-files-cnt - (= visible-files-cnt 1)) - (when dired-narrow-enable-blinking - (dired-narrow--blink-current-file)) - (exit-minibuffer)))))) - -(defun dired-narrow--internal (filter-function) - "Narrow a dired buffer to the files matching a filter. - -The function FILTER-FUNCTION is called on each line: if it -returns non-nil, the line is kept, otherwise it is removed. The -function takes one argument, which is the current filter string -read from minibuffer." - (let ((dired-narrow-buffer (current-buffer)) - (dired-narrow-filter-function filter-function) - (disable-narrow nil)) - (unwind-protect - (progn - (dired-narrow-mode 1) - (add-to-invisibility-spec :dired-narrow) - (setq disable-narrow (read-from-minibuffer - (pcase dired-narrow-filter-function - ('dired-narrow--regexp-filter - "Regex Filter:\s") - ('dired-narrow--fuzzy-filter - "Fuzzy Filter:\s") - (_ "Filter:\s")) - nil dired-narrow-map)) - (let ((inhibit-read-only t)) - (dired-narrow--remove-text-with-property :dired-narrow)) - ;; If the file no longer exists, we can't do anything, so - ;; set to nil - (unless (dired-utils-goto-line dired-narrow--current-file) - (setq dired-narrow--current-file nil))) - (with-current-buffer dired-narrow-buffer - (unless disable-narrow (dired-narrow-mode -1)) - (remove-from-invisibility-spec :dired-narrow) - (dired-narrow--restore)) - (when (and disable-narrow - dired-narrow--current-file - dired-narrow-exit-action) - (funcall dired-narrow-exit-action)) - (cond - ((equal disable-narrow "dired-narrow-enter-directory") - (dired-narrow--internal filter-function)))))) - - -;; Interactive - -(defun dired-narrow--regexp-filter (filter) - (condition-case nil - (string-match-p filter (dired-utils-get-filename 'no-dir)) - ;; Return t if your regexp is incomplete/has errors, thus - ;; filtering nothing until you fix the regexp. - (invalid-regexp t))) - -;;;###autoload -(defun dired-narrow-regexp () - "Narrow a dired buffer to the files matching a regular expression." - (interactive) - (dired-narrow--internal 'dired-narrow--regexp-filter)) - -(defun dired-narrow--string-filter (filter) - (let ((words (split-string filter " "))) - (--all? (save-excursion (search-forward it (line-end-position) t)) words))) - -(defun dired-narrow-next-file () - "Move point to the next file." - (interactive) - (with-current-buffer dired-narrow-buffer - (dired-hacks-next-file))) - -(defun dired-narrow-previous-file () - "Move point to the previous file." - (interactive) - (with-current-buffer dired-narrow-buffer - (dired-hacks-previous-file))) - -(defun dired-narrow-find-file () - "Run `dired-find-file' or any remapped action on file under point." - (interactive) - (let ((function (or (command-remapping 'dired-find-file) - 'dired-find-file))) - (funcall function))) - -(defun dired-narrow-enter-directory () - "Descend into directory under point and initiate narrowing." - (interactive) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert "dired-narrow-enter-directory")) - (exit-minibuffer)) - -;;;###autoload -(defun dired-narrow () - "Narrow a dired buffer to the files matching a string. - -If the string contains spaces, then each word is matched against -the file name separately. To succeed, all of them have to match -but the order does not matter. - -For example \"foo bar\" matches filename \"bar-and-foo.el\"." - (interactive) - (dired-narrow--internal 'dired-narrow--string-filter)) - -(defun dired-narrow--fuzzy-filter (filter) - (re-search-forward - (mapconcat 'regexp-quote - (mapcar 'char-to-string (string-to-list filter)) - ".*") - (line-end-position) t)) - -;;;###autoload -(defun dired-narrow-fuzzy () - "Narrow a dired buffer to the files matching a fuzzy string. - -A fuzzy string is constructed from the filter string by inserting -\".*\" between each letter. This is then matched as regular -expression against the file name." - (interactive) - (dired-narrow--internal 'dired-narrow--fuzzy-filter)) - -(define-minor-mode dired-narrow-mode - "Minor mode for indicating when narrowing is in progress." - :lighter " dired-narrow") - -(defun dired-narrow--disable-on-revert () - "Disable `dired-narrow-mode' after revert." - (dired-narrow-mode -1)) - -(add-hook 'dired-after-readin-hook 'dired-narrow--disable-on-revert) - -(provide 'dired-narrow) -;;; dired-narrow.el ends here diff --git a/site-lisp/extensions-local/dired-subtree.el b/site-lisp/extensions-local/dired-subtree.el deleted file mode 100644 index 87f0a69..0000000 --- a/site-lisp/extensions-local/dired-subtree.el +++ /dev/null @@ -1,784 +0,0 @@ -;;; dired-subtree.el --- Insert subdirectories in a tree-like fashion - -;; Copyright (C) 2014-2015 Matúš Goljer - -;; Author: Matúš Goljer -;; Maintainer: Matúš Goljer -;; Keywords: files -;; Version: 0.0.1 -;; Created: 25th February 2014 -;; Package-Requires: ((dash "2.5.0") (dired-hacks-utils "0.0.1")) - -;; 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: - -;; Introduction -;; ------------ - -;; The basic command to work with subdirectories in dired is `i', -;; which inserts the subdirectory as a separate listing in the active -;; dired buffer. - -;; This package defines function `dired-subtree-insert' which instead -;; inserts the subdirectory directly below its line in the original -;; listing, and indent the listing of subdirectory to resemble a -;; tree-like structure (somewhat similar to tree(1) except the pretty -;; graphics). The tree display is somewhat more intuitive than the -;; default "flat" subdirectory manipulation provided by `i'. - -;; There are several presentation options and faces you can customize -;; to change the way subtrees are displayed. - -;; You can further remove the unwanted lines from the subtree by using -;; `k' command or some of the built-in "focusing" functions, such as -;; `dired-subtree-only-*' (see list below). - -;; If you have the package `dired-filter', you can additionally filter -;; the subtrees with global or local filters. - -;; A demo of basic functionality is available on youtube: -;; https://www.youtube.com/watch?v=z26b8HKFsNE - -;; Interactive functions -;; --------------------- - -;; Here's a list of available interactive functions. You can read -;; more about each one by using the built-in documentation facilities -;; of emacs. It is adviced to place bindings for these into a -;; convenient prefix key map, for example C-, - -;; * `dired-subtree-insert' -;; * `dired-subtree-remove' -;; * `dired-subtree-toggle' -;; * `dired-subtree-cycle' -;; * `dired-subtree-revert' -;; * `dired-subtree-narrow' -;; * `dired-subtree-up' -;; * `dired-subtree-down' -;; * `dired-subtree-next-sibling' -;; * `dired-subtree-previous-sibling' -;; * `dired-subtree-beginning' -;; * `dired-subtree-end' -;; * `dired-subtree-mark-subtree' -;; * `dired-subtree-unmark-subtree' -;; * `dired-subtree-only-this-file' -;; * `dired-subtree-only-this-directory' - -;; If you have package `dired-filter', additional command -;; `dired-subtree-apply-filter' is available. - -;; See https://github.com/Fuco1/dired-hacks for the entire collection. - -;;; Code: - -(require 'dired-hacks-utils) -(require 'dash) -(require 'cl-lib) - -(defgroup dired-subtree () - "Insert subdirectories in a tree-like fashion." - :group 'dired-hacks - :prefix "dired-subtree-") - -(defcustom dired-subtree-line-prefix " " - "A prefix put into each nested subtree. - -The prefix is repeated \"depth\" times. - -Alternatively, it can be a function taking one argument---the -depth---that creates the prefix." - :type '(choice string function) - :group 'dired-subtree) - -(defcustom dired-subtree-line-prefix-face 'parents - "Specifies how the prefix is fontified." - :type '(radio - (const :tag "No face applied" nil) - (const :tag "Inherit from current subtree" subtree) - (const :tag "Inherit from all parents" parents)) - :group 'dired-subtree) - -(defcustom dired-subtree-use-backgrounds t - "When non-nil, add a background face to a subtree listing." - :type 'boolean - :group 'dired-subtree) - -(defcustom dired-subtree-after-insert-hook () - "Hook run at the end of `dired-subtree-insert'." - :type 'hook - :group 'dired-subtree) - -(defcustom dired-subtree-after-remove-hook () - "Hook run at the end of `dired-subtree-remove'." - :type 'hook - :group 'dired-subtree) - -(defcustom dired-subtree-cycle-depth 3 - "Default depth expanded by `dired-subtree-cycle'." - :type 'natnum - :group 'dired-subtree) - -(defcustom dired-subtree-ignored-regexp - (concat "^" (regexp-opt vc-directory-exclusion-list) "$") - "Matching directories will not be expanded in `dired-subtree-cycle'." - :type 'regexp - :group 'dired-subtree) - -(defgroup dired-subtree-faces () - "Faces used in `dired-subtree'." - :group 'dired-subtree) - -(defface dired-subtree-depth-1-face - '((t (:background "#252e30"))) - "Background for depth 1 subtrees" - :group 'dired-subtree-faces) - -(defface dired-subtree-depth-2-face - '((t (:background "#232a2b"))) - "Background for depth 2 subtrees" - :group 'dired-subtree-faces) - -(defface dired-subtree-depth-3-face - '((t (:background "#212627"))) - "Background for depth 3 subtrees" - :group 'dired-subtree-faces) - -(defface dired-subtree-depth-4-face - '((t (:background "#1e2223"))) - "Background for depth 4 subtrees" - :group 'dired-subtree-faces) - -(defface dired-subtree-depth-5-face - '((t (:background "#1c1d1e"))) - "Background for depth 5 subtrees" - :group 'dired-subtree-faces) - -(defface dired-subtree-depth-6-face - '((t (:background "#1a191a"))) - "Background for depth 6 subtrees" - :group 'dired-subtree-faces) - -(defvar dired-subtree-overlays nil - "Subtree overlays in this buffer.") -(make-variable-buffer-local 'dired-subtree-overlays) - - -;;; Overlay manipulation -;; Maybe we should abstract the overlay-foo into some subtree -;; functions instead!!! - -(defun dired-subtree--remove-overlay (ov) - "Remove dired-subtree overlay OV." - (setq dired-subtree-overlays - (--remove (equal it ov) dired-subtree-overlays)) - (delete-overlay ov)) - -(defun dired-subtree--remove-overlays (ovs) - "Remove dired-subtree overlays OVS." - (mapc 'dired-subtree--remove-overlay ovs)) - -(defun dired-subtree--cleanup-overlays () - "Remove the `nil' values from `dired-subtree-overlays'." - (setq dired-subtree-overlays - (--remove (not (overlay-buffer it)) dired-subtree-overlays))) - -(defun dired-subtree--get-all-ovs () - "Get all dired-subtree overlays in this buffer." - (--filter (overlay-get it 'dired-subtree-depth) (overlays-in (point-min) (point-max)))) - -(defun dired-subtree--get-all-ovs-at-point (&optional p) - "Get all dired-subtree overlays at point P." - (setq p (or p (point))) - (--filter (overlay-get it 'dired-subtree-depth) (overlays-at (point)))) - -(defun dired-subtree--get-ovs-in (&optional beg end) - "Get all dired-subtree overlays between BEG and END. - -BEG and END default to the region spanned by overlay at point." - (when (not beg) - (let ((ov (dired-subtree--get-ov))) - (setq beg (overlay-start ov)) - (setq end (overlay-end ov)))) - (--filter (and (overlay-get it 'dired-subtree-depth) - (>= (overlay-start it) beg) - (<= (overlay-end it) end)) - (overlays-in (point-min) (point-max)))) - -(defun dired-subtree--get-ov (&optional p) - "Get the parent subtree overlay at point." - (setq p (or p (point))) - (car (--sort (> (overlay-get it 'dired-subtree-depth) - (overlay-get other 'dired-subtree-depth)) - (dired-subtree--get-all-ovs-at-point p)))) - -(defun dired-subtree--get-depth (ov) - "Get subtree depth." - (or (and ov (overlay-get ov 'dired-subtree-depth)) 0)) - - - -;;; helpers -(defvar dired-subtree-preserve-properties '(dired-subtree-filter) - "Properties that should be preserved between read-ins.") - -(defun dired-subtree--after-readin (&optional subtrees) - "Insert the SUBTREES again after dired buffer has been reverted. - -If no SUBTREES are specified, use `dired-subtree-overlays'." - (-when-let (subtrees-to-process (or subtrees dired-subtree-overlays)) - (let* ((ovs-by-depth (--sort (< (car it) (car other)) - (--group-by (overlay-get it 'dired-subtree-depth) - subtrees-to-process))) - (sorted-ovs (--map (cons (car it) - (--map (-cons* it - (overlay-get it 'dired-subtree-name) - (-map (lambda (x) (cons x (overlay-get it x))) - dired-subtree-preserve-properties)) (cdr it))) - ovs-by-depth))) - ;; (depth (path1 ov1 (prop1 . value1) (prop2 . value2)) (path2 ...)) - (--each sorted-ovs - (--each (cdr it) - (when (dired-utils-goto-line (cadr it)) - (dired-subtree--remove-overlay (car it)) - (dired-subtree-insert) - (let ((ov (dired-subtree--get-ov))) - (--each (cddr it) - (overlay-put ov (car it) (cdr it))) - (dired-subtree--filter-subtree ov)))))))) - -(defun dired-subtree--after-insert () - "After inserting the subtree, setup dired-details/dired-hide-details-mode." - (if (fboundp 'dired-insert-set-properties) - (let ((inhibit-read-only t) - (ov (dired-subtree--get-ov))) - (dired-insert-set-properties (overlay-start ov) (overlay-end ov))) - (when (featurep 'dired-details) - (dired-details-delete-overlays) - (dired-details-activate)))) - -(add-hook 'dired-after-readin-hook 'dired-subtree--after-readin) - -(add-hook 'dired-subtree-after-insert-hook 'dired-subtree--after-insert) - -(defun dired-subtree--unmark () - "Unmark a file without moving point." - (save-excursion (dired-unmark 1))) - -(defun dired-subtree--dired-line-is-directory-or-link-p () - "Return non-nil if line under point is a directory or symlink" - ;; We've replaced `file-directory-p' with the regexp test to - ;; speed up filters over TRAMP. So long as dired/ls format - ;; doesn't change, we're good. - ;; 'd' for directories, 'l' for potential symlinks to directories. - (save-excursion (beginning-of-line) (looking-at "..[dl]"))) - -(defun dired-subtree--is-expanded-p () - "Return non-nil if directory under point is expanded." - (save-excursion - (when (dired-utils-get-filename) - (let ((depth (dired-subtree--get-depth (dired-subtree--get-ov)))) - (dired-next-line 1) - (< depth (dired-subtree--get-depth (dired-subtree--get-ov))))))) - -(defmacro dired-subtree-with-subtree (&rest forms) - "Run FORMS on each file in this subtree." - (declare (debug (body))) - `(save-excursion - (dired-subtree-beginning) - ,@forms - (while (dired-subtree-next-sibling) - ,@forms))) - - -;;;; Interactive - -;;;###autoload -(defun dired-subtree-narrow () - "Narrow the buffer to this subtree." - (interactive) - (-when-let (ov (dired-subtree--get-ov)) - (narrow-to-region (overlay-start ov) - (overlay-end ov)))) - -;;; Navigation - -;; make the arguments actually do something -;;;###autoload -(defun dired-subtree-up (&optional arg) - "Jump up one directory." - (interactive "p") - (-when-let (ov (dired-subtree--get-ov)) - (goto-char (overlay-start ov)) - (dired-previous-line 1))) - -;;;###autoload -(defun dired-subtree-down (&optional arg) - "Jump down one directory." - (interactive "p") - (-when-let* ((p (point)) - (ov (car (--sort - (< (overlay-start it) - (overlay-start other)) - (--remove - (< (overlay-start it) p) - (dired-subtree--get-all-ovs)))))) - (goto-char (overlay-start ov)) - (dired-move-to-filename))) - -;;;###autoload -(defun dired-subtree-next-sibling (&optional arg) - "Go to the next sibling." - (interactive "p") - (let ((current-ov (dired-subtree--get-ov))) - (dired-next-line 1) - (let ((new-ov (dired-subtree--get-ov))) - (cond - ((not (dired-utils-is-file-p)) - nil) - ((< (dired-subtree--get-depth current-ov) - (dired-subtree--get-depth new-ov)) - (goto-char (overlay-end new-ov)) - (dired-move-to-filename) - t) - ((> (dired-subtree--get-depth current-ov) - (dired-subtree--get-depth new-ov)) - ;; add option to either go to top or stay at the end - (dired-previous-line 1) - nil) - (t t))))) - -;;;###autoload -(defun dired-subtree-previous-sibling (&optional arg) - "Go to the previous sibling." - (interactive "p") - (let ((current-ov (dired-subtree--get-ov))) - (dired-previous-line 1) - (let ((new-ov (dired-subtree--get-ov))) - (cond - ;; this will need better handlign if we have inserted - ;; subdirectories - ((not (dired-utils-is-file-p)) - nil) - ((< (dired-subtree--get-depth current-ov) - (dired-subtree--get-depth new-ov)) - (goto-char (overlay-start new-ov)) - (dired-previous-line 1) - t) - ((> (dired-subtree--get-depth current-ov) - (dired-subtree--get-depth new-ov)) - ;; add option to either go to top or stay at the end - (dired-next-line 1) - nil) - (t t))))) - -;;;###autoload -(defun dired-subtree-beginning () - "Go to the first file in this subtree." - (interactive) - (let ((ov (dired-subtree--get-ov))) - (if (not ov) - ;; do something when not in subtree - t - (goto-char (overlay-start ov)) - (dired-move-to-filename)))) - -;;;###autoload -(defun dired-subtree-end () - "Go to the first file in this subtree." - (interactive) - (let ((ov (dired-subtree--get-ov))) - (if (not ov) - ;; do something when not in subtree - t - (goto-char (overlay-end ov)) - (dired-previous-line 1)))) - -;;; Marking - -;;;###autoload -(defun dired-subtree-mark-subtree (&optional all) - "Mark all files in this subtree. - -With prefix argument mark all the files in subdirectories -recursively." - (interactive "P") - (save-excursion - (if all - (let ((beg (save-excursion - (dired-subtree-beginning) - (point))) - (end (save-excursion - (dired-subtree-end) - (point)))) - (dired-mark-files-in-region - (progn (goto-char beg) (line-beginning-position)) - (progn (goto-char end) (line-end-position)))) - (dired-subtree-beginning) - (save-excursion (dired-mark 1)) - (while (dired-subtree-next-sibling) - (save-excursion (dired-mark 1)))))) - -;;;###autoload -(defun dired-subtree-unmark-subtree (&optional all) - "Unmark all files in this subtree. - -With prefix argument unmark all the files in subdirectories -recursively." - (interactive) - (let ((dired-marker-char ? )) - (dired-subtree-mark-subtree all))) - -;;; Insertion/deletion -;;;###autoload -(defun dired-subtree-revert () - "Revert the subtree. - -This means reinserting the content of this subtree and all its -children." - (interactive) - (let ((inhibit-read-only t) - (file-name (dired-utils-get-filename))) - (-when-let* ((ov (dired-subtree--get-ov)) - (ovs (dired-subtree--get-ovs-in))) - (dired-subtree-up) - (delete-region (overlay-start ov) (overlay-end ov)) - (dired-subtree--after-readin ovs) - (when file-name - (dired-utils-goto-line file-name))))) - -(defun dired-subtree--readin (dir-name) - "Read in the directory. - -Return a string suitable for insertion in `dired' buffer." - (with-temp-buffer - (insert-directory dir-name dired-listing-switches nil t) - (delete-char -1) - (goto-char (point-min)) - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line - (if (save-excursion - (forward-line 1) - (end-of-line) - (looking-back "\\.")) - 3 1)) (point))) - (insert " ") - (while (= (forward-line) 0) - (insert " ")) - (delete-char -2) - (buffer-string))) - -;;;###autoload -(defun dired-subtree-insert () - "Insert subtree under this directory." - (interactive) - (when (and (dired-subtree--dired-line-is-directory-or-link-p) - (not (dired-subtree--is-expanded-p))) - (let* ((dir-name (dired-get-filename nil)) - (listing (dired-subtree--readin (file-name-as-directory dir-name))) - beg end) - (read-only-mode -1) - (move-end-of-line 1) - ;; this is pretty ugly, I'm sure it can be done better - (save-excursion - (insert listing) - (setq end (+ (point) 2))) - (newline) - (setq beg (point)) - (let ((inhibit-read-only t)) - (remove-text-properties (1- beg) beg '(dired-filename))) - (let* ((ov (make-overlay beg end)) - (parent (dired-subtree--get-ov (1- beg))) - (depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth))) - 1)) - (face (intern (format "dired-subtree-depth-%d-face" depth)))) - (when dired-subtree-use-backgrounds - (overlay-put ov 'face face)) - ;; refactor this to some function - (overlay-put ov 'line-prefix - (if (stringp dired-subtree-line-prefix) - (if (not dired-subtree-use-backgrounds) - (apply 'concat (-repeat depth dired-subtree-line-prefix)) - (cond - ((eq nil dired-subtree-line-prefix-face) - (apply 'concat - (-repeat depth dired-subtree-line-prefix))) - ((eq 'subtree dired-subtree-line-prefix-face) - (concat - dired-subtree-line-prefix - (propertize - (apply 'concat - (-repeat (1- depth) dired-subtree-line-prefix)) - 'face face))) - ((eq 'parents dired-subtree-line-prefix-face) - (concat - dired-subtree-line-prefix - (apply 'concat - (--map - (propertize dired-subtree-line-prefix - 'face - (intern (format "dired-subtree-depth-%d-face" it))) - (number-sequence 1 (1- depth)))))))) - (funcall dired-subtree-line-prefix depth))) - (overlay-put ov 'dired-subtree-name dir-name) - (overlay-put ov 'dired-subtree-parent parent) - (overlay-put ov 'dired-subtree-depth depth) - (overlay-put ov 'evaporate t) - (push ov dired-subtree-overlays)) - (goto-char beg) - (dired-move-to-filename) - (read-only-mode 1) - (when (bound-and-true-p dired-filter-mode) (dired-filter-mode 1)) - (run-hooks 'dired-subtree-after-insert-hook)))) - -;;;###autoload -(defun dired-subtree-remove () - "Remove subtree at point." - (interactive) - (-when-let* ((ov (dired-subtree--get-ov)) - (ovs (dired-subtree--get-ovs-in - (overlay-start ov) - (overlay-end ov)))) - (let ((inhibit-read-only t)) - (dired-subtree-up) - (delete-region (overlay-start ov) - (overlay-end ov)) - (dired-subtree--remove-overlays ovs))) - (run-hooks 'dired-subtree-after-remove-hook)) - -;;;###autoload -(defun dired-subtree-toggle () - "Insert subtree at point or remove it if it was not present." - (interactive) - (if (dired-subtree--is-expanded-p) - (progn - (dired-next-line 1) - (dired-subtree-remove) - ;; #175 fixes the case of the first line in dired when the - ;; cursor jumps to the header in dired rather then to the - ;; first file in buffer - (when (bobp) - (dired-next-line 1))) - (save-excursion (dired-subtree-insert)))) - -(defun dired-subtree--insert-recursive (depth max-depth) - "Insert full subtree at point." - (save-excursion - (let ((name (dired-get-filename nil t))) - (when (and name (file-directory-p name) - (<= depth (or max-depth depth)) - (or (= 1 depth) - (not (string-match-p dired-subtree-ignored-regexp - (file-name-nondirectory name))))) - (if (dired-subtree--is-expanded-p) - (dired-next-line 1) - (dired-subtree-insert)) - (dired-subtree-end) - (dired-subtree--insert-recursive (1+ depth) max-depth) - (while (dired-subtree-previous-sibling) - (dired-subtree--insert-recursive (1+ depth) max-depth)))))) - -(defvar dired-subtree--cycle-previous nil - "Remember previous action for `dired-subtree-cycle'") - -;;;###autoload -(defun dired-subtree-cycle (&optional max-depth) - "Org-mode like cycle visibility: - -1) Show subtree -2) Show subtree recursively (if previous command was cycle) -3) Remove subtree - -Numeric prefix will set max depth" - (interactive "P") - (save-excursion - (cond - ;; prefix - show subtrees up to max-depth - (max-depth - (when (dired-subtree--is-expanded-p) - (dired-next-line 1) - (dired-subtree-remove)) - (dired-subtree--insert-recursive 1 (if (integerp max-depth) max-depth nil)) - (setq dired-subtree--cycle-previous :full)) - ;; if directory is not expanded, expand one level - ((not (dired-subtree--is-expanded-p)) - (dired-subtree-insert) - (setq dired-subtree--cycle-previous :insert)) - ;; hide if previous command was not cycle or tree was fully expanded - ((or (not (eq last-command 'dired-subtree-cycle)) - (eq dired-subtree--cycle-previous :full)) - (dired-next-line 1) - (dired-subtree-remove) - (setq dired-subtree--cycle-previous :remove)) - (t - (dired-subtree--insert-recursive 1 dired-subtree-cycle-depth) - (setq dired-subtree--cycle-previous :full))))) - -(defun dired-subtree--filter-up (keep-dir kill-siblings) - (save-excursion - (let (ov) - (save-excursion - (while (dired-subtree-up)) - (dired-next-line 1) - (dired-subtree-mark-subtree t)) - (if keep-dir - (dired-subtree-unmark-subtree) - (dired-subtree--unmark)) - (while (and (dired-subtree-up) - (> (dired-subtree--get-depth (dired-subtree--get-ov)) 0)) - (if (not kill-siblings) - (dired-subtree--unmark) - (dired-subtree--unmark) - (let ((here (point))) - (dired-subtree-with-subtree - (when (and (dired-subtree--is-expanded-p) - (/= (point) here)) - (dired-subtree--unmark) - (save-excursion - (dired-next-line 1) - (dired-subtree-unmark-subtree t))))))) - (dired-do-kill-lines) - (dired-subtree--cleanup-overlays)))) - -;;;###autoload -(defun dired-subtree-only-this-file (&optional arg) - "Remove all the siblings on the route from this file to the top-most directory. - -With ARG non-nil, do not remove expanded directories in parents." - (interactive "P") - (dired-subtree--filter-up nil arg)) - -;;;###autoload -(defun dired-subtree-only-this-directory (&optional arg) - "Remove all the siblings on the route from this directory to the top-most directory. - -With ARG non-nil, do not remove expanded directories in parents." - (interactive "P") - (dired-subtree--filter-up t arg)) - -;;; filtering -(defun dired-subtree--filter-update-bs (ov) - "Update the local filter list. - -This function assumes that `dired-filter-stack' is dynamically -bound to relevant value." - (let* ((filt (dired-filter--describe-filters)) - (before-str (if (equal filt "") nil (concat " Local filters: " filt "\n")))) - (overlay-put ov 'before-string before-str))) - -(defun dired-subtree--filter-subtree (ov) - "Run the filter for this subtree. - -It is only safe to call this from readin. - -This depends on `dired-filter' package." - (when (featurep 'dired-filter) - (let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter))) - (save-restriction - (widen) - (dired-subtree-narrow) - (dired-filter--expunge) - (dired-subtree--filter-update-bs ov))))) - -;;;###autoload -(defun dired-subtree-apply-filter () - "Push a local filter for this subtree. - -This depends on `dired-filter' package. - -It works exactly the same as global dired filters, only -restricted to a subtree. The global filter is also applied to -the subtree. The filter action is read from `dired-filter-map'." - (interactive) - (when (featurep 'dired-filter) - (-when-let (ov (dired-subtree--get-ov)) - (let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter)) - (glob (current-global-map)) - (loc (current-local-map)) - cmd) - (cl-flet ((dired-filter--update - () - (save-restriction - (overlay-put ov 'dired-subtree-filter dired-filter-stack) - (widen) - (dired-subtree-revert) - (dired-subtree--filter-update-bs ov)))) - (unwind-protect - (progn - (use-global-map dired-filter-map) - (use-local-map nil) - (setq cmd (key-binding (read-key-sequence "Choose filter action: ")))) - (use-global-map glob) - (use-local-map loc)) - (let ((p (point)) - (beg (overlay-start ov)) - (current-file (dired-utils-get-filename))) - (unwind-protect - (call-interactively cmd) - (unless (dired-utils-goto-line current-file) - (goto-char beg) - (forward-line) - (goto-char (min p (1- (overlay-end (dired-subtree--get-ov))))) - (dired-move-to-filename))))))))) - - -;;; Here we redefine a couple of functions from dired.el to make them -;;; subtree-aware - -;; If the point is in a subtree, we need to provide a proper -;; directory, not the one that would come from `dired-subdir-alist'. -(defun dired-current-directory (&optional localp) - "Return the name of the subdirectory to which this line belongs. -This returns a string with trailing slash, like `default-directory'. -Optional argument means return a file name relative to `default-directory'." - (let ((here (point)) - (alist (or dired-subdir-alist - ;; probably because called in a non-dired buffer - (error "No subdir-alist in %s" (current-buffer)))) - elt dir) - (while alist - (setq elt (car alist) - dir (car elt) - ;; use `<=' (not `<') as subdir line is part of subdir - alist (if (<= (dired-get-subdir-min elt) here) - nil ; found - (cdr alist)))) - ;; dired-subdir: modify dir here if we are in a "subtree" view - (-when-let (parent (dired-subtree--get-ov)) - (setq dir (concat (overlay-get parent 'dired-subtree-name) "/"))) - ;; end - (if localp - (dired-make-relative dir default-directory) - dir))) - -;; Since the tree-inserted directory is not in the dired-subdir-alist, -;; we need to guard against nil. -(defun dired-get-subdir () - ;;"Return the subdir name on this line, or nil if not on a headerline." - ;; Look up in the alist whether this is a headerline. - (save-excursion - (let ((cur-dir (dired-current-directory))) - (beginning-of-line) ; alist stores b-o-l positions - (and (zerop (- (point) - (or (dired-get-subdir-min - (assoc cur-dir - dired-subdir-alist)) - 0))) ;; dired-subtree: return zero if current - ;; dir is not in `dired-subdir-alist'. - cur-dir)))) - -(provide 'dired-subtree) - -;;; dired-subtree.el ends here diff --git a/site-lisp/extensions-local/force-indent.el b/site-lisp/extensions-local/force-indent.el index 08461c2..b2b6bbb 100644 --- a/site-lisp/extensions-local/force-indent.el +++ b/site-lisp/extensions-local/force-indent.el @@ -33,7 +33,7 @@ (t (force-indent-line))))) -(defun un-indent-line () +(defun unindent-line () (interactive) (let (col) (save-excursion @@ -51,13 +51,13 @@ (force-indent-line)) (forward-line 1))) -(defun un-indent-region (start stop) +(defun unindent-region (start stop) (interactive "r") (setq stop (copy-marker stop)) (goto-char start) (while (< (point) stop) (unless (and (bolp) (eolp)) - (un-indent-line)) + (unindent-line)) (forward-line 1))) (defun ld-indent () @@ -68,13 +68,13 @@ (setq deactivate-mark nil)) (indent-line))) -(defun ld-un-indent () +(defun ld-unindent () (interactive) (if (use-region-p) (save-excursion - (un-indent-region (region-beginning) (region-end)) + (unindent-region (region-beginning) (region-end)) (setq deactivate-mark nil)) - (un-indent-line))) + (unindent-line))) (provide 'force-indent) diff --git a/site-lisp/extensions-local/goto-last-change.el b/site-lisp/extensions-local/goto-last-change.el deleted file mode 100644 index 524219f..0000000 --- a/site-lisp/extensions-local/goto-last-change.el +++ /dev/null @@ -1,141 +0,0 @@ -;;; goto-last-change.el --- Move point through buffer-undo-list positions - -;; Copyright © 2003 Kevin Rodgers - -;; Author: Kevin Rodgers -;; Created: 17 Jun 2003 -;; Version: $Revision: 1.2 $ -;; Keywords: convenience -;; RCS: $Id: goto-last-change.el,v 1.2 2003/07/30 17:43:47 kevinr Exp kevinr $ - -;; Contributors: -;; Attila Lendvai (line distance and auto marks) - -;; 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 2 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, write to the Free -;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, -;; MA 02111-1307 USA - -;;; Commentary: - -;; After installing goto-last-change.el in a `load-path' directory and -;; compiling it with `M-x byte-compile-file', load it with -;; (require 'goto-last-change) -;; or autoload it with -;; (autoload 'goto-last-change "goto-last-change" -;; "Set point to the position of the last change." t) -;; -;; You may also want to bind a key to `M-x goto-last-change', e.g. -;; (global-set-key "\C-x\C-\\" 'goto-last-change) - -;; goto-last-change.el was written in response to to the following: -;; -;; From: Dan Jacobson -;; Newsgroups: gnu.emacs.bug -;; Subject: function to go to spot of last change -;; Date: Sun, 15 Jun 2003 00:15:08 +0000 (UTC) -;; Sender: news -;; Message-ID: -;; NNTP-Posting-Host: monty-python.gnu.org -;; -;; -;; Why of course, a function to get the user to the spot of last changes -;; in the current buffer(s?), that's what emacs must lack. -;; -;; How many times have you found yourself mosying [<-not in spell -;; checker!?] thru a file when you wonder, where the heck was I just -;; editing? Well, the best you can do is hit undo, ^F, and undo again, -;; to get back. Hence the "burning need" for the additional function, -;; which you might name the-jacobson-memorial-function, due to its brilliance. -;; -- -;; http://jidanni.org/ Taiwan(04)25854780 - -;;; Code: -(provide 'goto-last-change) - -(or (fboundp 'last) ; Emacs 20 - (require 'cl)) ; Emacs 19 - -(defvar goto-last-change-undo nil - "The `buffer-undo-list' entry of the previous \\[goto-last-change] command.") -(make-variable-buffer-local 'goto-last-change-undo) - -;;;###autoload -(defun goto-last-change (&optional mark-point minimal-line-distance) - "Set point to the position of the last change. -Consecutive calls set point to the position of the previous change. -With a prefix arg (optional arg MARK-POINT non-nil), set mark so \ -\\[exchange-point-and-mark] -will return point to the current position." - (interactive "P") - ;; (unless (buffer-modified-p) - ;; (error "Buffer not modified")) - (when (eq buffer-undo-list t) - (error "No undo information in this buffer")) - (when mark-point - (push-mark)) - (unless minimal-line-distance - (setq minimal-line-distance 10)) - (let ((position nil) - (undo-list (if (and (eq this-command last-command) - goto-last-change-undo) - (cdr (memq goto-last-change-undo buffer-undo-list)) - buffer-undo-list)) - undo) - (while (and undo-list - (or (not position) - (eql position (point)) - (and minimal-line-distance - ;; The first invocation always goes to the last change, subsequent ones skip - ;; changes closer to (point) then minimal-line-distance. - (memq last-command '(goto-last-change - goto-last-change-with-auto-marks)) - (< (count-lines (min position (point-max)) (point)) - minimal-line-distance)))) - (setq undo (car undo-list)) - (cond ((and (consp undo) (integerp (car undo)) (integerp (cdr undo))) - ;; (BEG . END) - (setq position (cdr undo))) - ((and (consp undo) (stringp (car undo))) ; (TEXT . POSITION) - (setq position (abs (cdr undo)))) - ((and (consp undo) (eq (car undo) t))) ; (t HIGH . LOW) - ((and (consp undo) (null (car undo))) - ;; (nil PROPERTY VALUE BEG . END) - (setq position (cdr (last undo)))) - ((and (consp undo) (markerp (car undo)))) ; (MARKER . DISTANCE) - ((integerp undo)) ; POSITION - ((null undo)) ; nil - (t (error "Invalid undo entry: %s" undo))) - (setq undo-list (cdr undo-list))) - (cond (position - (setq goto-last-change-undo undo) - (goto-char (min position (point-max)))) - ((and (eq this-command last-command) - goto-last-change-undo) - (setq goto-last-change-undo nil) - (error "No further undo information")) - (t - (setq goto-last-change-undo nil) - (error "Buffer not modified"))))) - -(defun goto-last-change-with-auto-marks (&optional minimal-line-distance) - "Calls goto-last-change and sets the mark at only the first invocations -in a sequence of invocations." - (interactive "P") - (goto-last-change (not (or (eq last-command 'goto-last-change-with-auto-marks) - (eq last-command t))) - minimal-line-distance)) - -;; (global-set-key "\C-x\C-\\" 'goto-last-change) - -;;; goto-last-change.el ends here diff --git a/site-lisp/extensions-local/goto-line-preview.el b/site-lisp/extensions-local/goto-line-preview.el index 16d5575..f457adb 100644 --- a/site-lisp/extensions-local/goto-line-preview.el +++ b/site-lisp/extensions-local/goto-line-preview.el @@ -90,8 +90,8 @@ (setq jumped (read-number (let ((lines (line-number-at-pos (point-max)))) (format (if goto-line-preview--relative-p - "[%d] Goto line relative: (%d to %d) " - "[%d] Goto line: (%d to %d) ") + "[%d] Goto line preview relative: (%d to %d) " + "[%d] Goto line preview: (%d to %d) ") goto-line-preview--prev-line-num (max 0 (min 1 lines)) lines)))) diff --git a/site-lisp/extensions-local/jsonian.el b/site-lisp/extensions-local/jsonian.el new file mode 100644 index 0000000..94e766e --- /dev/null +++ b/site-lisp/extensions-local/jsonian.el @@ -0,0 +1,2272 @@ +;;; jsonian.el --- A major mode for editing JSON files -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Ian Wahbe + +;; Author: Ian Wahbe +;; URL: https://github.com/iwahbe/jsonian +;; Version: 0.1.0 +;; Package-Requires: ((emacs "27.1")) + +;; 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: + +;; `jsonian' provides a fully featured `major-mode' to view, navigate and edit JSON files. +;; Notable features include: +;; - `jsonian-path': Display the path to the JSON object at point. +;; - `jsonian-edit-string': Edit the uninterned string at point cleanly in a separate buffer. +;; - `jsonian-enclosing-item': Move point to the beginning of the collection enclosing point. +;; - `jsonian-find': A `find-file' style interface to navigating a JSON document. +;; - Automatic indentation discovery via `jsonian-indent-line'. +;; +;; When `jsonian' is loaded, it adds `jsonian-mode' and `jsonian-c-mode' to `auto-mode-alist'. +;; This will overwrite `javascript-mode' by default when opening a .json file. It will +;; overwrite `fundamental-mode' when opening a .jsonc file +;; +;; To have `jsonian-mode' activate when any JSON like buffer is opened, +;; regardless of the extension, add +;; (add-to-list 'magic-fallback-mode-alist '("^[{[]$" . jsonian-mode)) +;; to your config after loading `jsonian'. + + +;;; Code: + +(require 'cl-lib) +(require 'json) +(require 'seq) + +(defgroup jsonian nil + "A major mode for editing JSON." + :prefix "jsonian-" :group 'languages + :link `(url-link :tag "GitHub" "https://github.com/iwahbe/jsonian")) + +(defcustom jsonian-ignore-font-lock (>= emacs-major-version 29) + "This variable doesn't do anything anymore. + +It will be removed in a future version of jsonian." + :type 'boolean + :group 'jsonian) + +(define-obsolete-variable-alias 'jsonian-spaces-per-indentation 'jsonian-indentation "27.1") +(defcustom jsonian-indentation nil + "The number of spaces each increase in indentation level indicates. +nil means that `jsonian-mode' will infer the correct indentation." + :type '(choice (const nil) integer) + :group 'jsonian) + +(defcustom jsonian-default-indentation 4 + "The default number of spaces per indent for when it cannot be inferred." + :type 'integer + :group 'jsonian) + +(defcustom jsonian-find-filter-fn #'jsonian--filter-prefix + "The function used to filter `jsonian-find' results." + :type 'func + :group 'jsonian) + +(defgroup jsonian-c nil + "A major mode for editing JSON with comments." + :prefix "jsonian-c-" :group 'jsonian) + +;; Hoisted because it must be declared before use. +(defvar-local jsonian--cache nil + "The buffer local cache of known locations in the current JSON file. +`jsonian--cache' is invalidated on buffer change.") + + +;; Manipulating and verifying JSON paths. +;; +;; A JSON Path is a unique identifier for a node in the buffer. Internally, JSON +;; Paths are lists of strings and integers. JSON Paths are unique, but multiple +;; string representations may parse into the same JSON Path. For example +;; 'foo[3].bar' and '["foo"][3]["bar"]' both parse into '("foo" 3 "bar"). + +(defun jsonian-path (&optional plain pos buffer) + "Find the JSON path of POINT in BUFFER. +If called interactively, then the path is printed to the +minibuffer and pre-appended to the kill ring. If called +non-interactively, then the path is returned as a list of strings +and numbers. It is assumed that BUFFER is entirely JSON and that +the json is valid from POS to `point-min'. PLAIN indicates that +the path should be formated using only indexes. Otherwise index +notation is used. + +For example + { \"foo\": [ { \"bar\": █ }, { \"fizz\": \"buzz\" } ] } +with pos at █ should yield \".foo[0].bar\". + +`jsonian-path' is optimized to work on very large json files (35 MiB+). +This optimization is achieved by +a. parsing as little of the file as necessary to find the path and +b. leveraging C code whenever possible." + (interactive "P") + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (when pos (goto-char pos)) + (jsonian--snap-to-node) + (let ((result (jsonian--reconstruct-path (jsonian--path))) display) + (when (called-interactively-p 'interactive) + (setq display (jsonian--display-path result (not plain))) + (message "Path: %s" display) + (kill-new display)) + result)))) + +(defun jsonian--cached-path (point head) + "Compute `jsonian-path' with assistance from `jsonian--cache'. +HEAD is the path segment for POINT." + (jsonian--ensure-cache) + (if-let* ((node (gethash point (jsonian--cache-locations jsonian--cache)))) + ;; We have retrieved a cached value, so return it + (reverse (jsonian--cached-node-path node)) + ;; Else cache the value and return it + (let ((r (cons head (jsonian--path)))) + (jsonian--cache-node point (reverse r)) + r))) + +(defun jsonian--path () + "Helper function for `jsonian-path'. +`jsonian--path' will parse back to the beginning of the file, +assembling the path it traversed as it goes. + +The caller is responsible for ensuring that `point' begins on a valid node." + ;; The number of previously encountered objects in this list (if we + ;; are in a list). + (cond + ;; We are at a key + ((and (eq (char-after) ?\") + (save-excursion + (and + (jsonian--forward-token) + (eq (char-after) ?:)))) + (when-let ((s (jsonian--string-at-pos (1+ (point))))) + ;; If `s' is nil, it means that the string was invalid + (jsonian--cached-path (prog1 (point) + (jsonian--up-node)) + (buffer-substring-no-properties + (1+ (car s)) (1- (cdr s)))))) + ;; We are not at a key but we are not at the beginning, so we must be in an array + ((save-excursion (jsonian--backward-token)) + (let ((index 0) done (p (point))) + (while (not done) + (when-let (back (jsonian--backward-node)) + (if (eq back 'start) + (setq done t) + (cl-incf index)))) + (jsonian--cached-path (prog1 p + (jsonian--up-node)) + index))) + ;; We are not in a array or object, so we must be at the top level + (t nil))) + +(defun jsonian--down-node () + "Move `point' into a container node. + +Given the example with point at $: + + $\"foo\": { + \"bar\": 3 + } + +`jsonian--down-node' will move point so `char-after' is at \"bar\": + + \"foo\": { + $\"bar\": 3 + } + +This function assumes we are at the start of a node." + (let ((start (point)) + (ret (pcase (char-after) + ((or ?\[ ?\{) + (and + (jsonian--forward-token) + ;; Prevent going into containers with no elements + (not (memq (char-after) '(?\] ?\}))))) + (?\" ;; We might be in a key, so lets check + (jsonian--forward-token) + (when (equal (char-after) ?:) + (progn + (jsonian--forward-token) + (jsonian--down-node))))))) + (unless (eq ret t) + (goto-char start)) + ret)) + +(defun jsonian--up-node () + "Move `point' to the enclosing node. + +Given the example with point at $: + + { + \"a\": 1, + $\"b\": 2 + } + +`jsonian--up-node' will move point so `char-after' is at the opening {: + + ${ + \"a\": 1, + \"b\": 2 + } + +This function assumes we are at the start of a node." + (let* ((start (point)) + ;; Move to the enclosing container + (ret (when-let ((enclosing (nth 1 (syntax-ppss)))) + (goto-char enclosing) + (if (memq (char-after) '(?\{ ?\[)) + t + (goto-char start) + nil)))) + ;; We have found an enclosing container and moved there. We now need only + ;; deal with an associated key. + (when ret + (setq start (point)) + (unless (and (jsonian--backward-token) + (eq (char-after) ?:) + (jsonian--backward-token)) + (goto-char start)) + ret))) + +(defun jsonian--forward-node () + "Move `point' forward a node. +`jsonian--forward-node' will not move up or down within a tree. + +This function assumes we are at the start of a node." + (let ((start (point)) + ;; We are starting at a valid node, which means one of: + ;; - A plain value + ;; - A key in an object + (ret (pcase (char-after) + ((or ?\[ ?\{) ; We are at the start of a list + (forward-list) + (jsonian--skip-chars-forward "\s\n\t") + (if (eobp) 'eob (jsonian--forward-token-comma))) + (?\" + (jsonian--forward-token) + (if (equal (char-after) ?\:) ; `equal' to obviate the `eobp' check + ;; We are looking at a key, so traverse the key and the value. + (and (jsonian--forward-token) ; traverse the : + (jsonian--forward-node)) ; traverse the value node + ;; We are just looking at a string + (jsonian--forward-token-comma))) + ;; Just a normal scalar value + (_ + (jsonian--forward-token) + (jsonian--forward-token-comma))))) + (unless (eq ret t) + (goto-char start)) + ret)) + +(defun jsonian--backward-node () + "Move `point' backward over one node. +`jsonian--backward-node' will not move up or down within a tree. + +This function assumes we are at the start of a node." + (let ((start (point)) + (ret (if (not (jsonian--backward-token)) + 'bob + (pcase (char-after) + ;; This was a valid entry in a list or map, so keep going backwards + (?, + ;; Traverse back over the token + (jsonian--backward-token) + (when (if (memq (char-after) '(?\} ?\])) + (progn + (forward-char) + (backward-list) + t) + t) + (if (save-excursion (and (jsonian--backward-token) + (eq (char-after) ?:))) + ;; We are at a key in an object, so traverse back the key as well. + (and (jsonian--backward-token) (jsonian--backward-token)) + t))) + ((or ?\[ ?\{) 'start) + (_ (jsonian--unexpected-char :backward "one of '[', '{' or ','")))))) + (unless (eq ret t) + (goto-char start)) + ret)) + +(defun jsonian--forward-token-comma () + "Move `point' over a separating ','. + +If the end of a container or the buffer is reached, then `eob' +or `end' will be sent, respectively. + +If the JSON is invalid then `jsonian--unexpected-char' will be called." + (pcase (char-after) + ((or ?\] ?\}) 'end) + (?, (jsonian--forward-token)) + (_ (jsonian--unexpected-char :forward "one of ']', '}' or ','")))) + +(defun jsonian--backward-token () + "Move `point' to the previous JSON token. + +`jsonian--backward-token' will skip over any whitespace it finds. + +It is assumed that `point' starts at a JSON token." + (jsonian--skip-chars-backward "\s\n\t") + (let* ((needs-seperator t) + (v (pcase (char-before) + ;; No previous token, so do nothing + ((pred null) nil) + ;; Found a single char token, so move behind it + ((or ?: ?, ?\[ ?\] ?\{ ?\}) + (setq needs-seperator nil) + (backward-char) t) + ;; Found a string, so traverse it + (?\" (jsonian--backward-string) t) + (?l (jsonian--backward-null) t) + (?e (pcase (char-before (1- (point))) + (?u (jsonian--backward-true) t) + (?s (jsonian--backward-false) t) + (_ (save-excursion (backward-char) + (jsonian--unexpected-char :backward "\"u\" or \"s\""))))) + ((pred (lambda (c) (and (<= c ?9) (>= c ?0)))) + (jsonian--backward-number) t) + (_ (jsonian--unexpected-char :backward "one of ':,[]{}\"le0123456789'"))))) + (when (and needs-seperator + (not (memq (char-before) '(nil ?: ?, ?\[ ?\] ?\{ ?\} ?\s ?\t ?\n)))) + (jsonian--unexpected-char :backward "one of ':,[]{}\\s\\t\\n' or BOF")) + v)) + +(defvar-local jsonian--last-token-end nil + "The end of the last token that `jsonian--forward-token' parsed. + +For example, given the following string with point at the +?| (`char-after' will be refer to ?,): + + 1.2|, 3.4 + +`jsonian--forward-token' will move point to ?|: + + 1.2, |3.4 + +It will set the value of `jsonian--last-token-end' to + + 1.2,| 3.4 + +If `jsonian--forward-token' returned nil, the value of +`jsonian--last-token-end' is undefined.") + +(defun jsonian--forward-token (&optional stop-at-comments) + "Move `point' to the next JSON token. + +`jsonian--forward-token' will skip over any whitespace it finds. + +By default, `jsonian--forward-token' skips over comments when in +`jsonian-c-mode' or errors on comments in plain `jsonian-mode'. +If STOP-AT-COMMENTS is non-nil and a comment is encountered in +`jsonian-c-mode', then comments are treated like tokens by +`jsonian--forward-token'. + +It is assumed that `point' starts at a JSON token. + +t is returned if `jsonian--forward-token' successfully traversed +a token, otherwise nil is returned." + (let ((needs-seperator t)) + (pcase (char-after) + ;; We are at the end of the buffer, so we can't do anything + ((pred null) nil) + ;; Found a single char token, so move ahead of it + ((or ?: ?, ?\[ ?\] ?\{ ?\}) + (setq needs-seperator nil) + (forward-char)) + ;; Found a string, so traverse it + (?\" (jsonian--forward-string)) + ;; Otherwise we are looking at a non-string scalar token, so parse forward + ;; until we find a separator or whitespace (which implies that the token is + ;; over). + (?t (jsonian--forward-true)) + (?f (jsonian--forward-false)) + (?n (jsonian--forward-null)) + ((pred (lambda (c) (and stop-at-comments + (derived-mode-p 'jsonian-c-mode) + (eq c ?/) + (memq (char-after (1+ (point))) '(?/ ?*))))) + (forward-comment 1)) + ((pred (lambda (c) (or (and (<= c ?9) (>= c ?0)) (eq c ?-)))) + (jsonian--forward-number)) + ;; This is the set of chars that can start a token + (_ (jsonian--unexpected-char :forward "one of ':,[]{}\"tfn0123456789-'"))) + (setq jsonian--last-token-end (point)) + ;; Skip forward over whitespace and comments + (when (and (= (jsonian--skip-chars-forward "\s\n\t" stop-at-comments) 0) + needs-seperator + (not (memq (char-after) '(nil ?: ?, ?\[ ?\] ?\{ ?\} ?\s ?\t ?\n)))) + (jsonian--unexpected-char :forward "one of ':,[]{}\\s\\t\\n' or EOF"))) + (not (eobp))) + +(defun jsonian--snap-to-node () + "Position `point' before a node. +This function moves forward through whitespace but backwards through the node. +nil is returned if `jsonian--snap-to-node' failed to move `point' to +before a node." + (when (jsonian--snap-to-token) + (pcase (char-after) + ;; The token indicates that we are the second token within a "key: value" + ;; node. + (?: (jsonian--backward-token)) + ;; We are at the end of a node, but its not clear how far from the + ;; front. Move back one token and try again. + (?, + (jsonian--backward-token) + (jsonian--snap-to-node)) + ;; We are at the end of a container, so move back inside the container and + ;; try again + ((or ?\] ?\}) + (skip-chars-backward "\s\n\t}]") ; Skip out of enclosing nodes + (backward-char) ; Skip into the last node being enclosed + (jsonian--snap-to-node)) ; Return that node + ;; We are either at the front of a node, or prefixed with a key + (_ (if (save-excursion (and (jsonian--backward-token) (eq (char-after) ?:))) + (progn + (jsonian--backward-token) ;; Move behind the : + (jsonian--backward-token)) ;; Move behind the string + t))))) + +(defun jsonian--skip-chars-backward (chars) + "Skip CHARS backwards in a comment aware way." + (let ((start (point))) + (while (or + (> (skip-chars-backward chars) 0) + (jsonian--backward-comment))) + (- start (point)))) + +(defun jsonian--skip-chars-forward (chars &optional stop-at-comments) + "Skip CHARS forward in a comment aware way. + +If STOP-AT-COMMENTS is non-nil, then (comment . traveled) is +returned when a comment is encountered." + (let ((start (point))) + (while (or + (> (skip-chars-forward chars) 0) + (and (not stop-at-comments) + (jsonian--forward-comment)))) + (- (point) start))) + +(defun jsonian--snap-to-token () + "Position `point' at the \"nearest\" token. +If `point' is within a token, it is moved to point at that token. +Otherwise, `point' is moved to point at the nearest token on the +same line. Otherwise `point' is moved to point to the nearest +token period. + +Nearest is defined to be point that minimizes (abs (- (point) +previous)). + +Consider the following example, with `point' starting at $: + + { \"foo\": \"fizz $buzz\" } + +`jsonian--snap-to-token' will move the point so `char-after' is the ?\" +that begins \"fizz buzz\". + +With the same example and different cursor position, we will see the same +result: + + { \"foo\": $ \"fizz buzz\" } + +The cursor will move so `char-after' will give the ?:. If we +move the starting point over: + + { \"foo\": $ \"fizz buzz\" } + +we instead move so that `char-after' gives the ?\" that begins +\"fizz buzz\"." + ;; We are looking for the "nearest" token to position the cursor at. + ;; + ;; We do this by looking for the nearest token on the left and the right. If we find + ;; tokens on the left and the right, we take whichever is closest to `center', which is + ;; where we started looking from. + (let* ((center (point)) + left-end + (left + (jsonian--is-token + ;; Find the left most valid starting token + (if-let (start (jsonian--pos-in-stringp)) + start + (when-let (start (jsonian--enclosing-comment-p (point))) + (goto-char start)) + + (jsonian--skip-chars-backward "\s\t\n") + (unless (bobp) + (pcase (char-before) + ((or ?: ?, ?\{ ?\} ?\[ ?\]) (1- (point))) + (?\" (jsonian--backward-string) + (point)) + (_ (while (not (or (bobp) + (memq (char-before) '(?: ?, ?\s ?\t ?\n ?\{ ?\} ?\[ ?\])))) + (backward-char)) + (unless (bobp) + (point)))))))) + (right + (jsonian--is-token + (cond + ;; If left=center, there is no point in trying to calculate `right', + ;; since it cannot be better then left. + ((eq left center) nil) + (left + ;; If we have a left token, we can just traverse forward from the left + ;; token to get the right token. + (goto-char left) + (when (and (jsonian--forward-token) + (>= center (setq left-end jsonian--last-token-end))) + ;; If center is within the node found by left, we take that + ;; token regardless of distance. This is necessary to ensure + ;; idenpotency for tightly packed tokens. + (point))) + (t + ;; We have no left token, so we need to parse to the right token. + (goto-char center) + (when-let (start (jsonian--enclosing-comment-p (point))) + (goto-char start)) + (jsonian--skip-chars-forward "\s\t\n") + (unless (eobp) + (point))))))) + ;; Move `point' to the nearest token start: `left' or `right'. + (goto-char + (or + (if (and left right) + ;; If we have both left and right, we look at their line positions. + (let ((center-line (line-number-at-pos center)) + (left-line (line-number-at-pos left)) + (right-line (line-number-at-pos right))) + (cond + ;; If `left' ^ `right' is on the same line as `center' we take that token. + ((and (= center-line left-line) + (not (= center-line right-line))) + left) + ((and (= center-line right-line) + (not (= center-line left-line))) + right) + (t + ;; If the tokens are on different lines, we set check against the end of the + ;; left token instead of the left token itself. + (if (<= (- center (if (and (not (= center-line left-line right-line)) left-end) + left-end left)) + (- right center)) + left + right)))) + (or left right)) + center)))) + +(defun jsonian--is-token (point) + "Return POINT if it is the start of a token. +Otherwise nil is returned." + (when point + (condition-case nil + (save-excursion + (goto-char point) + ;; If not at a token, then `jsonian--forward-token' will `signal'. + (jsonian--forward-token) + ;; If we didn't signal, return `point'. + ;; + ;; This would be better expressed as a (:success t) case, but that was + ;; introduced in Emacs 28. + point) + (user-error nil)))) + +(defun jsonian--display-path (path &optional pretty) + "Convert the reconstructed JSON path PATH to a string. +If PRETTY is non-nil, format for human readable." + (mapconcat + (lambda (el) + (cond + ((numberp el) (format "[%d]" el)) + ((stringp el) (format + (if (and pretty (jsonian--simple-path-segment-p el)) + ".%s" "[\"%s\"]") + el)) + (t (error "Unknown path element %s" path)))) + path "")) + +(defconst jsonian--complex-segment-regex "\\([[:blank:].\"\\[]\\|\\]\\)" + "The set of characters that make a path complex.") + +(defun jsonian--parse-path (str) + "Parse STR as a JSON path. +A list of elements is returned." + (unless (stringp str) (error "`jsonian--parse-path': Input not a string")) + (setq str (substring-no-properties str)) + (cond + ((string= str "") nil) + ((string-match "^\\[[0-9]+\]" str) + (cons (string-to-number (substring str 1 (1- (match-end 0)))) + (jsonian--parse-path (substring str (match-end 0))))) + ((string-match-p "^\\[\"" str) + (if-let* ((str-end (with-temp-buffer + (insert (substring str 1)) (goto-char (point-min)) + (when (jsonian--forward-string) + (point)))) + (str-length (- str-end 3))) + (cons (substring str 2 (1- str-end)) + (jsonian--parse-path + (string-trim-left (substring str (+ str-length 2)) "\"\\]?"))) + (cons (string-trim-left str "\\[\"") nil))) + ((string= "." (substring str 0 1)) + (if (not (string-match "[\.\[]" (substring str 1))) + ;; We have found nothing to indicate another sequence, so this is the last node + (cons (string-trim (substring str 1)) nil) + (cons + (string-trim (substring str 1 (match-end 0))) + (jsonian--parse-path (substring str (match-end 0)))))) + ((string= " " (substring str 0 1)) + ;; We have found a leading whitespace not part of a segment, so ignore it. + (jsonian--parse-path (substring str 1))) + ;; There are no more fully valid parses, so look at invalid parses + ((string-match "^\\[[0-9]+$" str) + ;; A number without a closing ] + (cons (string-to-number (substring str 1)) nil)) + ((string-match-p "^\\[" str) + ;; We have found a string starting with [, it isn't a number, so parse it + ;; like a string + (if (string-match "\\]" str 1) + ;; Found a terminator + (cons (substring str 1 (1- (match-end 0))) + (jsonian--parse-path (substring str (match-end 0)))) + ;; Did not find a terminator + (cons (substring str 1) nil))) + ((not (eq (string-match-p jsonian--complex-segment-regex str) 0)) + ;; If we are not at a character that cannot be part of a simple path, + ;; attempt making it one. + (jsonian--parse-path (concat "." str))) + (t (user-error "Unexpected input: %s" str)))) + +(defun jsonian--simple-path-segment-p (segment) + "If the string SEGMENT can be displayed simply, or if it needs to be escaped. +A segment is considered simple if and only if it does not contain any +- blanks +- period +- quotes +- square brackets" + (not (string-match-p jsonian--complex-segment-regex segment))) + +(defun jsonian--reconstruct-path (input) + "Cleanup INPUT as the result of `jsonian--path'." + (let (path) + (seq-do (lambda (element) + (if (or (stringp element) (numberp element)) + (setq path (cons element path)) + (error "Unexpected element %s of type %s" element (type-of element)))) + input) + path)) + +(defun jsonian--valid-path (path) + "Check if PATH is a valid path in the current JSON buffer. +PATH should be a list of segments. A path is considered valid if +it traverses existing structures in the buffer JSON. It does not +need to be a leaf path." + (save-excursion + (goto-char (point-min)) + (jsonian--snap-to-token) + (let (failed leaf current-segment traversed) + (while (and path (not failed) (not leaf)) + (unless (seq-some + (lambda (x) + (when (equal (car x) (car path)) + (cl-assert (car x) t "Found nil car") + (goto-char (cdr x)) + (setq leaf (not (jsonian--at-collection (point)))) + t)) + (jsonian--cached-find-children traversed :segment current-segment)) + (setq failed t)) + (setq current-segment (car path) + traversed (append traversed (list current-segment)) + path (cdr path))) + ;; We reject if we have noticed a failure or exited early by hitting a + ;; leaf node + (when (and (not failed) (not path)) + (jsonian--cached-find-children traversed :segment current-segment) + (point))))) + + +;; Traversal functions +;; +;; A set of utility functions for moving around a JSON buffer by the structured text. + +;;;###autoload +(defun jsonian-enclosing-item (&optional arg) + "Move point to the item enclosing the current point. +If ARG is not nil, move to the ARGth enclosing item." + (interactive "P") + (if arg + (cl-assert (wholenump arg) t "Invalid input to `jsonian-enclosing-item'.") + (setq arg 1)) + (unless (jsonian--snap-to-node) + (user-error "Failed to find a JSON node at point")) + (while (and (> arg 0) (jsonian--up-node)) + (cl-decf arg 1)) + (= arg 0)) + +(defmacro jsonian--defun-literal-traversal (literal) + "Define `jsonian--forward-LITERAL' and `jsonian--backward-LITERAL'. +LITERAL is the string literal to be traversed." + (declare (indent defun)) + `(progn + (defun ,(intern (format "jsonian--backward-%s" literal)) () + ,(format "Move backward over the literal \"%s\"" literal) + (if (and (> (- (point) ,(length literal)) (point-min)) + ,@(let ((i 0) l) + (while (< i (length literal)) + (setq l (cons (list 'eq (list 'char-before (list '- '(point) (- (length literal) i 1))) (aref literal i)) l) + i (1+ i))) + l)) + (backward-char ,(length literal)) + (jsonian--unexpected-char :backward ,(format "literal value \"%s\"" literal)))) + (defun ,(intern (format "jsonian--forward-%s" literal)) () + ,(format "Move forward over the literal \"%s\"" literal) ; + (if (and (< (+ (point) ,(length literal)) (point-max)) + ,@(let ((i 0) l) + (while (< i (length literal)) + (setq l (cons (list '= (list 'char-after (list '+ '(point) i)) (aref literal i)) l) + i (1+ i))) + l)) + (dotimes (_ ,(length literal)) + (if (eolp) (forward-line) (forward-char))) + (jsonian--unexpected-char :forward ,(format "literal value \"%s\"" literal)))))) + +(jsonian--defun-literal-traversal "true") +(jsonian--defun-literal-traversal "false") +(jsonian--defun-literal-traversal "null") + +(defun jsonian--forward-number () + "Parse a JSON number forward. + +For the definition of a number, see https://www.json.org/json-en.html" + (let ((point (point)) (valid t)) + (when (equal (char-after point) ?-) (setq point (1+ point))) ;; Sign + ;; Whole number + (if (equal (char-after point) ?0) + (setq point (1+ point)) ;; Found a zero, the whole part is done + (if (and (char-after point) + (>= (char-after point) ?1) + (<= (char-after point) ?9)) + (setq point (1+ point)) ;; If valid, increment over the first number. + (setq valid nil)) ;; Otherwise, the number is not valid. + ;; Parse the remaining whole part of the number + (while (and (char-after point) + (>= (char-after point) ?0) + (<= (char-after point) ?9)) + (setq point (1+ point)))) + ;; Fractional + (when (equal (char-after point) ?.) + (setq point (1+ point)) + (unless (and (char-after point) + (>= (char-after point) ?0) + (<= (char-after point) ?9)) + (setq valid nil)) + (while (and (char-after point) + (>= (char-after point) ?0) + (<= (char-after point) ?9)) + (setq point (1+ point)))) + ;; Exponent + (when (memq (char-after point) '(?e ?E)) + (setq point (1+ point)) + (when (memq (char-after point) '(?- ?+)) ;; Exponent sign + (setq point (1+ point))) + (unless (and (char-after point) + (>= (char-after point) ?0) + (<= (char-after point) ?9)) + (setq valid nil)) + (while (and (char-after point) + (>= (char-after point) ?0) + (<= (char-after point) ?9)) + (setq point (1+ point)))) + (when valid + (goto-char point) + t))) + +(defun jsonian--backward-number () + "Parse a JSON number backward. + +Here we execute the reverse of the flow chart described at +https://www.json.org/json-en.html: + + +------+ !=====! !===! !===! +>>--+-----+------------------+------>| 0-9* |--->| 1-9 |--->| - |<---| 0 | + | | | +------+ !=====! !===! !===! + | | | | ^ ^ + | v | v | | + | +------+ +-----+ +-----+ +---+ +------+ | + | | 0-9* |->| +|- |->| e|E | +--| . |---->| 0-9* | | + | +------+ +-----+ +-----+ | +---+ +------+ | + | | | + | exponent component | fraction component sign | + | -------------------------- | -------------------- ------ | + | v | + +------------------------------+-----------------------------------+ + +The above diagram denotes valid stopping locations with boxes +outlined with = and !. The flow starts with the >> at the middle +left." + (when-let ((valid-stops + (seq-filter + #'identity + (list + (jsonian--backward-exponent (point)) + (jsonian--backward-fraction (point)) + (jsonian--backward-integer (point)))))) + (goto-char (seq-min valid-stops)))) + +(defun jsonian--backward-exponent (point) + "Parse backward from POINT assuming an exponent segment of a JSON number." + (let (found-number done) + (while (and (not done) (char-before point) + (<= (char-before point) ?9) + (>= (char-before point) ?0)) + (if (= point (1+ (point-min))) + (setq done t) + (setq point (1- point) + found-number t))) + (when found-number ;; We need to see a number for an exponent + (when (memq (char-before point) '(?+ ?-)) + (setq point (1- point))) + (when (memq (char-before point) '(?e ?E)) + (or (jsonian--backward-fraction (1- point)) + (jsonian--backward-integer (1- point))))))) + +(defun jsonian--backward-fraction (point) + "Parse backward from POINT assuming no exponent segment of a JSON number." + (let (found-number done) + (while (and (not done) (char-before point) + (<= (char-before point) ?9) + (>= (char-before point) ?0)) + (if (= point (1+ (point-min))) + (setq done t) + (setq point (1- point) + found-number t))) + (when (and found-number (= (char-before point) ?.)) + (jsonian--backward-integer (1- point))))) + +(defun jsonian--backward-integer (point) + "Parse backward from POINT assuming you will only find a simple integer." + (let (found-number done leading-valid) + (when (equal (char-before point) ?0) + (setq leading-valid (1- point))) + (while (and (not done) (char-before point) + (<= (char-before point) ?9) + (>= (char-before point) ?0)) + (setq found-number (char-before point)) + (unless (eq found-number ?0) + (setq leading-valid (1- point))) + (if (= point (1+ (point-min))) + (setq done t) + (setq point (1- point)))) + (when leading-valid + (if (and (char-before leading-valid) + (eq (char-before leading-valid) ?-)) + (1- leading-valid) + leading-valid)))) + +(defun jsonian--enclosing-comment-p (pos) + "Check if POS is inside comment delimiters. +If in a comment, the first char before the comment deliminator is +returned." + (when (and (derived-mode-p 'jsonian-c-mode) + (>= pos (point-min)) + (<= pos (point-max))) + (save-excursion +;; The behavior of `syntax-ppss' is worth considering. +;; This is confusing behavior. For example: +;; [ 1, 2, /* 42 */ 3 ] +;; ^ +;; is not in a comment, since it is part of the comment deliminator. + (let ((s (syntax-ppss pos))) + (cond + ;; We are in a comment body + ((nth 4 s) (nth 8 s)) + ;; We are between the characters of a two character comment opener. + ((and + (eq (char-before pos) ?/) + (or + (eq (char-after pos) ?/) + (eq (char-after pos) ?*)) + (< pos (point-max))) + ;; we still do the syntax check, because we might be in a string + (setq s (syntax-ppss (1+ pos))) + (when (nth 4 s) + (nth 8 s))) + ;; We are between the ending characters of a comment. + ((and + (eq (char-before pos) ?*) + (eq (char-after pos) ?/) + (> pos (point-min))) + ;; we still do the syntax check, because we might be in a string + (setq s (syntax-ppss (1- pos))) + (when (nth 4 s) + (nth 8 s)))))))) + +(defun jsonian--backward-comment () + "Traverse backward out of a comment." + ;; In the body of a comment + (when-let (start (or (jsonian--enclosing-comment-p (point)) + (jsonian--enclosing-comment-p (1- (point))))) + (goto-char start))) + +(defun jsonian--forward-comment () + "Traverse forward out of a comment. +Must be at the comment boundary." + (when (and + (derived-mode-p 'jsonian-c-mode) + (eq (char-after) ?/) + (memq (char-after (1+ (point))) '(?/ ?*))) + (forward-comment 1))) + +(defun jsonian--backward-string () + "Move back a string, starting at the ending \"." + (unless (eq (char-before) ?\") + (error "`jsonian--backward-string': Expected to start at \"")) + (let ((end (point))) + (backward-char) ; Skip over the previous " + (jsonian--string-scan-back) + (cons (point) end))) + +(defun jsonian--forward-string () + "Move forward a string, starting at the beginning \"." + (unless (eq (char-after) ?\") + (error "`jsonian--forward-string': Expected to start at \", instead found %s" + (if (char-after) (char-to-string (char-after)) "EOF"))) + (let ((start (point))) + (when (jsonian--string-scan-forward t) + (cons start (point))))) + +(defun jsonian--string-scan-back () + "Scan backwards from `point' looking for the beginning of a string. +`jsonian--string-scan-back' will not move between lines. A non-nil +result is returned if a string beginning was found." + (let (done exit) + (while (not (or done exit)) + (when (bolp) (setq exit t)) + ;; Backtrack through the string until an unescaped " is found. + (if (not (eq (char-before) ?\")) + (when (not (bobp)) (backward-char)) + (let (escaped (anchor (point))) + (while (eq (char-before (1- (point))) ?\\) + (backward-char) + (setq escaped (not escaped))) + (if escaped + (when (not (bobp)) (backward-char)) + (goto-char (1- anchor)) + (setq done (point)))))) + done)) + +(defun jsonian--string-scan-forward (&optional at-beginning) + "Find the front of the current string. +`jsonian--string-scan-back' is called internally. When a string is found +the position of the final \" is returned and the point is moved +to just past that. When no string is found, nil is returned. + +If AT-BEGINNING is non-nil, `jsonian--string-scan-forward' assumes +it is at the beginning of the string. Otherwise it scans +backwards to ensure that the end of a string is not escaped." + (let ((start (if at-beginning (point) (jsonian--pos-in-stringp))) + done) + (when start + (goto-char (1+ start)) + (while (not (or done (eolp))) + (cond + ((= (char-after) ?\\) + (forward-char 2)) + ((= (char-after) ?\") + (setq done (point)) + (forward-char)) + ;; We are in the string, and not looking at a significant character. Scan forward + ;; (in C) for an interesting character. + (t (skip-chars-forward "^\"\\\\\n")))) + (and done (>= done start) done)))) + +(defun jsonian--pos-in-stringp () + "Determine if `point' is in a string (either a key or a value). +`jsonian--pos-in-string' will only examine between `point' and +`beginning-of-line'. When non-nil, the starting position of the +discovered string is returned." + (save-excursion + (let (in-string start done) + (while (and (jsonian--string-scan-back) (not done)) + (when (not start) + (setq start (point))) + (setq in-string (not in-string)) + (setq done (bobp))) + (when in-string start)))) + +(defun jsonian--pos-in-keyp (&optional at-beginning) + "Determine if `point' is a JSON string key. +If a non-nil, the position of the end of the string is returned. + +If AT-BEGINNING is non-nil `jsonian--pos-in-keyp' assumes it is at +the beginning of a string." + ;; A string is considered to be a key iff it is a string followed by some + ;; amount of whitespace (maybe none) and then a :. + (save-excursion + (when (jsonian--string-scan-forward at-beginning) + (let ((end (point))) + (jsonian--skip-chars-forward "\s\t\n") + (and (= (char-after) ?:) end))))) + +(defun jsonian--after-key (pos) + "Detect if POS are preceded by a key. +This is a short-cut version of `jsonian--pos-in-keyp' to improve +syntax highlighting time." + (let ((x (char-before pos))) + (while (and (not (bobp)) + (or (= x ?\ ) + (= x ?\t) + (= x ?\n) + (= x ?\r))) + (setq pos (1- pos) + x (char-before pos))) + (eq (char-before pos) ?:))) + +(defun jsonian--pos-in-valuep () + "Determine if `point' is a JSON string value. +If a non-nil, the position of the beginning of the string is +returned." + (and (not (jsonian--pos-in-keyp)) (jsonian--pos-in-stringp))) + +(defun jsonian--string-at-pos (&optional pos) + "Return (start . end) for a string at POS if it exists. +Otherwise nil is returned. POS defaults to `point'." + (save-excursion + (when pos + (goto-char pos)) + (let ((start (jsonian--pos-in-stringp)) end) + (when start + (setq end (jsonian--string-scan-forward))) + (when (and start end) + (cons start (1+ end)))))) + +(defun jsonian--get-string-region (type &optional pos) + "Find the bounds of the string at POS in BUFFER. +Valid options for TYPE are `font-lock-string-face' and `font-lock-keyword-face'." + (save-excursion + (when pos + (goto-char pos)) + (cond + ((eq type 'font-lock-string-face) + (and (jsonian--pos-in-valuep) (jsonian--string-at-pos))) + ((eq type 'font-lock-keyword-face) + (and (jsonian--pos-in-keyp) (jsonian--string-at-pos))) + (t (error "'%s' is not a valid type" type))))) + +(defun jsonian--at-collection (pos) + "Check if POS is before a collection. +POS must be a valid node location." + (save-excursion + (goto-char pos) + (jsonian--down-node))) + + +;; Supporting commands for `jsonian-edit-string'. +;; +;; This is the infrastructure for un-interning and re-interning strings to edit, +;; as well as the major mode used to do so. + +(cl-defstruct jsonian--edit-return + "Information necessary to return from `jsonian--edit-mode'." + (match nil :documentation "The (start . end) region of text being operated on.") + (back-buffer nil :documentation "The buffer to return back to.") + (overlay nil :documentation "The overlay used to highlight `match' text.") + (delete-window nil :documentation "If the hosting `window' should be deleted upon exit.")) + +(defvar-local jsonian-edit-return-var nil + "Information necessary to jump back from `jsonian--edit-mode'.") + +(defvar jsonian-edit-string-hook nil + "A normal hook run when `jsonian-edit-string' is called. + +It is run in the context of the edit buffer.") + +(defun jsonian-edit-string () + "Edit the string at point in another buffer." + (interactive) + (let ((cbuffer (current-buffer)) + (match (jsonian--get-string-region 'font-lock-string-face))) + (unless match (user-error "No string at point")) + (let* ((edit-buffer (generate-new-buffer (concat "edit-string:" (buffer-name)))) + (overlay (make-overlay (car match) (cdr match) cbuffer)) + (match (cons (1+ (car match)) (1- (cdr match)))) + (text (buffer-substring-no-properties (car match) (cdr match)))) + (overlay-put overlay 'face (list :background "white")) + (read-only-mode +1) + (with-current-buffer edit-buffer + (insert text) + (jsonian--unintern-special-chars (current-buffer)) + (goto-char (point-min)) + (run-hooks 'jsonian-edit-string-hook) + (setq-local jsonian-edit-return-var (make-jsonian--edit-return + :match match + :back-buffer cbuffer + :overlay overlay))) + (let ((windows (length (window-list-1)))) + ;; We observe the number of existing windows + (select-window (display-buffer edit-buffer #'display-buffer-pop-up-window)) + ;; Then we display the new buffer + (when (> (length (window-list-1)) windows) + ;; If we have added a new window, we note to delete that window when + ;; when we kill the display buffer + (with-current-buffer edit-buffer + (setf (jsonian--edit-return-delete-window jsonian-edit-return-var) t)))) + (jsonian--edit-mode +1) + (setq header-line-format + (substitute-command-keys + "Edit, then exit with `\\[jsonian-edit-mode-return]' or abort with \ +`\\[jsonian-edit-mode-cancel]'"))))) + +(defun jsonian--replace-text-in (start end text &optional buffer) + "Set the content of the region (START to END) to TEXT in BUFFER. +BUFFER defaults to the current buffer." + (with-current-buffer (or buffer (current-buffer)) + (goto-char start) + (save-excursion + (delete-region start end) + (insert text)))) + +(defun jsonian--intern-special-chars (buffer) + "Translates whitespace operators to their ansi equivalents in BUFFER. +This means replacing '\n' with '\\n', '\t' with '\\t', and escaping quotes and backslashes" + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (search-forward "\\" nil t) + (replace-match "\\\\\\\\")) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match "\\\\n")) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match "\\\\t")) + (goto-char (point-min)) + (while (search-forward "\"" nil t) + (replace-match "\\\\\""))))) + +(defun jsonian--unintern-special-chars (buffer) + "Translate special characters to their unescaped equivalents in BUFFER. +This means replacing '\\n' with '\n' and '\\t' with '\t' and unescaping escaped characters." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (search-forward "\\" nil t) + (let ((c (char-after))) + (delete-region (1- (point)) (1+ (point))) + (insert + (cond + ((eql c ?t) ?\t) + ((eql c ?n) ?\n) + (t c)))))))) + +(defun jsonian-edit-mode-return () + "Jump back from `json-edit-string', actualizing the change made." + (interactive) + (jsonian--edit-mode-ensure) + (jsonian--intern-special-chars (current-buffer)) + (let ((text (buffer-substring-no-properties (point-min) (point-max))) + (back-buffer (jsonian--edit-return-back-buffer jsonian-edit-return-var)) + (back-match (jsonian--edit-return-match jsonian-edit-return-var))) + (jsonian-edit-mode-cancel) + (jsonian--replace-text-in (car back-match) (cdr back-match) text back-buffer))) + +(defun jsonian-edit-mode-cancel () + "Jump back from `json-edit-string' without making a change." + (interactive) + (jsonian--edit-mode-ensure) + (let ((back-buffer (jsonian--edit-return-back-buffer jsonian-edit-return-var)) + (overlay (jsonian--edit-return-overlay jsonian-edit-return-var)) + (kill-window (jsonian--edit-return-delete-window jsonian-edit-return-var))) + (delete-overlay overlay) + + ;; Kill the display buffer + (if kill-window + (kill-buffer-and-window) + (kill-current-buffer)) + ;; Go back to the display window, if it exists. + ;; + ;; It should exist as long as Emacs is running with UI. + (if-let (w (get-buffer-window back-buffer)) + (select-window w) + (switch-to-buffer back-buffer)) + (read-only-mode -1))) + +(define-minor-mode jsonian--edit-mode + "Toggle edit-string-at-point mode. +This mode is used to setup editing functions for strings at point. +It should *not* be toggled manually." + ;; TODO: Should be a major mode + :global nil + :lighter " edit-string" + :keymap (list + (cons (kbd "C-c C-c") #'jsonian-edit-mode-return) + (cons (kbd "C-c C-k") #'jsonian-edit-mode-cancel))) + +(defun jsonian--edit-mode-ensure () + "Throw an error if edit-string-at-point-mode is not setup correctly." + (unless jsonian--edit-mode + (error "`jsonian--edit-mode' is not set")) + (unless jsonian-edit-return-var + (error "`jsonian--edit-mode' is set but jsonian-edit-return-var is not"))) + + +;; Caching JSON nodes and their locations +;; +;; All cached data is stored in the buffer local variable `jsonian--cache'. It +;; is invalidated after the buffer is changed. + +(defun jsonian--handle-change (&rest args) + "Handle a change in the buffer. +`jsonian--handle-change' is designed to be called from the +`before-change-functions' hook. ARGS is ignored." + (ignore args) + (setq jsonian--cache nil)) + +(cl-defstruct (jsonian--cache (:copier nil)) + "The jsonian node cache. O(1) lookup is supported via either location or path." + (locations (make-hash-table :test 'eql) :documentation "A map of locations to nodes.") + (paths (make-hash-table :test 'equal) :documentation "A map of paths to locations.")) + +(cl-defstruct jsonian--cached-node + "Information about a specific node in a JSON buffer." + (children nil :documentation "A list of the locations of child nodes. +If non-nil, the child nodes should exist in cache. +If the node is a leaf node, CHILDREN may be set to `'leaf'.") + (path nil :documentation "The full path to this node.") + (segment nil :documentation "The last segment in the path to this node. `segment' should +be equal to the last element of `path'.") + (type nil :documentation "The type of the node (as a string), used for display purposes.") + (preview nil :documentation "A preview of the value, containing test properties.")) + +(cl-defun jsonian--cache-node (location path &key children segment type preview) + "Cache information about a node. +LOCATION defines the primary key in the cache. +PATH is a secondary key in the cache. +Accepts the following optional keys: +CHILDREN is a list of child nodes in the form ( key . point). +SEGMENT is segment by which this node is accessed. If PATH is +supplied, then segment should equal (car (butlast path)). +TYPE is the type of the JSON node (as a string). +PREVIEW is a (fontified) string preview of the node." + (cl-assert + (integerp location) t + "Invalid location") + (jsonian--ensure-cache) + (puthash path location (jsonian--cache-paths jsonian--cache)) + (let ((existing (or + (gethash location + (jsonian--cache-locations jsonian--cache)) + (make-jsonian--cached-node :path path)))) + (when children + (setf (jsonian--cached-node-children existing) (mapcar #'cdr children))) + (if segment + (setf (jsonian--cached-node-segment existing) segment) + (if path + (setf (jsonian--cached-node-segment existing) (car (butlast path))))) + (when type + (setf (jsonian--cached-node-type existing) type)) + (when preview + (setf (jsonian--cached-node-preview existing) preview)) + (puthash location existing (jsonian--cache-locations jsonian--cache)))) + +(defun jsonian--ensure-cache () + "Ensure that a valid cache exists, creating one if necessary." + (cl-pushnew #'jsonian--handle-change before-change-functions) + (unless jsonian--cache + (setq jsonian--cache (make-jsonian--cache)))) + +(cl-defun jsonian--cached-find-children (path &key segment) + "Call `jsonian--find-children' and cache the result. +If the result is already in the cache, just return it. PATH and +SEGMENT refer to the parent. Either PATH or SEGMENT must be +supplied." + (jsonian--ensure-cache) + (if-let* ((node (gethash (point) (jsonian--cache-locations jsonian--cache))) + (children (jsonian--cached-node-children node))) + (unless (eq children 'leaf) + (seq-map + (lambda (x) + (cons + (jsonian--cached-node-segment (gethash x (jsonian--cache-locations jsonian--cache))) + x)) + children)) + (let ((result (jsonian--find-children))) + (mapc + (lambda (kv) + (jsonian--cache-node (cdr kv) (append path (list (car kv))) + :segment (car kv) + :type (jsonian--node-type (cdr kv)) + :preview (jsonian--node-preview (cdr kv)))) + result) + (jsonian--cache-node (point) path + :children result + :segment segment + :type (jsonian--node-type (point)) + :preview (jsonian--node-preview (point))) + result))) + + +;; The `jsonian-find' function. +;; +;; `jsonian-find' is implemented on top of `completing-read'. + +(defvar jsonian--find-buffer nil + "The buffer in which `jsonian-find' is currently operating in.") + +;;;###autoload +(defun jsonian-find (&optional path) + "Navigate to a item in a JSON document. +If PATH is supplied, navigate to it." + (interactive) + (setq jsonian--find-buffer (current-buffer)) + (if-let ((selection + (or path + (completing-read "Select Element: " #'jsonian--find-completion nil t + (save-excursion + (jsonian--snap-to-node) + (when-let* ((path (jsonian--reconstruct-path (jsonian--path))) + (display (jsonian--display-path path t))) + display)))))) + ;; We know that the path is valid since we chose it from the list of valid paths presented + (goto-char (jsonian--valid-path (jsonian--parse-path selection))))) + +(defun jsonian--find-completion (str predicate type) + "The function passed to `completing-read' to handle navigating the buffer. +STR is the string to be completed. +PREDICATE is a function by which to filter possible matches. +TYPE is a flag specifying the type of completion." + ;; See 21.6.7 Programmed Completion in the manual for more details + ;; (elisp)Programmed Completion + (with-current-buffer jsonian--find-buffer + (jsonian--ensure-cache) + (cond + ((eq type nil) + (jsonian--completing-nil (jsonian--parse-path str) predicate)) + ((eq type t) + (jsonian--completing-t (jsonian--parse-path str) predicate)) + ((eq type 'lambda) + (when (jsonian--valid-path (jsonian--parse-path str)) t)) + ((eq (car-safe type) 'boundaries) + (cons 'boundaries (jsonian--completing-boundary str (cdr type)))) + ((eq type 'metadata) + (cons 'metadata `((display-sort-function . ,(apply-partially #'jsonian--completing-sort str)) + (affixation-function . + ,(apply-partially #'jsonian--completing-affixation str jsonian--cache))))) + (t (error "Unexpected type `%s'" type))))) + +(defun jsonian--completing-affixation (prefix cache paths) + "Map each element in PATHS to (list ). + and may be nil if the necessary information is not cached. +PREFIX is the string currently being completed against. +CACHE is the value of `jsonian--cache' for the buffer being completed against." + (let ((max-value (+ 8 (seq-reduce #'max (seq-map #'length paths) 0)))) + (mapcar (lambda (path) + (let* ((is-index (string-match-p "^[0-9]+\\]$" path)) + (full-path (append + (butlast (jsonian--parse-path prefix)) + (jsonian--parse-path + (if is-index + (concat "[" path) + path)))) + (node (gethash + (gethash + full-path + (jsonian--cache-paths cache)) + (jsonian--cache-locations cache))) + (type (and node (jsonian--cached-node-type node)))) + (list + (jsonian--pad-string (- max-value 4) (if is-index (concat "[" path) path) t) + (propertize + (jsonian--pad-string + 10 (or type "") t) + 'face 'font-lock-comment-face) + (or (and node (jsonian--cached-node-preview node)) "")))) + paths))) + +(defun jsonian--filter-prefix (prefix paths) + "Filter out entries in PATHS that do not start with PREFIX." + (seq-filter (apply-partially #'string-prefix-p prefix) paths)) + +(defun jsonian--completing-sort (prefix paths) + "The completing sort function for `jsonian--find-completion'. +PREFIX is the string to compare against. +PATHS is the list of returned paths." + (if-let* ((segment (car-safe (last (jsonian--parse-path prefix)))) + (prefix (jsonian--display-segment-end segment))) + (sort + (funcall jsonian-find-filter-fn prefix paths) + (if (seq-every-p (apply-partially #'string-match-p "^[0-9]+\]$") paths) + ;; We are in an array, and indexes are numbers like "42]". We should sort them low to high. + (lambda (x y) (< (string-to-number x) (string-to-number y))) + ;; We are in a map, our keys are arbitrary strings, we should sort by edit distance. + (lambda (x y) (< (string-distance prefix x) (string-distance prefix y))))) + paths)) + +(defun jsonian--completing-t (path predicate) + "Compute the set of all possible completions for PATH that satisfy PREDICATE." + (if-let* ((parent-loc (jsonian--valid-path (butlast path))) + (is-collection (jsonian--at-collection parent-loc))) + (let ((result (seq-map + (lambda (x) + ;; We trim of the leading "[" or "." since it already exists + (let ((path (jsonian--display-path (list (car x)) t))) + (if (> (length path) 0) + (substring path 1) + path))) + (save-excursion + (goto-char parent-loc) + (jsonian--cached-find-children path))))) + (if predicate + (seq-filter predicate result) + result)))) + +(defun jsonian--completing-nil (path &optional predicate) + "The nil component of `jsonian--find-completion'. +PATH is a a list of path segments. PREDICATE is a function that +filters values. It takes a string as argument. According to the +docs: The function should return nil if there are no matches; it +should return t if the specified string is a unique and exact +match; and it should return the longest common prefix substring +of all matches otherwise." + (save-excursion + (let* ((final (car-safe (last path))) + (final-str (if final + (if (numberp final) + (number-to-string final) + final) + "")) + (result + (if-let* ((parent-loc (jsonian--valid-path (butlast path))) + (is-collection (jsonian--at-collection parent-loc))) + (save-excursion + (goto-char parent-loc) + (seq-filter + (lambda (kv) + (let ((k (if (car kv) + (if (numberp (car kv)) + (number-to-string (car kv)) + (car kv))))) + (string= final-str (substring k 0 (min (length final-str) (length k)))))) + (jsonian--cached-find-children path)))))) + (setq result + (if predicate + (seq-filter predicate result) + result)) + (cond + ((not result) nil) + ((= 1 (length result)) t) + (t (substring + ;; We trim of the leading "[" or "." since it already exists + (jsonian--display-path + (list (jsonian--longest-common-substring (mapcar #'car result))) t) + 1)))))) + +(defun jsonian--completing-boundary (str suffix) + "Calculate the completion boundary for `jsonian--find-completion'. +Here STR represents the completing string and SUFFIX the string after point." + ;; We first check if we are inside a string segment: ["INSIDE"] + (with-temp-buffer + (insert str suffix) + (goto-char (1+ (length str))) + (if-let ((str-start (jsonian--pos-in-stringp))) + (cons + str-start + (progn + (jsonian--string-scan-forward) + (- (point) (length str) 1))) + ;; Not in a string, so we can look backward and forward for dividing chars + ;; `?\[', `?\]', `?\"' and `?.' + (cons + (save-excursion + (while (and + (char-before) + (not (eq (char-before) ?\[)) + (not (eq (char-before) ?\")) + (not (eq (char-before) ?.))) + (backward-char)) + (1- (point))) + (- (progn (while (and + (char-after) + (not (eq (char-after) ?\])) + (not (eq (char-after) ?\")) + (not (eq (char-after) ?.))) + (forward-char)) + (point)) + (length str) 1))))) + +(defun jsonian--node-type (pos) + "Find the type of the node at POS. +POS must be at the beginning of a node. If no type is found, nil +is returned." + (save-excursion + (goto-char pos) + ;; Skip past a key if present + (when (eq (char-after) ?\") + (unless (and (jsonian--forward-token) + (eq (char-after) ?:) + (jsonian--forward-token)) + (goto-char pos))) + (pcase (char-after) + (?\" "string") + ((or ?t ?f) "boolean") + (?n "null") + (?\[ "array") + (?\{ "object") + ((pred (lambda (n) + (and (<= n ?9) + (>= n ?0)))) + "number")))) + +(defun jsonian--node-preview (pos) + "Provide a preview of the value of the node at POS. + +POS must be a valid node." + (save-excursion + (goto-char pos) + ;; Skip past a key if present + (when (eq (char-after) ?\") + (if (and (jsonian--forward-token) (eq (char-after) ?:)) + (jsonian--forward-token) + (goto-char pos))) + (pcase (char-after) + ;; We preview arrays and objects specially, since they are often arbitrarily large. + (?\[ (propertize "[ array ]" 'face 'font-lock-type-face)) + (?\{ (propertize "{ object }" 'face 'font-lock-type-face)) + (_ (buffer-substring (point) (and + (jsonian--forward-token) + jsonian--last-token-end)))))) + +(defun jsonian--find-children () + "Return a list of elements in the collection at point. +nil is returned if the object at point is not a collection." + (save-excursion + (when (jsonian--down-node) + (let (elements done + (obj-p (save-excursion (and (jsonian--forward-token) + (eq (char-after) ?:)))) + (count 0)) + (while (not done) + (setq elements + (cons + (cons + (if obj-p + (let ((end (save-excursion (forward-char) (jsonian--pos-in-keyp t)))) + (buffer-substring-no-properties (1+ (point)) (1- end))) + (prog1 count (cl-incf count))) + (point)) + elements)) + (setq done (eq (jsonian--forward-node) 'end))) + elements)))) + + +;; The jsonian major mode and the basic functions that support it. +;; Most functions in this page hook into existing emacs functionality. + +(defvar jsonian-syntax-table + (let ((s (make-syntax-table))) + ;; Objects + (modify-syntax-entry ?\{ "(}" s) + (modify-syntax-entry ?\} "){" s) + ;; Arrays + (modify-syntax-entry ?\[ "(]" s) + (modify-syntax-entry ?\] ")[" s) + ;; Strings + (modify-syntax-entry ?\" "\"" s) + ;; Syntax Escape + (modify-syntax-entry ?\\ "\\" s) + s) + "The syntax table for JSON.") + +(defvar jsonian-mode-map + (let ((km (make-sparse-keymap))) + (define-key km (kbd "C-c C-p") #'jsonian-path) + (define-key km (kbd "C-c C-s") #'jsonian-edit-string) + (define-key km (kbd "C-c C-e") #'jsonian-enclosing-item) + (define-key km (kbd "C-c C-f") #'jsonian-find) + (define-key km (kbd "C-c C-w") #'jsonian-format-region) + km) + "The mode-map for `jsonian-mode'.") + +;;;###autoload +(define-derived-mode jsonian-mode prog-mode "JSON" + "Major mode for editing JSON files." + :syntax-table jsonian-syntax-table + :group 'jsonian + (set (make-local-variable 'comment-start) "") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'indent-line-function) + #'jsonian-indent-line) + (set (make-local-variable 'indent-region-function) + #'jsonian-indent-region) + (set (make-local-variable 'beginning-of-defun-function) + #'jsonian-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + #'jsonian-end-of-defun) + (set (make-local-variable 'font-lock-defaults) + '(jsonian--font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . jsonian--syntactic-face))) + (cl-pushnew #'jsonian--handle-change before-change-functions) + (advice-add #'narrow-to-defun :before-until #'jsonian--correct-narrow-to-defun)) + +(defun jsonian--syntactic-face (state) + "The syntactic face function for the position represented by STATE. +STATE is a `parse-partial-sexp' state, and the returned function is the +JSON font lock syntactic face function." + (cond + ((nth 3 state) + ;; This might be a string or a name + (if (or (jsonian--after-key (nth 8 state)) + (not (save-excursion + (goto-char (nth 8 state)) + (jsonian--pos-in-keyp t)))) + font-lock-string-face + font-lock-keyword-face)) + ((nth 4 state) font-lock-comment-face))) + +(add-to-list 'hs-special-modes-alist '(jsonian-mode "{" "}" "/[*/]" nil)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.json\\'" . jsonian-mode)) + +(defvar jsonian--font-lock-keywords + (list (cons (regexp-opt '("true" "false" "null")) 'font-lock-constant-face)) + "Keywords in JSON (true|false|null).") + +(defun jsonian--infer-indentation () + "Infer the level of indentation at point." + (save-excursion + (forward-line 0) + (let ((indent nil) + (origin (point)) + (done nil) + parent-position) + (while (not done) + (setq parent-position (nth 1 (syntax-ppss))) + (if parent-position + (progn + (setq indent (jsonian--infer-indentation-from-container + parent-position + origin)) + (if indent + (setq done t) + (goto-char parent-position))) + (setq done t))) + (unless indent + (goto-char (point-min)) + (forward-comment (point-max)) + (when (memq (char-after) '(?\[ ?{)) + (setq indent (jsonian--infer-indentation-from-container (point))))) + indent))) + +(defun jsonian--infer-indentation-from-container + (container-position &optional end) + "Infer the level of indentation from array/object at CONTAINER-POSITION. + +If END is non-nil, inspect only before it." + (save-excursion + (let (indent) + (goto-char container-position) + (forward-char) + ;; TODO: Should we ignore comments? + (skip-chars-forward "\s\t") + (when (eolp) + (skip-chars-forward "\s\t\n") + (when (and (not (memq (char-after) '(?\] ?}))) + (or (not end) (< (point) end))) + (setq indent (- (current-column) + (progn + (goto-char container-position) + (current-column)))) + (and (< 0 indent) indent)))))) + +(defun jsonian--indentation-spaces () + "The number of spaces per indentation level. +Either set or inferred." + (or + jsonian-indentation + (if-let* ((indent (jsonian--infer-indentation)) + (not-zero (> indent 0))) + indent + jsonian-default-indentation))) + +;;;###autoload +(defun jsonian-indent-line () + "Indent a single line. +The indent is determined by examining the previous line. The +number of spaces is determined by `jsonian-indentation' if it is +set, otherwise it is inferred from the document." + (interactive) + (let* ((indent (jsonian--indentation-spaces)) + (indent-level (jsonian--get-indent-level indent)) + (current-indent + (save-excursion (back-to-indentation) (current-column)))) + (if (<= (current-column) current-indent) + ;; The cursor is on the left margin. Moving to the new indent. + (indent-line-to indent-level) + ;; Keeps current relative position. + (save-excursion (indent-line-to indent-level))))) + +(defun jsonian--get-indent-level (indent &optional previous-level parent-level) + "Find the indentation level of the current line. +The indentation level of the current line is derived from the +indentation level of the previous line. INDENT is the number of +spaces in each indentation level. + +If PREVIOUS-LEVEL is non-nil, it is used as the indentation column of +the previous member. + +If PARENT-LEVEL is non-nil, it is used as the indentation column of +the parent member." + (save-excursion + (forward-line 0) + (if (jsonian--enclosing-comment-p (point)) + ;; Inside comments. Keep as is. + (current-indentation) + (skip-chars-forward "\s\t") + (let ((next-char (char-after)) + previous-char) + (cond + ;; Indenting a close bracket. + ((memq next-char '(?\] ?})) + (or parent-level + (progn + (forward-char) + (jsonian--current-indentation)))) + + ;; Indenting a colon. + ((eq next-char ?:) + (+ (or previous-level + (jsonian--current-indentation)) + indent)) + + ;; Otherwise. + (t + (setq previous-char (save-excursion + (forward-comment (- (point))) + (char-before))) + (if (eq previous-char ?:) + ;; After a colon. + ;; + ;; { + ;; "aaa": + ;; 111 + ;; } + (+ (or previous-level + (jsonian--current-indentation)) + indent) + ;; Indening a value. + (or previous-level + (if (progn + (jsonian--backward-member) + (eq (char-before) ?,)) + ;; The current member isn't the first member. + ;; Align to the preceding sibling. + (progn + (backward-char) + (jsonian--current-indentation)) + (if (memq (char-before) '(?\[ ?{)) + ;; The current member is the first member. + ;; Align to the parent. + (+ (or parent-level + (progn + (backward-char) + (jsonian--current-indentation))) + indent) + ;; Beginning of the buffer. + 0)))))))))) + +(defun jsonian--backward-member () + "Move point to the end of the previous member or open bracket. + +After returning from this function, `char-before' should return a comma, +open brackets, or nil (beginning of the buffer)." + (let ((done nil)) + (while (not done) + (skip-chars-backward "^,[]{}\"/\n") + (cond + ;; Found it. + ((or (bobp) + (memq (char-before) '(?, ?\[ ?{))) + (setq done t)) + + ;; Close brackets or strings. + ((memq (char-before) '(?\] ?} ?\")) + (backward-sexp)) + + ;; Maybe comments. + ((memq (char-before) '(?/ ?\n)) + (if (jsonian--enclosing-comment-p (1- (point))) + (jsonian--backward-comment) + (backward-char))))))) + +(defun jsonian--current-indentation () + "Return the indentation level of the current member. + +It is the indentation level of the current or preceding member which +is either at the beginning of a line or at the beginning of the +containing array/object." + (save-excursion + ;; FIXME: maybe, we should align to comments at the beginning of a + ;; line if any. + (jsonian--backward-member) + (while (and (save-excursion + (forward-comment (point-max)) + (skip-chars-backward "\s\t") + (not (bolp))) + (eq (char-before) ?,)) + (backward-char) + (jsonian--backward-member)) + (forward-comment (point-max)) + (current-column))) + +;;;###autoload +(defun jsonian-indent-region (start end) + "Indent the region from START to END." + (interactive "r") + (save-excursion + (let ((indent (jsonian--indentation-spaces)) + ;; Indent levels of siblings, parent, grand parent, and so on. + (levels '()) + progress + next-char + parser-state) + (setq end (copy-marker end)) + (goto-char start) + (jsonian-indent-line) + (when (jsonian--enclosing-comment-p (point)) + (jsonian--backward-comment)) + (setq parser-state (syntax-ppss)) + ;; Exit from a string. + (when (nth 3 parser-state) + (goto-char (nth 8 parser-state))) + (setq progress (make-progress-reporter "Indenting region..." (point) end)) + ;; Scan forward and indent lines. + (while (< (point) end) + (progress-reporter-update progress (point)) + (skip-chars-forward "^[]{}\"/\n") + (setq next-char (char-after)) + (cond + ;; Found a new line. Indent it. Use cache if available. + ;; Otherwise, indent as normal and cache it. + ((eq next-char ?\n) + (forward-char) + (skip-chars-forward "\s\t") + ;; Do not indent empty lines. + (when (and (not (eolp)) (< (point) end)) + (if levels + (indent-line-to (jsonian--get-indent-level indent + (nth 0 levels) + (nth 1 levels))) + (jsonian-indent-line) + (push (jsonian--current-indentation) levels)))) + + ;; Open brackets. + ((memq next-char '(?\[ ?{)) + (push + ;; If the bracket is at the end of the line, current + ;; indentation level + `indent' is the indentation level of + ;; children. + (if (save-excursion + (forward-char) + (skip-chars-forward "\s\t") + (eolp)) + (prog1 + (+ (if levels + (car levels) + (jsonian--current-indentation)) + indent) + (forward-char)) + ;; Otherwise, this line have the first child, so record + ;; its column to the cache. + ;; + ;; Example: + ;; [ 1, + ;; 2, + ;; 3 ] + (forward-char) + (skip-chars-forward "\s\t") + (current-column)) + levels)) + + ;; Close brackets. + ((memq next-char '(?\] ?})) + (pop levels) + (forward-char)) + + ;; Strings. + ((eq next-char ?\") + (forward-sexp)) + + ;; Maybe comments. + ((eq next-char ?/) + (if (forward-comment 1) + (when (eq (char-before) ?\n) + (backward-char)) + (forward-char))))) + (progress-reporter-done progress)) + (set-marker end nil nil))) + +(defmacro jsonian--huge-edit (start end &rest body) + "Evaluate form BODY with optimizations for huge edits. +Run the change hooks just once like `combine-change-calls'. +Create undo entries as if the contents from START to END are replaced at once. +BODY must not modify buffer outside the region (START END), nor move any markers +out of the region." + (declare (debug (form form def-body)) (indent 2)) + (let ((start-value (make-symbol "start")) + (end-value (make-symbol "end"))) + `(let ((,start-value ,start) + (,end-value ,end)) + ;; WORKAROUND: If buffer-undo-list is nil, combine-change-calls shows + ;; unnecessary message. + ;; https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=977630b5285809a57e50ff5f38d9c34247b549a7 + (unless buffer-undo-list + (push (point) buffer-undo-list)) + (,(if (fboundp 'combine-change-calls) + 'combine-change-calls + 'combine-after-change-calls) + ,start-value + ,end-value + (jsonian--huge-edit-1 ,start-value ,end-value (lambda () ,@body)))))) + +(defun jsonian--huge-edit-1 (start end body) + "Evaluate a function BODY with optimizations for huge edits. +Create undo entries as if the contents from START to END are replaced at once. +BODY must not modify buffer outside the region (START END), nor move any markers +out of the region." + (let ((old-undo-list buffer-undo-list) + (undo-inhibit-record-point t) + deletion-undo-list) + ;; Clear the undo list. + (buffer-disable-undo) + (buffer-enable-undo) + (unwind-protect + (atomic-change-group + (delete-region start end) + ;; This contains restoreing the region and markers inside it. + (setq deletion-undo-list buffer-undo-list) + (primitive-undo (length deletion-undo-list) deletion-undo-list)) + (setq buffer-undo-list old-undo-list)) + (setq start (copy-marker start)) + (setq end (copy-marker end)) + (buffer-disable-undo) + (unwind-protect + (funcall body) + ;; Note that setting `buffer-undo-list' enables undo again. + (setq buffer-undo-list + (append (cons + (cons (jsonian--free-marker start) + (jsonian--free-marker end)) + deletion-undo-list) + old-undo-list))))) + +(defun jsonian--free-marker (marker) + "Make MARKER pointing nowhere and return the old position." + (prog1 (marker-position marker) + (set-marker marker nil nil))) + +;;;###autoload +(defun jsonian-format-region (start end &optional minimize) + "Format the region (START . END). + +If MINIMIZE is non-nil, minimize the region instead of expanding it." + (interactive "*r\nP") + (let ((current-point (point-marker))) + (jsonian--huge-edit start end + ;; Both `inhibit-modification-hooks' and `undo-inhibit-record-point' must be inside + ;; `jsonian--huge-edit' to allow `jsonian--huge-edit' to handle changes + ;; appropriately. + (let ((inhibit-modification-hooks t) + (undo-inhibit-record-point t) + (end (progn (goto-char end) (point-marker)))) + (goto-char start) + (jsonian--snap-to-token) + (let* ((indent (jsonian--indentation-spaces)) + (indent-level (jsonian--get-indent-level indent)) + (next-token (make-marker)) + ;; Don't allocate a new string each time you add indentation. + ;; + ;; In effect, this is where we intern strings on behalf of elisp. + (indent-strings '("\n")) + (progress (make-progress-reporter "Formatting region..." start (* (- end start) 1.5)))) + (set-marker-insertion-type next-token t) + (while (and + (< (point) end) + (jsonian--forward-token t)) + (progress-reporter-update progress (point)) + ;; Delete the whitespace between the old token and the next token. + (set-marker next-token (point)) + (delete-region jsonian--last-token-end (point)) + (unless (or minimize (>= (point) end)) + ;; Unless we are minimizing, insert the appropriate whitespace. + (cond + ;; A space separates : from the next token + ;; + ;; "foo": bar + ;; ^space + ((eq (char-before jsonian--last-token-end) ?:) + (goto-char jsonian--last-token-end) + (insert " ") + (goto-char next-token)) + ;; If the second of the abutting tokens is a ",", then we don't make any + ;; adjustments. + ((memq (char-after) '(?, ?:))) + + ;; Empty objects and arrays are formatted as {} and [], respectively. + ((and (eq (char-before) ?\[) (eq (char-after) ?\]))) + ((and (eq (char-before) ?\{) (eq (char-after) ?\}))) + + ;; All other items are separated by a new line, then the appropriate indentation. + (t + (when (memq (char-after) '(?\] ?\})) + (cl-decf indent-level indent)) + (when (memq (char-before jsonian--last-token-end) '(?\[ ?\{)) + (cl-incf indent-level indent)) + (while (<= (length indent-strings) indent-level) + (setq indent-strings + (append indent-strings + (list (concat + "\n" + (make-string (length indent-strings) + ?\s)))))) + (insert (nth indent-level indent-strings)) + (goto-char next-token))))) + (progress-reporter-done progress)))) + (goto-char current-point))) + +(defun jsonian-beginning-of-defun (&optional arg) + "Move to the beginning of the smallest object/array enclosing `POS'. +ARG is currently ignored." + (ignore arg) ;; TODO use ARG correctly + (and + (jsonian--snap-to-node) + (jsonian--up-node))) + +(defun jsonian-end-of-defun (&optional arg) + "Move to the end of the smallest object/array enclosing `POS'. +ARG is currently ignored." + (ignore arg) + (when (and + (jsonian--snap-to-node) + (jsonian--up-node)) + (pcase (char-after) + ((or ?\[ ?\{) + (forward-list)) + (?\" + (and + (jsonian--forward-token) + (eq (char-after) ?:) + (jsonian--forward-token) + (when (memq (char-after) '(?\[ ?\{)) + (forward-list))))) + t)) + +(defun jsonian-narrow-to-defun (&optional arg) + "Narrows to region for `jsonian-mode'. ARG is ignored." + ;; Arg is present to comply with the function signature of `narrow-to-defun'. + ;; Its value is ignored. + (ignore arg) + (let (start end) + (when (setq start (save-excursion (and (jsonian-beginning-of-defun) (point)))) + (setq end (save-excursion (and (jsonian-end-of-defun) (point))))) + (when (and start end) + (narrow-to-region start end)))) + +(defun jsonian--correct-narrow-to-defun (&optional arg) + "Correct `narrow-to-defun' for `jsonian-mode' via the advice system. +ARG is passed onto `jsonian-narrow-to-defun'. This function is +designed to be installed with `advice-add' and `:before-until'." + (interactive) + (when (derived-mode-p 'jsonian-mode) + (jsonian-narrow-to-defun arg) + t)) + +(defvar jsonian--so-long-predicate nil + "The function originally assigned to `so-long-predicate'.") + +(defun jsonian-unload-function () + "Unload `jsonian'." + (advice-remove #'narrow-to-defun #'jsonian--correct-narrow-to-defun) + (defvar so-long-predicate) + (when jsonian--so-long-predicate + (setq so-long-predicate jsonian--so-long-predicate))) + + +;; The major mode for jsonian-c mode. + +(defvar jsonian-c-syntax-table + (let ((s (make-syntax-table jsonian-syntax-table))) + ;; We set / to be a punctuation character with the following additional + ;; properties: + ;; 1 -> The first character to begin a (class a|b) comment + ;; 2 -> The second character to begin a (class a) comment + ;; 4 -> The second character to end a (class a|b) comment + (modify-syntax-entry ?/ ". 124" s) + ;; \n ends (class a) comments + (modify-syntax-entry ?\n "> " s) + ;; * is a punctuation character as well as: + ;; 2 -> The second character to begin a (class b) comment + ;; 3 -> The first character to end a (class b) comment + ;; b -> Only effect class b + (modify-syntax-entry ?* ". 23b" s) + s) + "The syntax table for jsonian-c-mode.") + +;;;###autoload +(define-derived-mode jsonian-c-mode jsonian-mode "JSONC" + "A major mode for editing JSON documents with comments." + :syntax-table jsonian-c-syntax-table + :group 'jsonian-c + (set (make-local-variable 'comment-start) "// ") + (set (make-local-variable 'comment-add) 1) + (set (make-local-variable 'font-lock-syntax-table) + jsonian-c-syntax-table)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.jsonc\\'" . jsonian-c-mode)) + + +;; Foreign integration + +;;;###autoload +(defun jsonian-enable-flycheck () + "Enable `jsonian-mode' for all checkers where `json-mode' is enabled." + (interactive) + (unless (boundp 'flycheck-checkers) + (error "Flycheck needs to be loaded")) + (defvar flycheck-checkers) + (declare-function flycheck-checker-get "flycheck") + (declare-function flycheck-add-mode "flycheck") + (let ((checkers flycheck-checkers)) + (while checkers + (when (seq-some (apply-partially #'eq 'json-mode) + (flycheck-checker-get (car checkers) 'modes)) + (flycheck-add-mode (car checkers) 'jsonian-mode)) + (setq checkers (cdr checkers))))) + +;;;###autoload +(defun jsonian-no-so-long-mode () + "Prevent `so-long-mode' from supplanting `jsonian-mode'." + (interactive) + (unless (boundp 'so-long-predicate) + (user-error "`so-long' mode needs to be loaded")) + (defvar so-long-predicate) + (setq jsonian--so-long-predicate so-long-predicate) + (setq so-long-predicate + (lambda () + (unless (eq major-mode 'jsonian-mode) + (funcall jsonian--so-long-predicate))))) + + +;; Miscellaneous utility functions + +(defun jsonian--pad-string (len string &optional pad-right) + "Pad STRING to LEN by prefixing it with spaces." + (cl-assert (wholenump len) nil "jsonian--pad-string") + (if (<= len (length string)) + string + (if pad-right + (concat + string + (make-string (- len (length string)) ?\ )) + (concat + (make-string (- len (length string)) ?\ ) + string)))) + +(defun jsonian--type-index-string (type) + "Return the string necessary to index into TYPE. +If TYPE does not support some form of indexing, then nil is +returned." + (cond + ((equal type "array") "[") + ((equal type "object") "."))) + +(defun jsonian--display-segment-end (segment) + "Displays SEGMENT with it's closer. +For example the segment \"foo\" ends as \"foo\", while 3 ends as \"3]\". +The segment \"foo bar\" would end as \"foo bar\\\"]." + (cond + ((numberp segment) (format "%d]" segment)) + ((jsonian--simple-path-segment-p segment) segment) + (t (format "[\"%s\"]" segment)))) + +(defun jsonian--longest-common-substring (strings) + "Find the longest common sub-string among the list STRINGS." + (let* ((sorted (sort strings #'string<)) + (first (car-safe sorted)) + (last (car-safe (last sorted))) + (i 0) result) + (while (and (< i (length first)) + (< i (length last)) + (not result)) + (if (= (aref first i) (aref last i)) + (setq i (1+ i)) + (setq result t))) + (substring first 0 i))) + +(defun jsonian--unexpected-char (direction &optional expecting) + "Signal a `user-error' that EXPECTING was expected, but not found. +DIRECTION indicates if parsing is forward (:forward) or backward (:backward)." + (user-error + "%s: unexpected character '%s' at %d:%d%s\n%s" + (jsonian--enclosing-public-frame) + (let ((bound + (cond + ((eq direction :backward) (list #'bobp "BOB" #'char-before)) + ((eq direction :forward) (list #'eobp "EOB" #'char-after)) + (t (error "Expecting :forward or :backward, found %s" direction))))) + (if (funcall (car bound)) + (cadr bound) + (let ((c (funcall (caddr bound)))) + (cond + ((eq c ?\n) "\\n") + ((eq c ?\t) "\\t") + (t (format "%c" c)))))) + (line-number-at-pos) (if (and (eq direction :backward) (> (current-column) 0)) + (1- (current-column)) + (current-column)) + (if expecting + (format ": expecting %s" expecting) + "") + (let* ((column-start-pos (save-excursion (beginning-of-line) (point))) + (column-end-pos (save-excursion (end-of-line) (point))) + (window-start (max column-start-pos (- (point) 40))) + (window-end (min column-end-pos (+ (point) 40)))) + (concat + (buffer-substring window-start window-end) "\n" + (make-string (let ((pos (- (point) window-start))) + (if (and (eq direction :backward) (> pos 0)) + (1- pos) + pos)) + ? ) + "^")))) + +(defun jsonian--enclosing-public-frame () + "The public jsonian- function that directly encloses the current stack frame." + ;; i=3 gets us to the function that called `jsonian--enclosing-public-frame'. + (let* ((i 3) (frame (backtrace-frame i)) + (disp (lambda (x) (if (symbolp x) (symbol-name x) (format "%s" x)))) + ;; We take that function as a backup value + (ret-val (funcall disp (nth 1 frame)))) + (while frame + (let ((fn-name (funcall disp (nth 1 frame)))) + (if (and (string-prefix-p "jsonian-" fn-name) + (not (string-prefix-p "jsonian--" fn-name))) + (setq ret-val fn-name + frame nil) + (setq i (1+ i) + frame (backtrace-frame i))))) + ret-val)) + +(provide 'jsonian) + +;;; jsonian.el ends here diff --git a/site-lisp/extensions-local/ld-delete-block.el b/site-lisp/extensions-local/ld-delete-block.el deleted file mode 100644 index 494a9ed..0000000 --- a/site-lisp/extensions-local/ld-delete-block.el +++ /dev/null @@ -1,38 +0,0 @@ -;; -*- coding: utf-8; -*- -;;; Require: -(require 'subword) - -;;; Code: -(defun ld-delete-one-block-forward () - (interactive) - (if (eobp) - (message "End of buffer") - (let* ((syntax-move-point - (save-excursion - (skip-syntax-forward (string (char-syntax (char-after)))) - (point) - )) - (subword-move-point - (save-excursion - (subword-forward) - (point)))) - (kill-region (point) (min syntax-move-point subword-move-point))))) - -(defun ld-delete-one-block-backward () - (interactive) - (if (bobp) - (message "Beginning of buffer") - (let* ((syntax-move-point - (save-excursion - (skip-syntax-backward (string (char-syntax (char-before)))) - (point) - )) - (subword-move-point - (save-excursion - (subword-backward) - (point)))) - (kill-region (point) (max syntax-move-point subword-move-point))))) - -(provide 'ld-delete-block) - -;;; ld-delete-block.el ends here \ No newline at end of file diff --git a/site-lisp/extensions-local/ld-buffer-operations.el b/site-lisp/extensions-local/ld-file-and-buffer-operations.el similarity index 81% rename from site-lisp/extensions-local/ld-buffer-operations.el rename to site-lisp/extensions-local/ld-file-and-buffer-operations.el index 426084e..00fdc29 100644 --- a/site-lisp/extensions-local/ld-buffer-operations.el +++ b/site-lisp/extensions-local/ld-file-and-buffer-operations.el @@ -6,10 +6,16 @@ "Automatic format current buffer." (interactive) (cond + ;; judge by mode ((derived-mode-p 'python-mode) (message "Don't indent python buffer. It will mess up the code syntax.")) ((derived-mode-p 'yaml-mode) (message "Don't indent yaml buffer. It will mess up the code syntax.")) + ;; judge by buffer name + ((string-suffix-p ".yml" (buffer-name) t) + (message "Don't indent yaml buffer. It will mess up the code syntax.")) + ((string-suffix-p ".yaml" (buffer-name) t) + (message "Don't indent yaml buffer. It will mess up the code syntax.")) (t (save-excursion (indent-region (point-min) (point-max) nil) @@ -67,6 +73,15 @@ (switch-to-buffer current-element) (deactivate-mark))) +; --- + +(defun ld-find-file-in-root (file) + "Find file with root." + (interactive "fFind file as sudo: ") + (require 'tramp) + (tramp-cleanup-all-connections) + (find-file (concat "/sudo:root@localhost:" file))) + (provide 'ld-buffer-operations) ;;; ld-buffer-operations.el ends here diff --git a/site-lisp/extensions-local/ld-file-operations.el b/site-lisp/extensions-local/ld-file-operations.el deleted file mode 100644 index 0b08aad..0000000 --- a/site-lisp/extensions-local/ld-file-operations.el +++ /dev/null @@ -1,14 +0,0 @@ -;; -*- coding: utf-8; -*- -;;; Require: - -;;; Code: -(defun ld-find-file-in-root (file) - "Find file with root." - (interactive "fFind file as sudo: ") - (require 'tramp) - (tramp-cleanup-all-connections) - (find-file (concat "/sudo:root@localhost:" file))) - -(provide 'ld-file-operations) - -;;; ld-file-operations.el ends here diff --git a/site-lisp/extensions-local/ld-goto-cursor-stack.el b/site-lisp/extensions-local/ld-goto-cursor-stack.el deleted file mode 100644 index 0d065c1..0000000 --- a/site-lisp/extensions-local/ld-goto-cursor-stack.el +++ /dev/null @@ -1,39 +0,0 @@ -;; -*- coding: utf-8; -*- -;;; Require: - -;;; Code: -(defvar ld-cursor-position-stack nil - "Cursor position stack.") - -(defun ld-cursor-position-1-store () - "Remember current position and setup." - (interactive) - (point-to-register 8) - (message "Have remember one position")) - -(defun ld-cursor-position-1-jump () - "Jump to latest position and setup." - (interactive) - (let ((tmp (point-marker))) - (jump-to-register 8) - (set-register 8 tmp)) - (message "Have back to remember position")) - -(defun ld-cursor-position-stack-push () - "Push current point in stack." - (interactive) - (message "Location marked.") - (setq ld-cursor-position-stack (cons (list (current-buffer) (point)) ld-cursor-position-stack))) - -(defun ld-cursor-position-stack-pop () - "Pop point from stack." - (interactive) - (if (null ld-cursor-position-stack) - (message "Stack is empty.") - (switch-to-buffer (caar ld-cursor-position-stack)) - (goto-char (cadar ld-cursor-position-stack)) - (setq ld-cursor-position-stack (cdr ld-cursor-position-stack)))) - -(provide 'ld-goto-cursor-stack) - -;;; ld-goto-cursor-stack.el ends here diff --git a/site-lisp/extensions-local/ld-toggle-one-window.el b/site-lisp/extensions-local/ld-toggle-one-window.el deleted file mode 100644 index 0690222..0000000 --- a/site-lisp/extensions-local/ld-toggle-one-window.el +++ /dev/null @@ -1,22 +0,0 @@ -;; -*- coding: utf-8; -*- -;;; Require: - -;;; Code: -(defvar ld-toggle-one-window-config-of-window nil - "The window configuration used for `toggle-one-window'.") - -(defun ld-toggle-one-window () - "Toggle between window layout and one window." - (interactive) - (if (equal (length (cl-remove-if #'window-dedicated-p (window-list))) 1) - (if toggle-one-window-config-of-window - (progn - (set-window-configuration toggle-one-window-config-of-window) - (setq toggle-one-window-config-of-window nil)) - (message "No other windows exist.")) - (setq toggle-one-window-config-of-window (current-window-configuration)) - (delete-other-windows))) - -(provide 'ld-toggle-one-window) - -;;; ld-toggle-one-window.el ends here \ No newline at end of file diff --git a/site-lisp/extensions-local/markdown-mode.el b/site-lisp/extensions-local/markdown-mode.el new file mode 100644 index 0000000..2ce2dd5 --- /dev/null +++ b/site-lisp/extensions-local/markdown-mode.el @@ -0,0 +1,10422 @@ +;;; markdown-mode.el --- Major mode for Markdown-formatted text -*- lexical-binding: t; -*- + +;; Copyright (C) 2007-2023 Jason R. Blevins and markdown-mode +;; contributors (see the commit log for details). + +;; Author: Jason R. Blevins +;; Maintainer: Jason R. Blevins +;; Created: May 24, 2007 +;; Version: 2.7 +;; Package-Requires: ((emacs "27.1")) +;; Keywords: Markdown, GitHub Flavored Markdown, itex +;; URL: https://jblevins.org/projects/markdown-mode/ + +;; 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: + +;; See the README.md file for details. + + +;;; Code: + +(require 'easymenu) +(require 'outline) +(require 'thingatpt) +(require 'cl-lib) +(require 'url-parse) +(require 'button) +(require 'color) +(require 'rx) +(require 'subr-x) + +(defvar jit-lock-start) +(defvar jit-lock-end) +(defvar flyspell-generic-check-word-predicate) +(defvar electric-pair-pairs) +(defvar sh-ancestor-alist) + +(declare-function project-roots "project") +(declare-function sh-set-shell "sh-script") +(declare-function mailcap-file-name-to-mime-type "mailcap") +(declare-function dnd-get-local-file-name "dnd") + +;; for older emacs<29 +(declare-function mailcap-mime-type-to-extension "mailcap") +(declare-function file-name-with-extension "files") +(declare-function yank-media-handler "yank-media") + + +;;; Constants ================================================================= + +(defconst markdown-mode-version "2.7" + "Markdown mode version number.") + +(defconst markdown-output-buffer-name "*markdown-output*" + "Name of temporary buffer for markdown command output.") + + +;;; Global Variables ========================================================== + +(defvar markdown-reference-label-history nil + "History of used reference labels.") + +(defvar markdown-live-preview-mode nil + "Sentinel variable for command `markdown-live-preview-mode'.") + +(defvar markdown-gfm-language-history nil + "History list of languages used in the current buffer in GFM code blocks.") + +(defvar markdown-follow-link-functions nil + "Functions used to follow a link. +Each function is called with one argument, the link's URL. It +should return non-nil if it followed the link, or nil if not. +Functions are called in order until one of them returns non-nil; +otherwise the default link-following function is used.") + + +;;; Customizable Variables ==================================================== + +(defvar markdown-mode-hook nil + "Hook run when entering Markdown mode.") + +(defvar markdown-before-export-hook nil + "Hook run before running Markdown to export XHTML output. +The hook may modify the buffer, which will be restored to it's +original state after exporting is complete.") + +(defvar markdown-after-export-hook nil + "Hook run after XHTML output has been saved. +Any changes to the output buffer made by this hook will be saved.") + +(defgroup markdown nil + "Major mode for editing text files in Markdown format." + :prefix "markdown-" + :group 'text + :link '(url-link "https://jblevins.org/projects/markdown-mode/")) + +(defcustom markdown-command (let ((command (cl-loop for cmd in '("markdown" "pandoc" "markdown_py") + when (executable-find cmd) + return (file-name-nondirectory it)))) + (or command "markdown")) + "Command to run markdown." + :group 'markdown + :type '(choice (string :tag "Shell command") (repeat (string)) function)) + +(defcustom markdown-command-needs-filename nil + "Set to non-nil if `markdown-command' does not accept input from stdin. +Instead, it will be passed a filename as the final command line +option. As a result, you will only be able to run Markdown from +buffers which are visiting a file." + :group 'markdown + :type 'boolean) + +(defcustom markdown-open-command nil + "Command used for opening Markdown files directly. +For example, a standalone Markdown previewer. This command will +be called with a single argument: the filename of the current +buffer. It can also be a function, which will be called without +arguments." + :group 'markdown + :type '(choice file function (const :tag "None" nil))) + +(defcustom markdown-open-image-command nil + "Command used for opening image files directly. +This is used at `markdown-follow-link-at-point'." + :group 'markdown + :type '(choice file function (const :tag "None" nil))) + +(defcustom markdown-hr-strings + '("-------------------------------------------------------------------------------" + "* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" + "---------------------------------------" + "* * * * * * * * * * * * * * * * * * * *" + "---------" + "* * * * *") + "Strings to use when inserting horizontal rules. +The first string in the list will be the default when inserting a +horizontal rule. Strings should be listed in decreasing order of +prominence (as in headings from level one to six) for use with +promotion and demotion functions." + :group 'markdown + :type '(repeat string)) + +(defcustom markdown-bold-underscore nil + "Use two underscores when inserting bold text instead of two asterisks." + :group 'markdown + :type 'boolean) + +(defcustom markdown-italic-underscore nil + "Use underscores when inserting italic text instead of asterisks." + :group 'markdown + :type 'boolean) + +(defcustom markdown-marginalize-headers nil + "When non-nil, put opening atx header markup in a left margin. + +This setting goes well with `markdown-asymmetric-header'. But +sadly it conflicts with `linum-mode' since they both use the +same margin." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-marginalize-headers-margin-width 6 + "Character width of margin used for marginalized headers. +The default value is based on there being six heading levels +defined by Markdown and HTML. Increasing this produces extra +whitespace on the left. Decreasing it may be preferred when +fewer than six nested heading levels are used." + :group 'markdown + :type 'integer + :safe 'natnump + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-asymmetric-header nil + "Determines if atx header style will be asymmetric. +Set to a non-nil value to use asymmetric header styling, placing +header markup only at the beginning of the line. By default, +balanced markup will be inserted at the beginning and end of the +line around the header title." + :group 'markdown + :type 'boolean) + +(defcustom markdown-indent-function 'markdown-indent-line + "Function to use to indent." + :group 'markdown + :type 'function) + +(defcustom markdown-indent-on-enter t + "Determines indentation behavior when pressing \\[newline]. +Possible settings are nil, t, and \\='indent-and-new-item. + +When non-nil, pressing \\[newline] will call `newline-and-indent' +to indent the following line according to the context using +`markdown-indent-function'. In this case, note that +\\[electric-newline-and-maybe-indent] can still be used to insert +a newline without indentation. + +When set to \\='indent-and-new-item and the point is in a list item +when \\[newline] is pressed, the list will be continued on the next +line, where a new item will be inserted. + +When set to nil, simply call `newline' as usual. In this case, +you can still indent lines using \\[markdown-cycle] and continue +lists with \\[markdown-insert-list-item]. + +Note that this assumes the variable `electric-indent-mode' is +non-nil (enabled). When it is *disabled*, the behavior of +\\[newline] and `\\[electric-newline-and-maybe-indent]' are +reversed." + :group 'markdown + :type '(choice (const :tag "Don't automatically indent" nil) + (const :tag "Automatically indent" t) + (const :tag "Automatically indent and insert new list items" indent-and-new-item))) + +(defcustom markdown-enable-wiki-links nil + "Syntax highlighting for wiki links. +Set this to a non-nil value to turn on wiki link support by default. +Support can be toggled later using the `markdown-toggle-wiki-links' +function or \\[markdown-toggle-wiki-links]." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-alias-first t + "When non-nil, treat aliased wiki links like [[alias text|PageName]]. +Otherwise, they will be treated as [[PageName|alias text]]." + :group 'markdown + :type 'boolean + :safe 'booleanp) + +(defcustom markdown-wiki-link-search-subdirectories nil + "When non-nil, search for wiki link targets in subdirectories. +This is the default search behavior for GitHub and is +automatically set to t in `gfm-mode'." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-search-parent-directories nil + "When non-nil, search for wiki link targets in parent directories. +This is the default search behavior of Ikiwiki." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-search-type nil + "Searching type for markdown wiki link. + +sub-directories: search for wiki link targets in sub directories +parent-directories: search for wiki link targets in parent directories +project: search for wiki link targets under project root" + :group 'markdown + :type '(set + (const :tag "search wiki link from subdirectories" sub-directories) + (const :tag "search wiki link from parent directories" parent-directories) + (const :tag "search wiki link under project root" project)) + :package-version '(markdown-mode . "2.5")) + +(make-obsolete-variable 'markdown-wiki-link-search-subdirectories 'markdown-wiki-link-search-type "2.5") +(make-obsolete-variable 'markdown-wiki-link-search-parent-directories 'markdown-wiki-link-search-type "2.5") + +(defcustom markdown-wiki-link-fontify-missing nil + "When non-nil, change wiki link face according to existence of target files. +This is expensive because it requires checking for the file each time the buffer +changes or the user switches windows. It is disabled by default because it may +cause lag when typing on slower machines." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-retain-case nil + "When non-nil, wiki link file names do not have their case changed." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.7")) + +(defcustom markdown-uri-types + '("acap" "cid" "data" "dav" "fax" "file" "ftp" + "geo" "gopher" "http" "https" "imap" "ldap" "mailto" + "mid" "message" "modem" "news" "nfs" "nntp" + "pop" "prospero" "rtsp" "service" "sip" "tel" + "telnet" "tip" "urn" "vemmi" "wais") + "Link types for syntax highlighting of URIs." + :group 'markdown + :type '(repeat (string :tag "URI scheme"))) + +(defcustom markdown-url-compose-char + '(?∞ ?… ?⋯ ?# ?★ ?⚓) + "Placeholder character for hidden URLs. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :type '(choice + (character :tag "Single URL replacement character") + (repeat :tag "List of possible URL replacement characters" + character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-blockquote-display-char + '("▌" "┃" ">") + "String to display when hiding blockquote markup. +This may be a single string or a list of string. In case of a +list, the first one that satisfies `char-displayable-p' will be +used." + :type '(choice + (string :tag "Single blockquote display string") + (repeat :tag "List of possible blockquote display strings" string)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-hr-display-char + '(?─ ?━ ?-) + "Character for hiding horizontal rule markup. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :group 'markdown + :type '(choice + (character :tag "Single HR display character") + (repeat :tag "List of possible HR display characters" character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-definition-display-char + '(?⁘ ?⁙ ?≡ ?⌑ ?◊ ?:) + "Character for replacing definition list markup. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :type '(choice + (character :tag "Single definition list character") + (repeat :tag "List of possible definition list characters" character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-enable-math nil + "Syntax highlighting for inline LaTeX and itex expressions. +Set this to a non-nil value to turn on math support by default. +Math support can be enabled, disabled, or toggled later using +`markdown-toggle-math' or \\[markdown-toggle-math]." + :group 'markdown + :type 'boolean + :safe 'booleanp) +(make-variable-buffer-local 'markdown-enable-math) + +(defcustom markdown-enable-html t + "Enable font-lock support for HTML tags and attributes." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-enable-highlighting-syntax nil + "Enable highlighting syntax." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-css-paths nil + "List of URLs of CSS files to link to in the output XHTML." + :group 'markdown + :safe (lambda (x) (and (listp x) (cl-every #'stringp x))) + :type '(repeat (string :tag "CSS File Path"))) + +(defcustom markdown-content-type "text/html" + "Content type string for the http-equiv header in XHTML output. +When set to an empty string, this attribute is omitted. Defaults to +`text/html'." + :group 'markdown + :type 'string) + +(defcustom markdown-coding-system nil + "Character set string for the http-equiv header in XHTML output. +Defaults to `buffer-file-coding-system' (and falling back to +`utf-8' when not available). Common settings are `iso-8859-1' +and `iso-latin-1'. Use `list-coding-systems' for more choices." + :group 'markdown + :type 'coding-system) + +(defcustom markdown-export-kill-buffer t + "Kill output buffer after HTML export. +When non-nil, kill the HTML output buffer after +exporting with `markdown-export'." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-header-content "" + "Additional content to include in the XHTML block." + :group 'markdown + :type 'string) + +(defcustom markdown-xhtml-body-preamble "" + "Content to include in the XHTML block, before the output." + :group 'markdown + :type 'string + :safe 'stringp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-body-epilogue "" + "Content to include in the XHTML block, after the output." + :group 'markdown + :type 'string + :safe 'stringp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-standalone-regexp + "^\\(<\\?xml\\| Links & Images menu." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.3")) +(make-variable-buffer-local 'markdown-hide-urls) + +(defcustom markdown-translate-filename-function #'identity + "Function to use to translate filenames when following links. +\\\\[markdown-follow-thing-at-point] and \\[markdown-follow-link-at-point] +call this function with the filename as only argument whenever +they encounter a filename (instead of a URL) to be visited and +use its return value instead of the filename in the link. For +example, if absolute filenames are actually relative to a server +root directory, you can set +`markdown-translate-filename-function' to a function that +prepends the root directory to the given filename." + :group 'markdown + :type 'function + :risky t + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-max-image-size nil + "Maximum width and height for displayed inline images. +This variable may be nil or a cons cell (MAX-WIDTH . MAX-HEIGHT). +When nil, use the actual size. Otherwise, use ImageMagick to +resize larger images to be of the given maximum dimensions. This +requires Emacs to be built with ImageMagick support." + :group 'markdown + :package-version '(markdown-mode . "2.4") + :type '(choice + (const :tag "Use actual image width" nil) + (cons (choice (sexp :tag "Maximum width in pixels") + (const :tag "No maximum width" nil)) + (choice (sexp :tag "Maximum height in pixels") + (const :tag "No maximum height" nil))))) + +(defcustom markdown-mouse-follow-link t + "Non-nil means mouse on a link will follow the link. +This variable must be set before loading markdown-mode." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-table-align-p t + "Non-nil means that table is aligned after table operation." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-fontify-whole-heading-line nil + "Non-nil means fontify the whole line for headings. +This is useful when setting a background color for the +markdown-header-face-* faces." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-special-ctrl-a/e nil + "Non-nil means `C-a' and `C-e' behave specially in headlines and items. + +When t, `C-a' will bring back the cursor to the beginning of the +headline text. In an item, this will be the position after bullet +and check-box, if any. When the cursor is already at that +position, another `C-a' will bring it to the beginning of the +line. + +`C-e' will jump to the end of the headline, ignoring the presence +of closing tags in the headline. A second `C-e' will then jump to +the true end of the line, after closing tags. This also means +that, when this variable is non-nil, `C-e' also will never jump +beyond the end of the heading of a folded section, i.e. not after +the ellipses. + +When set to the symbol `reversed', the first `C-a' or `C-e' works +normally, going to the true line boundary first. Only a directly +following, identical keypress will bring the cursor to the +special positions. + +This may also be a cons cell where the behavior for `C-a' and +`C-e' is set separately." + :group 'markdown + :type '(choice + (const :tag "off" nil) + (const :tag "on: after hashes/bullet and before closing tags first" t) + (const :tag "reversed: true line boundary first" reversed) + (cons :tag "Set C-a and C-e separately" + (choice :tag "Special C-a" + (const :tag "off" nil) + (const :tag "on: after hashes/bullet first" t) + (const :tag "reversed: before hashes/bullet first" reversed)) + (choice :tag "Special C-e" + (const :tag "off" nil) + (const :tag "on: before closing tags first" t) + (const :tag "reversed: after closing tags first" reversed)))) + :package-version '(markdown-mode . "2.7")) + +;;; Markdown-Specific `rx' Macro ============================================== + +;; Based on python-rx from python.el. +(defmacro markdown-rx (&rest regexps) + "Markdown mode specialized rx macro. +This variant of `rx' supports common Markdown named REGEXPS." + `(rx-let ((newline "\n") + ;; Note: #405 not consider markdown-list-indent-width however this is never used + (indent (or (repeat 4 " ") "\t")) + (block-end (and (or (one-or-more (zero-or-more blank) "\n") line-end))) + (numeral (and (one-or-more (any "0-9#")) ".")) + (bullet (any "*+:-")) + (list-marker (or (and (one-or-more (any "0-9#")) ".") + (any "*+:-"))) + (checkbox (seq "[" (any " xX") "]"))) + (rx ,@regexps))) + + +;;; Regular Expressions ======================================================= + +(defconst markdown-regex-comment-start + "") + (setq-local comment-start-skip "