diff --git a/.gitmodules b/.gitmodules index a074062..471eeb5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,33 +1,3 @@ -[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/avy.el b/site-lisp/extensions-local/avy.el new file mode 100644 index 0000000..e037d1c --- /dev/null +++ b/site-lisp/extensions-local/avy.el @@ -0,0 +1,2249 @@ +;;; avy.el --- Jump to arbitrary positions in visible text and select text quickly. -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; URL: https://github.com/abo-abo/avy +;; Version: 0.5.0 +;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) +;; Keywords: point, location + +;; This file is part of GNU Emacs. + +;; This file 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, 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. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: +;; +;; With Avy, you can move point to any position in Emacs – even in a +;; different window – using very few keystrokes. For this, you look at +;; the position where you want point to be, invoke Avy, and then enter +;; the sequence of characters displayed at that position. +;; +;; If the position you want to jump to can be determined after only +;; issuing a single keystroke, point is moved to the desired position +;; immediately after that keystroke. In case this isn't possible, the +;; sequence of keystrokes you need to enter is comprised of more than +;; one character. Avy uses a decision tree where each candidate position +;; is a leaf and each edge is described by a character which is distinct +;; per level of the tree. By entering those characters, you navigate the +;; tree, quickly arriving at the desired candidate position, such that +;; Avy can move point to it. +;; +;; Note that this only makes sense for positions you are able to see +;; when invoking Avy. These kinds of positions are supported: +;; +;; * character positions +;; * word or subword start positions +;; * line beginning positions +;; * link positions +;; * window positions +;; +;; If you're familiar with the popular `ace-jump-mode' package, this +;; package does all that and more, without the implementation +;; headache. + +;;; Code: +(require 'cl-lib) +(require 'ring) + +;;* Customization +(defgroup avy nil + "Jump to things tree-style." + :group 'convenience + :prefix "avy-") + +(defcustom avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l) + "Default keys for jumping. +Any key is either a character representing a self-inserting +key (letters, digits, punctuation, etc.) or a symbol denoting a +non-printing key like an arrow key (left, right, up, down). For +non-printing keys, a corresponding entry in +`avy-key-to-char-alist' must exist in order to visualize the key +in the avy overlays. + +If `avy-style' is set to words, make sure there are at least three +keys different than the following: a, e, i, o, u, y" + :type '(repeat :tag "Keys" (choice + (character :tag "char") + (symbol :tag "non-printing key")))) + +(defconst avy--key-type + '(choice :tag "Command" + (const avy-goto-char) + (const avy-goto-char-2) + (const avy-isearch) + (const avy-goto-line) + (const avy-goto-subword-0) + (const avy-goto-subword-1) + (const avy-goto-word-0) + (const avy-goto-word-1) + (const avy-copy-line) + (const avy-copy-region) + (const avy-move-line) + (const avy-move-region) + (const avy-kill-whole-line) + (const avy-kill-region) + (const avy-kill-ring-save-whole-line) + (const avy-kill-ring-save-region) + (function :tag "Other command"))) + +(defcustom avy-keys-alist nil + "Alist of `avy-jump' commands to `avy-keys' overriding the default `avy-keys'." + :type `(alist + :key-type ,avy--key-type + :value-type (repeat :tag "Keys" character))) + +(defcustom avy-orders-alist '((avy-goto-char . avy-order-closest)) + "Alist of candidate ordering functions. +Usually, candidates appear in their point position order." + :type `(alist + :key-type ,avy--key-type + :value-type function)) + +(defcustom avy-words + '("am" "by" "if" "is" "it" "my" "ox" "up" + "ace" "act" "add" "age" "ago" "aim" "air" "ale" "all" "and" "ant" "any" + "ape" "apt" "arc" "are" "arm" "art" "ash" "ate" "awe" "axe" "bad" "bag" + "ban" "bar" "bat" "bay" "bed" "bee" "beg" "bet" "bid" "big" "bit" "bob" + "bot" "bow" "box" "boy" "but" "cab" "can" "cap" "car" "cat" "cog" "cop" + "cow" "cry" "cup" "cut" "day" "dew" "did" "die" "dig" "dim" "dip" "dog" + "dot" "dry" "dub" "dug" "dye" "ear" "eat" "eel" "egg" "ego" "elf" "eve" + "eye" "fan" "far" "fat" "fax" "fee" "few" "fin" "fit" "fix" "flu" "fly" + "foe" "fog" "for" "fox" "fry" "fun" "fur" "gag" "gap" "gas" "gel" "gem" + "get" "gig" "gin" "gnu" "god" "got" "gum" "gun" "gut" "guy" "gym" "had" + "hag" "ham" "has" "hat" "her" "hid" "him" "hip" "his" "hit" "hop" "hot" + "how" "hub" "hue" "hug" "hut" "ice" "icy" "imp" "ink" "inn" "ion" "ire" + "ivy" "jab" "jam" "jar" "jaw" "jet" "job" "jog" "joy" "key" "kid" "kit" + "lag" "lap" "lay" "let" "lid" "lie" "lip" "lit" "lob" "log" "lot" "low" + "mad" "man" "map" "mat" "may" "men" "met" "mix" "mob" "mop" "mud" "mug" + "nag" "nap" "new" "nil" "nod" "nor" "not" "now" "nun" "oak" "odd" "off" + "oil" "old" "one" "orb" "ore" "ork" "our" "out" "owl" "own" "pad" "pan" + "par" "pat" "paw" "pay" "pea" "pen" "pet" "pig" "pin" "pit" "pod" "pot" + "pry" "pub" "pun" "put" "rag" "ram" "ran" "rat" "raw" "ray" "red" "rib" + "rim" "rip" "rob" "rod" "rot" "row" "rub" "rug" "rum" "run" "sad" "sat" + "saw" "say" "sea" "see" "sew" "she" "shy" "sin" "sip" "sit" "six" "ski" + "sky" "sly" "sob" "son" "soy" "spy" "sum" "sun" "tab" "tad" "tag" "tan" + "tap" "tar" "tax" "tea" "the" "tie" "tin" "tip" "toe" "ton" "too" "top" + "toy" "try" "tub" "two" "urn" "use" "van" "war" "was" "wax" "way" "web" + "wed" "wet" "who" "why" "wig" "win" "wit" "woe" "won" "wry" "you" "zap" + "zip" "zoo") + "Words to use in case `avy-style' is set to `words'. +Every word should contain at least one vowel i.e. one of the following +characters: a, e, i, o, u, y +They do not have to be sorted but no word should be a prefix of another one." + :type '(repeat string)) + +(defcustom avy-style 'at-full + "The default method of displaying the overlays. +Use `avy-styles-alist' to customize this per-command." + :type '(choice + (const :tag "Pre" pre) + (const :tag "At" at) + (const :tag "At Full" at-full) + (const :tag "Post" post) + (const :tag "De Bruijn" de-bruijn) + (const :tag "Words" words))) + +(defcustom avy-styles-alist nil + "Alist of `avy-jump' commands to the style for each command. +If the commands isn't on the list, `avy-style' is used." + :type '(alist + :key-type (choice :tag "Command" + (const avy-goto-char) + (const avy-goto-char-2) + (const avy-isearch) + (const avy-goto-line) + (const avy-goto-subword-0) + (const avy-goto-subword-1) + (const avy-goto-word-0) + (const avy-goto-word-1) + (const avy-copy-line) + (const avy-copy-region) + (const avy-move-line) + (const avy-move-region) + (const avy-kill-whole-line) + (const avy-kill-region) + (const avy-kill-ring-save-whole-line) + (const avy-kill-ring-save-region) + (function :tag "Other command")) + :value-type (choice + (const :tag "Pre" pre) + (const :tag "At" at) + (const :tag "At Full" at-full) + (const :tag "Post" post) + (const :tag "De Bruijn" de-bruijn) + (const :tag "Words" words)))) + +(defcustom avy-dispatch-alist + '((?x . avy-action-kill-move) + (?X . avy-action-kill-stay) + (?t . avy-action-teleport) + (?m . avy-action-mark) + (?n . avy-action-copy) + (?y . avy-action-yank) + (?Y . avy-action-yank-line) + (?i . avy-action-ispell) + (?z . avy-action-zap-to-char)) + "List of actions for `avy-handler-default'. + +Each item is (KEY . ACTION). When KEY not on `avy-keys' is +pressed during the dispatch, ACTION is set to replace the default +`avy-action-goto' once a candidate is finally selected." + :type + '(alist + :key-type (choice (character :tag "Char")) + :value-type (choice + (const :tag "Mark" avy-action-mark) + (const :tag "Copy" avy-action-copy) + (const :tag "Kill and move point" avy-action-kill-move) + (const :tag "Kill" avy-action-kill-stay)))) + +(defcustom avy-background nil + "When non-nil, a gray background will be added during the selection." + :type 'boolean) + +(defcustom avy-all-windows t + "Determine the list of windows to consider in search of candidates." + :type + '(choice + (const :tag "All Frames" all-frames) + (const :tag "This Frame" t) + (const :tag "This Window" nil))) + +(defcustom avy-case-fold-search t + "Non-nil if searches should ignore case." + :type 'boolean) + +(defcustom avy-word-punc-regexp "[!-/:-@[-`{-~]" + "Regexp of punctuation chars that count as word starts for `avy-goto-word-1. +When nil, punctuation chars will not be matched. + +\"[!-/:-@[-`{-~]\" will match all printable punctuation chars." + :type 'regexp) + +(defcustom avy-goto-word-0-regexp "\\b\\sw" + "Regexp that determines positions for `avy-goto-word-0'." + :type '(choice + (const :tag "Default" "\\b\\sw") + (const :tag "Symbol" "\\_<\\(\\sw\\|\\s_\\)") + (const :tag "Not whitespace" "[^ \r\n\t]+") + (regexp :tag "Regex"))) + +(defcustom avy-ignored-modes '(image-mode doc-view-mode pdf-view-mode) + "List of modes to ignore when searching for candidates. +Typically, these modes don't use the text representation." + :type 'list) + +(defcustom avy-single-candidate-jump t + "In case there is only one candidate jumps directly to it." + :type 'boolean) + +(defcustom avy-del-last-char-by '(?\b ?\d) + "List of event types, i.e. key presses, that delete the last +character read. The default represents `C-h' and `DEL'. See +`event-convert-list'." + :type 'list) + +(defcustom avy-escape-chars '(?\e ?\C-g) + "List of characters that quit avy during `read-char'." + :type 'list) + +(defvar avy-ring (make-ring 20) + "Hold the window and point history.") + +(defvar avy-translate-char-function #'identity + "Function to translate user input key into another key. +For example, to make SPC do the same as ?a, use +\(lambda (c) (if (= c 32) ?a c)).") + +(defface avy-lead-face-0 + '((t (:foreground "white" :background "#4f57f9"))) + "Face used for first non-terminating leading chars.") + +(defface avy-lead-face-1 + '((t (:foreground "white" :background "gray"))) + "Face used for matched leading chars.") + +(defface avy-lead-face-2 + '((t (:foreground "white" :background "#f86bf3"))) + "Face used for leading chars.") + +(defface avy-lead-face + '((t (:foreground "white" :background "#e52b50"))) + "Face used for the leading chars.") + +(defface avy-background-face + '((t (:foreground "gray40"))) + "Face for whole window background during selection.") + +(defface avy-goto-char-timer-face + '((t (:inherit highlight))) + "Face for matches during reading chars using `avy-goto-char-timer'.") + +(defconst avy-lead-faces '(avy-lead-face + avy-lead-face-0 + avy-lead-face-2 + avy-lead-face + avy-lead-face-0 + avy-lead-face-2) + "Face sequence for `avy--overlay-at-full'.") + +(defvar avy-key-to-char-alist '((left . ?◀) + (right . ?▶) + (up . ?▲) + (down . ?▼) + (prior . ?△) + (next . ?▽)) + "An alist from non-character keys to printable chars used in avy overlays. +This alist must contain all keys used in `avy-keys' which are not +self-inserting keys and thus aren't read as characters.") + +;;* Internals +;;** Tree +(defmacro avy-multipop (lst n) + "Remove LST's first N elements and return them." + `(if (<= (length ,lst) ,n) + (prog1 ,lst + (setq ,lst nil)) + (prog1 ,lst + (setcdr + (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst)))) + nil)))) + +(defun avy--de-bruijn (keys n) + "De Bruijn sequence for alphabet KEYS and subsequences of length N." + (let* ((k (length keys)) + (a (make-list (* n k) 0)) + sequence) + (cl-labels ((db (T p) + (if (> T n) + (if (eq (% n p) 0) + (setq sequence + (append sequence + (cl-subseq a 1 (1+ p))))) + (setf (nth T a) (nth (- T p) a)) + (db (1+ T) p) + (cl-loop for j from (1+ (nth (- T p) a)) to (1- k) do + (setf (nth T a) j) + (db (1+ T) T))))) + (db 1 1) + (mapcar (lambda (n) + (nth n keys)) + sequence)))) + +(defun avy--path-alist-1 (lst seq-len keys) + "Build a De Bruin sequence from LST. +SEQ-LEN is how many elements of KEYS it takes to identify a match." + (let ((db-seq (avy--de-bruijn keys seq-len)) + prev-pos prev-seq prev-win path-alist) + ;; The De Bruijn seq is cyclic, so append the seq-len - 1 first chars to + ;; the end. + (setq db-seq (nconc db-seq (cl-subseq db-seq 0 (1- seq-len)))) + (cl-labels ((subseq-and-pop () + (when (nth (1- seq-len) db-seq) + (prog1 (cl-subseq db-seq 0 seq-len) + (pop db-seq))))) + (while lst + (let* ((cur (car lst)) + (pos (cond + ;; ace-window has matches of the form (pos . wnd) + ((integerp (car cur)) (car cur)) + ;; avy-jump have form ((start . end) . wnd) + ((consp (car cur)) (caar cur)) + (t (error "Unexpected match representation: %s" cur)))) + (win (cdr cur)) + (path (if prev-pos + (let ((diff (if (eq win prev-win) + (- pos prev-pos) + 0))) + (when (and (> diff 0) (< diff seq-len)) + (while (and (nth (1- seq-len) db-seq) + (not + (eq 0 + (cl-search + (cl-subseq prev-seq diff) + (cl-subseq db-seq 0 seq-len))))) + (pop db-seq))) + (subseq-and-pop)) + (subseq-and-pop)))) + (if (not path) + (setq lst nil + path-alist nil) + (push (cons path (car lst)) path-alist) + (setq prev-pos pos + prev-seq path + prev-win win + lst (cdr lst)))))) + (nreverse path-alist))) + +(defun avy-order-closest (x) + (abs (- (if (numberp (car x)) + (car x) + (caar x)) + (point)))) + +(defvar avy-command nil + "Store the current command symbol. +E.g. `avy-goto-line' or `avy-goto-char'.") + +(defun avy-tree (lst keys) + "Coerce LST into a balanced tree. +The degree of the tree is the length of KEYS. +KEYS are placed appropriately on internal nodes." + (let* ((len (length keys)) + (order-fn (cdr (assq avy-command avy-orders-alist))) + (lst (if order-fn + (cl-sort lst #'< :key order-fn) + lst))) + (cl-labels + ((rd (ls) + (let ((ln (length ls))) + (if (< ln len) + (cl-pairlis keys + (mapcar (lambda (x) (cons 'leaf x)) ls)) + (let ((ks (copy-sequence keys)) + res) + (dolist (s (avy-subdiv ln len)) + (push (cons (pop ks) + (if (eq s 1) + (cons 'leaf (pop ls)) + (rd (avy-multipop ls s)))) + res)) + (nreverse res)))))) + (rd lst)))) + +(defun avy-subdiv (n b) + "Distribute N in B terms in a balanced way." + (let* ((p (1- (floor (+ (log n b) 1e-6)))) + (x1 (expt b p)) + (x2 (* b x1)) + (delta (- n x2)) + (n2 (/ delta (- x2 x1))) + (n1 (- b n2 1))) + (append + (make-list n1 x1) + (list + (- n (* n1 x1) (* n2 x2))) + (make-list n2 x2)))) + +(defun avy-traverse (tree walker &optional recur-key) + "Traverse TREE generated by `avy-tree'. +WALKER is a function that takes KEYS and LEAF. + +RECUR-KEY is used in recursion. + +LEAF is a member of LST argument of `avy-tree'. + +KEYS is the path from the root of `avy-tree' to LEAF." + (dolist (br tree) + (let ((key (cons (car br) recur-key))) + (if (eq (cadr br) 'leaf) + (funcall walker key (cddr br)) + (avy-traverse (cdr br) walker key))))) + +(defvar avy-action nil + "Function to call at the end of select.") + +(defvar avy-action-oneshot nil + "Function to call once at the end of select.") + +(defun avy-handler-default (char) + "The default handler for a bad CHAR." + (let (dispatch) + (cond ((setq dispatch (assoc char avy-dispatch-alist)) + (unless (eq avy-style 'words) + (setq avy-action (cdr dispatch))) + (throw 'done 'restart)) + ((memq char avy-escape-chars) + ;; exit silently + (throw 'done 'abort)) + ((eq char ??) + (avy-show-dispatch-help) + (throw 'done 'restart)) + ((mouse-event-p char) + (signal 'user-error (list "Mouse event not handled" char))) + (t + (message "No such candidate: %s, hit `C-g' to quit." + (if (characterp char) (string char) char)))))) + +(defun avy-show-dispatch-help () + "Display action shortucts in echo area." + (let ((len (length "avy-action-"))) + (message "%s" (mapconcat + (lambda (x) + (format "%s: %s" + (propertize + (char-to-string (car x)) + 'face 'aw-key-face) + (substring (symbol-name (cdr x)) len))) + avy-dispatch-alist + " ")))) + +(defvar avy-handler-function 'avy-handler-default + "A function to call for a bad `read-key' in `avy-read'.") + +(defvar avy-current-path "" + "Store the current incomplete path during `avy-read'.") + +(defun avy-mouse-event-window (char) + "Return the window of mouse event CHAR if any or the selected window. +Return nil if CHAR is not a mouse event." + (when (mouse-event-p char) + (cond ((windowp (posn-window (event-start char))) + (posn-window (event-start char))) + ((framep (posn-window (event-start char))) + (frame-selected-window (posn-window (event-start char)))) + (t (selected-window))))) + +(defun avy-read (tree display-fn cleanup-fn) + "Select a leaf from TREE using consecutive `read-key'. + +DISPLAY-FN should take CHAR and LEAF and signify that LEAFs +associated with CHAR will be selected if CHAR is pressed. This is +commonly done by adding a CHAR overlay at LEAF position. + +CLEANUP-FN should take no arguments and remove the effects of +multiple DISPLAY-FN invocations." + (catch 'done + (setq avy-current-path "") + (while tree + (let ((avy--leafs nil)) + (avy-traverse tree + (lambda (path leaf) + (push (cons path leaf) avy--leafs))) + (dolist (x avy--leafs) + (funcall display-fn (car x) (cdr x)))) + (let ((char (funcall avy-translate-char-function (read-key))) + window + branch) + (funcall cleanup-fn) + (if (setq window (avy-mouse-event-window char)) + (throw 'done (cons char window)) + (if (setq branch (assoc char tree)) + (progn + ;; Ensure avy-current-path stores the full path prior to + ;; exit so other packages can utilize its value. + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (if (eq (car (setq tree (cdr branch))) 'leaf) + (throw 'done (cdr tree)))) + (funcall avy-handler-function char))))))) + +(defun avy-read-de-bruijn (lst keys) + "Select from LST dispatching on KEYS." + ;; In theory, the De Bruijn sequence B(k,n) has k^n subsequences of length n + ;; (the path length) usable as paths, thus that's the lower bound. Due to + ;; partially overlapping matches, not all subsequences may be usable, so it's + ;; possible that the path-len must be incremented, e.g., if we're matching + ;; for x and a buffer contains xaxbxcx only every second subsequence is + ;; usable for the four matches. + (catch 'done + (let* ((path-len (ceiling (log (length lst) (length keys)))) + (alist (avy--path-alist-1 lst path-len keys))) + (while (not alist) + (cl-incf path-len) + (setq alist (avy--path-alist-1 lst path-len keys))) + (let* ((len (length (caar alist))) + (i 0)) + (setq avy-current-path "") + (while (< i len) + (dolist (x (reverse alist)) + (avy--overlay-at-full (reverse (car x)) (cdr x))) + (let ((char (funcall avy-translate-char-function (read-key)))) + (avy--remove-leading-chars) + (setq alist + (delq nil + (mapcar (lambda (x) + (when (eq (caar x) char) + (cons (cdr (car x)) (cdr x)))) + alist))) + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (cl-incf i) + (unless alist + (funcall avy-handler-function char)))) + (cdar alist))))) + +(defun avy-read-words (lst words) + "Select from LST using WORDS." + (catch 'done + (let ((num-words (length words)) + (num-entries (length lst)) + alist) + ;; If there are not enough words to cover all the candidates, + ;; we use a De Bruijn sequence to generate the remaining ones. + (when (< num-words num-entries) + (let ((keys avy-keys) + (bad-keys '(?a ?e ?i ?o ?u ?y)) + (path-len 1) + (num-remaining (- num-entries num-words)) + tmp-alist) + ;; Delete all keys which could lead to duplicates. + ;; We want at least three keys left to work with. + (dolist (x bad-keys) + (when (memq x keys) + (setq keys (delq ?a keys)))) + (when (< (length keys) 3) + (signal 'user-error + '("Please add more keys to the variable `avy-keys'."))) + ;; Generate the sequence and add the keys to the existing words. + (while (not tmp-alist) + (cl-incf path-len) + (setq tmp-alist (avy--path-alist-1 lst path-len keys))) + (while (>= (cl-decf num-remaining) 0) + (push (mapconcat 'string (caar tmp-alist) nil) (cdr (last words))) + (setq tmp-alist (cdr tmp-alist))))) + (dolist (x lst) + (push (cons (string-to-list (pop words)) x) alist)) + (setq avy-current-path "") + (while (or (> (length alist) 1) + (caar alist)) + (dolist (x (reverse alist)) + (avy--overlay-at-full (reverse (car x)) (cdr x))) + (let ((char (funcall avy-translate-char-function (read-key)))) + (avy--remove-leading-chars) + (setq alist + (delq nil + (mapcar (lambda (x) + (when (eq (caar x) char) + (cons (cdr (car x)) (cdr x)))) + alist))) + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (unless alist + (funcall avy-handler-function char)))) + (cdar alist)))) + +;;** Rest +(defun avy-window-list () + "Return a list of windows depending on `avy-all-windows'." + (cond ((eq avy-all-windows 'all-frames) + (cl-mapcan #'window-list (frame-list))) + + ((eq avy-all-windows t) + (window-list)) + + ((null avy-all-windows) + (list (selected-window))) + + (t + (error "Unrecognized option: %S" avy-all-windows)))) + +(defcustom avy-all-windows-alt nil + "The alternative `avy-all-windows' for use with \\[universal-argument]." + :type '(choice + (const :tag "Current window" nil) + (const :tag "All windows on the current frame" t) + (const :tag "All windows on all frames" all-frames))) + +(defmacro avy-dowindows (flip &rest body) + "Depending on FLIP and `avy-all-windows' run BODY in each or selected window." + (declare (indent 1) + (debug (form body))) + `(let ((avy-all-windows (if ,flip + avy-all-windows-alt + avy-all-windows))) + (dolist (wnd (avy-window-list)) + (with-selected-window wnd + (unless (memq major-mode avy-ignored-modes) + ,@body))))) + +(defun avy-resume () + "Stub to hold last avy command. +Commands using `avy-with' macro can be resumed." + (interactive)) + +(defmacro avy-with (command &rest body) + "Set `avy-keys' according to COMMAND and execute BODY. +Set `avy-style' according to COMMAND as well." + (declare (indent 1) + (debug (form body))) + `(let ((avy-keys (or (cdr (assq ',command avy-keys-alist)) + avy-keys)) + (avy-style (or (cdr (assq ',command avy-styles-alist)) + avy-style)) + (avy-command ',command)) + (setq avy-action nil) + (setf (symbol-function 'avy-resume) + (lambda () + (interactive) + ,@(if (eq command 'avy-goto-char-timer) + (cdr body) + body))) + ,@body)) + +(defun avy-action-goto (pt) + "Goto PT." + (let ((frame (window-frame (selected-window)))) + (unless (equal frame (selected-frame)) + (select-frame-set-input-focus frame) + (raise-frame frame)) + (goto-char pt))) + +(defun avy-forward-item () + (if (eq avy-command 'avy-goto-line) + (end-of-line) + (forward-sexp)) + (point)) + +(defun avy-action-mark (pt) + "Mark sexp at PT." + (goto-char pt) + (set-mark (point)) + (avy-forward-item)) + +(defun avy-action-copy (pt) + "Copy sexp starting on PT." + (save-excursion + (let (str) + (goto-char pt) + (avy-forward-item) + (setq str (buffer-substring pt (point))) + (kill-new str) + (message "Copied: %s" str))) + (let ((dat (ring-ref avy-ring 0))) + (select-frame-set-input-focus + (window-frame (cdr dat))) + (select-window (cdr dat)) + (goto-char (car dat)))) + +(defun avy-action-yank (pt) + "Yank sexp starting at PT at the current point." + (avy-action-copy pt) + (yank) + t) + +(defun avy-action-yank-line (pt) + "Yank sexp starting at PT at the current point." + (let ((avy-command 'avy-goto-line)) + (avy-action-yank pt))) + +(defun avy-action-kill-move (pt) + "Kill sexp at PT and move there." + (goto-char pt) + (avy-forward-item) + (kill-region pt (point)) + (message "Killed: %s" (current-kill 0)) + (point)) + +(defun avy-action-kill-stay (pt) + "Kill sexp at PT." + (save-excursion + (goto-char pt) + (avy-forward-item) + (kill-region pt (point)) + (just-one-space)) + (message "Killed: %s" (current-kill 0)) + (select-window + (cdr + (ring-ref avy-ring 0))) + t) + +(defun avy-action-zap-to-char (pt) + "Kill from point up to PT." + (if (> pt (point)) + (kill-region (point) pt) + (kill-region pt (point)))) + +(defun avy-action-teleport (pt) + "Kill sexp starting on PT and yank into the current location." + (avy-action-kill-stay pt) + (select-window + (cdr + (ring-ref avy-ring 0))) + (save-excursion + (yank)) + t) + +(declare-function flyspell-correct-word-before-point "flyspell") + +(defcustom avy-flyspell-correct-function #'flyspell-correct-word-before-point + "Function called to correct word by `avy-action-ispell' when +`flyspell-mode' is enabled." + :type 'function) + +(defun avy-action-ispell (pt) + "Auto correct word at PT." + (save-excursion + (goto-char pt) + (cond + ((eq avy-command 'avy-goto-line) + (ispell-region + (line-beginning-position) + (line-end-position))) + ((bound-and-true-p flyspell-mode) + (funcall avy-flyspell-correct-function)) + ((looking-at-p "\\b") + (ispell-word)) + (t + (progn + (backward-word) + (when (looking-at-p "\\b") + (ispell-word))))))) + +(defvar avy-pre-action #'avy-pre-action-default + "Function to call before `avy-action' is called.") + +(defun avy-pre-action-default (res) + (avy-push-mark) + (when (and (consp res) + (windowp (cdr res))) + (let* ((window (cdr res)) + (frame (window-frame window))) + (unless (equal frame (selected-frame)) + (select-frame-set-input-focus frame)) + (select-window window)))) + +(defun avy--process-1 (candidates overlay-fn &optional cleanup-fn) + (let ((len (length candidates))) + (cond ((= len 0) + nil) + ((and (= len 1) avy-single-candidate-jump) + (car candidates)) + (t + (unwind-protect + (progn + (avy--make-backgrounds + (avy-window-list)) + (cond ((eq avy-style 'de-bruijn) + (avy-read-de-bruijn + candidates avy-keys)) + ((eq avy-style 'words) + (avy-read-words + candidates avy-words)) + (t + (avy-read (avy-tree candidates avy-keys) + overlay-fn + (or cleanup-fn #'avy--remove-leading-chars))))) + (avy--done)))))) + +(defvar avy-last-candidates nil + "Store the last candidate list.") + +(defun avy--last-candidates-cycle (advancer) + (let* ((avy-last-candidates + (cl-remove-if-not + (lambda (x) (equal (cdr x) (selected-window))) + avy-last-candidates)) + (min-dist + (apply #'min + (mapcar (lambda (x) (abs (- (if (listp (car x)) (caar x) (car x)) (point)))) avy-last-candidates))) + (pos + (cl-position-if + (lambda (x) + (= (- (if (listp (car x)) (caar x) (car x)) (point)) min-dist)) + avy-last-candidates))) + (funcall advancer pos avy-last-candidates))) + +(defun avy-prev () + "Go to the previous candidate of the last `avy-read'." + (interactive) + (avy--last-candidates-cycle + (lambda (pos lst) + (when (> pos 0) + (let ((candidate (nth (1- pos) lst))) + (goto-char (if (listp (car candidate)) (caar candidate) (car candidate)))))))) + +(defun avy-next () + "Go to the next candidate of the last `avy-read'." + (interactive) + (avy--last-candidates-cycle + (lambda (pos lst) + (when (< pos (1- (length lst))) + (let ((candidate (nth (1+ pos) lst))) + (goto-char (if (listp (car candidate)) (caar candidate) (car candidate)))))))) + +;;;###autoload +(defun avy-process (candidates &optional overlay-fn cleanup-fn) + "Select one of CANDIDATES using `avy-read'. +Use OVERLAY-FN to visualize the decision overlay. +CLEANUP-FN should take no arguments and remove the effects of +multiple OVERLAY-FN invocations." + (setq overlay-fn (or overlay-fn (avy--style-fn avy-style))) + (setq cleanup-fn (or cleanup-fn #'avy--remove-leading-chars)) + (unless (and (consp (car candidates)) + (windowp (cdar candidates))) + (setq candidates + (mapcar (lambda (x) (cons x (selected-window))) + candidates))) + (setq avy-last-candidates (copy-sequence candidates)) + (let ((original-cands (copy-sequence candidates)) + (res (avy--process-1 candidates overlay-fn cleanup-fn))) + (cond + ((null res) + (if (and (eq avy-style 'words) candidates) + (avy-process original-cands overlay-fn cleanup-fn) + (message "zero candidates") + t)) + ((eq res 'restart) + (avy-process original-cands overlay-fn cleanup-fn)) + ;; ignore exit from `avy-handler-function' + ((eq res 'exit)) + ((eq res 'abort) + nil) + (t + (funcall avy-pre-action res) + (setq res (car res)) + (let ((action (or avy-action avy-action-oneshot 'avy-action-goto))) + (funcall action + (if (consp res) + (car res) + res))) + res)))) + +(define-obsolete-function-alias 'avy--process 'avy-process + "0.4.0") + +(defvar avy--overlays-back nil + "Hold overlays for when `avy-background' is t.") + +(defun avy--make-backgrounds (wnd-list) + "Create a dim background overlay for each window on WND-LIST." + (when avy-background + (setq avy--overlays-back + (mapcar (lambda (w) + (let ((ol (make-overlay + (window-start w) + (window-end w) + (window-buffer w)))) + (overlay-put ol 'face 'avy-background-face) + (overlay-put ol 'window w) + ol)) + wnd-list)))) + +(defun avy--done () + "Clean up overlays." + (mapc #'delete-overlay avy--overlays-back) + (setq avy--overlays-back nil) + (avy--remove-leading-chars)) + +(defun avy--visible-p (s) + (let ((invisible (get-char-property s 'invisible))) + (or (null invisible) + (eq t buffer-invisibility-spec) + (null (assoc invisible buffer-invisibility-spec))))) + +(defun avy--next-visible-point () + "Return the next closest point without `invisible' property." + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-char-property-change s)))) + (not (avy--visible-p s)))) + s)) + +(defun avy--next-invisible-point () + "Return the next closest point with `invisible' property." + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-char-property-change s)))) + (avy--visible-p s))) + s)) + +(defun avy--find-visible-regions (rbeg rend) + "Return a list of all visible regions between RBEG and REND." + (setq rbeg (max rbeg (point-min))) + (setq rend (min rend (point-max))) + (when (< rbeg rend) + (let (visibles beg) + (save-excursion + (save-restriction + (narrow-to-region rbeg rend) + (setq beg (goto-char (point-min))) + (while (not (= (point) (point-max))) + (goto-char (avy--next-invisible-point)) + (push (cons beg (point)) visibles) + (setq beg (goto-char (avy--next-visible-point)))) + (nreverse visibles)))))) + +(defun avy--regex-candidates (regex &optional beg end pred group) + "Return all elements that match REGEX. +Each element of the list is ((BEG . END) . WND) +When PRED is non-nil, it's a filter for matching point positions. +When GROUP is non-nil, (BEG . END) should delimit that regex group." + (setq group (or group 0)) + (let ((case-fold-search (or avy-case-fold-search + (string= regex (downcase regex)))) + candidates) + (avy-dowindows current-prefix-arg + (dolist (pair (avy--find-visible-regions + (or beg (window-start)) + (or end (window-end (selected-window) t)))) + (save-excursion + (goto-char (car pair)) + (while (re-search-forward regex (cdr pair) t) + (when (avy--visible-p (1- (point))) + (when (or (null pred) + (funcall pred)) + (push (cons + (if (numberp group) + (cons (match-beginning group) + (match-end group)) + (funcall group)) + wnd) candidates))))))) + (nreverse candidates))) + +(defvar avy--overlay-offset 0 + "The offset to apply in `avy--overlay'.") + +(defvar avy--overlays-lead nil + "Hold overlays for leading chars.") + +(defun avy--remove-leading-chars () + "Remove leading char overlays." + (mapc #'delete-overlay avy--overlays-lead) + (setq avy--overlays-lead nil)) + +(defun avy--old-str (pt wnd) + "Return a one-char string at PT in WND." + (let ((old-str (with-selected-window wnd + (buffer-substring pt (1+ pt))))) + (if avy-background + (propertize old-str 'face 'avy-background-face) + old-str))) + +(defun avy--overlay (str beg end wnd &optional compose-fn) + "Create an overlay with STR from BEG to END in WND. +COMPOSE-FN is a lambda that concatenates the old string at BEG with STR." + (let ((eob (with-selected-window wnd (point-max)))) + (when (<= beg eob) + (let* ((beg (+ beg avy--overlay-offset)) + (ol (make-overlay beg (or end (1+ beg)) (window-buffer wnd))) + (old-str (if (eq beg eob) "" (avy--old-str beg wnd))) + (os-line-prefix (get-text-property 0 'line-prefix old-str)) + (os-wrap-prefix (get-text-property 0 'wrap-prefix old-str)) + other-ol) + (unless (= (length str) 0) + (when os-line-prefix + (add-text-properties 0 1 `(line-prefix ,os-line-prefix) str)) + (when os-wrap-prefix + (add-text-properties 0 1 `(wrap-prefix ,os-wrap-prefix) str))) + (when (setq other-ol (cl-find-if + (lambda (o) (overlay-get o 'goto-address)) + (overlays-at beg))) + (add-text-properties + 0 (length old-str) + `(face ,(overlay-get other-ol 'face)) old-str)) + (overlay-put ol 'window wnd) + (overlay-put ol 'category 'avy) + (overlay-put ol (if (eq beg eob) + 'after-string + 'display) + (funcall + (or compose-fn #'concat) + str old-str)) + (push ol avy--overlays-lead))))) + +(defcustom avy-highlight-first nil + "When non-nil highlight the first decision char with `avy-lead-face-0'. +Do this even when the char is terminating." + :type 'boolean) + +(defun avy--key-to-char (c) + "If C is no character, translate it using `avy-key-to-char-alist'." + (cond ((characterp c) c) + ((cdr (assoc c avy-key-to-char-alist))) + ((mouse-event-p c) c) + (t + (error "Unknown key %s" c)))) + +(defun avy-candidate-beg (leaf) + "Return the start position for LEAF." + (cond ((numberp leaf) + leaf) + ((consp (car leaf)) + (caar leaf)) + (t + (car leaf)))) + +(defun avy-candidate-end (leaf) + "Return the end position for LEAF." + (cond ((numberp leaf) + leaf) + ((consp (car leaf)) + (cdar leaf)) + (t + (car leaf)))) + +(defun avy-candidate-wnd (leaf) + "Return the window for LEAF." + (if (consp leaf) + (cdr leaf) + (selected-window))) + +(defun avy--overlay-pre (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (if (with-selected-window (cdr leaf) + (bound-and-true-p visual-line-mode)) + (avy--overlay-at-full path leaf) + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (or avy-highlight-first (> (length str) 1)) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (avy--overlay + str + (avy-candidate-beg leaf) nil + (avy-candidate-wnd leaf))))) + +(defun avy--overlay-at (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize + (string (car (last path))) + 'face 'avy-lead-face))) + (avy--overlay + str + (avy-candidate-beg leaf) nil + (avy-candidate-wnd leaf) + (lambda (str old-str) + (cond ((string= old-str "\n") + (concat str "\n")) + ;; add padding for wide-width character + ((eq (string-width old-str) 2) + (concat str " ")) + (t + str)))))) + +(defun avy--overlay-at-full (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize + (apply #'string (reverse path)) + 'face 'avy-lead-face)) + (len (length path)) + (beg (avy-candidate-beg leaf)) + (wnd (cdr leaf)) + end) + (dotimes (i len) + (set-text-properties i (1+ i) + `(face ,(nth i avy-lead-faces)) + str)) + (when (eq avy-style 'de-bruijn) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (setq len (length str))) + (with-selected-window wnd + (save-excursion + (goto-char beg) + (let* ((lep (if (bound-and-true-p visual-line-mode) + (save-excursion + (end-of-visual-line) + (point)) + (line-end-position))) + ;; `end-of-visual-line' is bugged sometimes + (lep (if (< lep beg) + (line-end-position) + lep)) + (len-and-str (avy--update-offset-and-str len str lep))) + (setq len (car len-and-str)) + (setq str (cdr len-and-str)) + (setq end (if (= beg lep) + (1+ beg) + (min (+ beg + (if (eq (char-after) ?\t) + 1 + len)) + lep))) + (when (and (bound-and-true-p visual-line-mode) + (> len (- end beg)) + (not (eq lep beg))) + (setq len (- end beg)) + (let ((old-str (apply #'string (reverse path)))) + (setq str + (substring + (propertize + old-str + 'face + (if (= (length old-str) 1) + 'avy-lead-face + 'avy-lead-face-0)) + 0 len))))))) + (avy--overlay + str beg end wnd + (lambda (str old-str) + (cond ((string= old-str "\n") + (concat str "\n")) + ((string= old-str "\t") + (concat str (make-string (max (- tab-width len) 0) ?\ ))) + (t + ;; add padding for wide-width character + (if (eq (string-width old-str) 2) + (concat str " ") + str))))))) + +(defun avy--overlay-post (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (or avy-highlight-first (> (length str) 1)) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (avy--overlay + str + (avy-candidate-end leaf) nil + (avy-candidate-wnd leaf)))) + +(defun avy--update-offset-and-str (offset str lep) + "Recalculate the length of the new overlay at point. + +OFFSET is the previous overlay length. +STR is the overlay string that we wish to add. +LEP is the line end position. + +We want to add an overlay between point and END=point+OFFSET. +When other overlays already exist between point and END, set +OFFSET to be the difference between the start of the first +overlay and point. This is equivalent to truncating our new +overlay, so that it doesn't intersect with overlays that already +exist." + (let* ((wnd (selected-window)) + (beg (point)) + (oov (delq nil + (mapcar + (lambda (o) + (and (eq (overlay-get o 'category) 'avy) + (eq (overlay-get o 'window) wnd) + (overlay-start o))) + (overlays-in beg (min (+ beg offset) lep)))))) + (when oov + (setq offset (- (apply #'min oov) beg)) + (setq str (substring str 0 offset))) + (let ((other-ov (cl-find-if + (lambda (o) + (and (eq (overlay-get o 'category) 'avy) + (eq (overlay-start o) beg) + (not (eq (overlay-get o 'window) wnd)))) + (overlays-in (point) (min (+ (point) offset) lep))))) + (when (and other-ov + (> (overlay-end other-ov) + (+ beg offset))) + (setq str (concat str (buffer-substring + (+ beg offset) + (overlay-end other-ov)))) + (setq offset (- (overlay-end other-ov) + beg)))) + (cons offset str))) + +(defun avy--style-fn (style) + "Transform STYLE symbol to a style function." + (cl-case style + (pre #'avy--overlay-pre) + (at #'avy--overlay-at) + (at-full 'avy--overlay-at-full) + (post #'avy--overlay-post) + (de-bruijn #'avy--overlay-at-full) + (words #'avy--overlay-at-full) + (ignore #'ignore) + (t (error "Unexpected style %S" style)))) + +(cl-defun avy-jump (regex &key window-flip beg end action pred group) + "Jump to REGEX. +The window scope is determined by `avy-all-windows'. +When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +ACTION is a function that takes point position as an argument. +When PRED is non-nil, it's a filter for matching point positions. +When GROUP is non-nil, it's either a match group in REGEX, or a function +that returns a cons of match beginning and end." + (setq avy-action (or action avy-action)) + (let ((avy-all-windows + (if window-flip + (not avy-all-windows) + avy-all-windows))) + (avy-process + (avy--regex-candidates regex beg end pred group)))) + +(defun avy--generic-jump (regex window-flip &optional beg end) + "Jump to REGEX. +The window scope is determined by `avy-all-windows'. +When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (declare (obsolete avy-jump "0.4.0")) + (let ((avy-all-windows + (if window-flip + (not avy-all-windows) + avy-all-windows))) + (avy-process + (avy--regex-candidates regex beg end)))) + +;;* Commands +;;;###autoload +(defun avy-goto-char (char &optional arg) + "Jump to the currently visible CHAR. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-char + (avy-jump + (if (= 13 char) + "\n" + (regexp-quote (string char))) + :window-flip arg))) + +;;;###autoload +(defun avy-goto-char-in-line (char) + "Jump to the currently visible CHAR in the current line." + (interactive (list (read-char "char: " t))) + (avy-with avy-goto-char + (avy-jump + (regexp-quote (string char)) + :beg (line-beginning-position) + :end (line-end-position)))) + +;;;###autoload +(defun avy-goto-char-2 (char1 char2 &optional arg beg end) + "Jump to the currently visible CHAR1 followed by CHAR2. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive (list (let ((c1 (read-char "char 1: " t))) + (if (memq c1 '(? ?\b)) + (keyboard-quit) + c1)) + (let ((c2 (read-char "char 2: " t))) + (cond ((eq c2 ?) + (keyboard-quit)) + ((memq c2 avy-del-last-char-by) + (keyboard-escape-quit) + (call-interactively 'avy-goto-char-2)) + (t + c2))) + current-prefix-arg + nil nil)) + (when (eq char1 ? ) + (setq char1 ?\n)) + (when (eq char2 ? ) + (setq char2 ?\n)) + (avy-with avy-goto-char-2 + (avy-jump + (regexp-quote (string char1 char2)) + :window-flip arg + :beg beg + :end end))) + +;;;###autoload +(defun avy-goto-char-2-above (char1 char2 &optional arg) + "Jump to the currently visible CHAR1 followed by CHAR2. +This is a scoped version of `avy-goto-char-2', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char 1: " t) + (read-char "char 2: " t) + current-prefix-arg)) + (avy-with avy-goto-char-2-above + (avy-goto-char-2 + char1 char2 arg + (window-start) (point)))) + +;;;###autoload +(defun avy-goto-char-2-below (char1 char2 &optional arg) + "Jump to the currently visible CHAR1 followed by CHAR2. +This is a scoped version of `avy-goto-char-2', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char 1: " t) + (read-char "char 2: " t) + current-prefix-arg)) + (avy-with avy-goto-char-2-below + (avy-goto-char-2 + char1 char2 arg + (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-isearch () + "Jump to one of the current isearch candidates." + (interactive) + (avy-with avy-isearch + (let ((avy-background nil) + (avy-case-fold-search case-fold-search)) + (prog1 + (avy-process + (avy--regex-candidates (if isearch-regexp + isearch-string + (regexp-quote isearch-string)))) + (isearch-done))))) + +;;;###autoload +(defun avy-goto-word-0 (arg &optional beg end) + "Jump to a word start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-jump avy-goto-word-0-regexp + :window-flip arg + :beg beg + :end end))) + +;;;###autoload +(defun avy-goto-whitespace-end (arg &optional beg end) + "Jump to the end of a whitespace sequence. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-jump "[ \t]+\\|\n[ \t]*" + :window-flip arg + :beg beg + :end end + :group (lambda () (cons (point) (1+ (point))))))) + +(defun avy-goto-word-0-above (arg) + "Jump to a word start between window start and point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-goto-word-0 arg (window-start) (point)))) + +(defun avy-goto-word-0-below (arg) + "Jump to a word start between point and window end. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-goto-word-0 arg (point) (window-end (selected-window) t)))) + +(defun avy-goto-whitespace-end-above (arg) + "Jump to the end of a whitespace sequence between point and window end. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-goto-whitespace-end arg (window-start) (point)))) + +(defun avy-goto-whitespace-end-below (arg) + "Jump to the end of a whitespace sequence between window start and point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-goto-whitespace-end arg (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-goto-word-1 (char &optional arg beg end symbol) + "Jump to the currently visible CHAR at a word start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When SYMBOL is non-nil, jump to symbol start instead of word start." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (let* ((str (string char)) + (regex (cond ((string= str ".") + "\\.") + ((and avy-word-punc-regexp + (string-match avy-word-punc-regexp str)) + (regexp-quote str)) + ((<= char 26) + str) + (t + (concat + (if symbol "\\_<" "\\b") + str))))) + (avy-jump regex + :window-flip arg + :beg beg + :end end)))) + +;;;###autoload +(defun avy-goto-word-1-above (char &optional arg) + "Jump to the currently visible CHAR at a word start. +This is a scoped version of `avy-goto-word-1', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (avy-goto-word-1 char arg (window-start) (point)))) + +;;;###autoload +(defun avy-goto-word-1-below (char &optional arg) + "Jump to the currently visible CHAR at a word start. +This is a scoped version of `avy-goto-word-1', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (avy-goto-word-1 char arg (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-goto-symbol-1 (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1 + (avy-goto-word-1 char arg nil nil t))) + +;;;###autoload +(defun avy-goto-symbol-1-above (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +This is a scoped version of `avy-goto-symbol-1', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1-above + (avy-goto-word-1 char arg (window-start) (point) t))) + +;;;###autoload +(defun avy-goto-symbol-1-below (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +This is a scoped version of `avy-goto-symbol-1', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1-below + (avy-goto-word-1 char arg (point) (window-end (selected-window) t) t))) + +(declare-function subword-backward "subword") +(defvar subword-backward-regexp) + +(defcustom avy-subword-extra-word-chars '(?{ ?= ?} ?* ?: ?> ?<) + "A list of characters that should temporarily match \"\\w\". +This variable is used by `avy-goto-subword-0' and `avy-goto-subword-1'." + :type '(repeat character)) + +;;;###autoload +(defun avy-goto-subword-0 (&optional arg predicate beg end) + "Jump to a word or subword start. +The window scope is determined by `avy-all-windows' (ARG negates it). + +When PREDICATE is non-nil it's a function of zero parameters that +should return true. + +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (require 'subword) + (avy-with avy-goto-subword-0 + (let ((case-fold-search nil) + (subword-backward-regexp + "\\(\\(\\W\\|[[:lower:][:digit:]]\\)\\([!-/:@`~[:upper:]]+\\W*\\)\\|\\W\\w+\\)") + candidates) + (avy-dowindows arg + (let ((syn-tbl (copy-syntax-table))) + (dolist (char avy-subword-extra-word-chars) + (modify-syntax-entry char "w" syn-tbl)) + (with-syntax-table syn-tbl + (let ((ws (or beg (window-start))) + window-cands) + (save-excursion + (goto-char (or end (window-end (selected-window) t))) + (subword-backward) + (while (> (point) ws) + (when (or (null predicate) + (and predicate (funcall predicate))) + (unless (not (avy--visible-p (point))) + (push (cons (cons (point) (1+ (point))) + (selected-window)) window-cands))) + (subword-backward)) + (and (= (point) ws) + (or (null predicate) + (and predicate (funcall predicate))) + (not (get-char-property (point) 'invisible)) + (push (cons (cons (point) (1+ (point))) + (selected-window)) window-cands))) + (setq candidates (nconc candidates window-cands)))))) + (avy-process candidates)))) + +;;;###autoload +(defun avy-goto-subword-1 (char &optional arg) + "Jump to the currently visible CHAR at a subword start. +The window scope is determined by `avy-all-windows' (ARG negates it). +The case of CHAR is ignored." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-subword-1 + (let ((char (downcase char))) + (avy-goto-subword-0 + arg (lambda () + (and (char-after) + (eq (downcase (char-after)) char))))))) + +;;;###autoload +(defun avy-goto-word-or-subword-1 () + "Forward to `avy-goto-subword-1' or `avy-goto-word-1'. +Which one depends on variable `subword-mode'." + (interactive) + (if (bound-and-true-p subword-mode) + (call-interactively #'avy-goto-subword-1) + (call-interactively #'avy-goto-word-1))) + +(defvar visual-line-mode) + +(defcustom avy-indent-line-overlay nil + "When non-nil, display line overlay next to the first non-whitespace character. +This affects `avy-goto-line'." + :type 'boolean) + +(defun avy--line-cands (&optional arg beg end bottom-up) + "Get candidates for selecting a line. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (let (candidates) + (avy-dowindows arg + (let ((ws (or beg (window-start)))) + (save-excursion + (save-restriction + (narrow-to-region ws (or end (window-end (selected-window) t))) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (member (get-char-property + (max (1- (point)) ws) 'invisible) '(nil org-link)) + (push (cons + (if (eq avy-style 'post) + (line-end-position) + (save-excursion + (when avy-indent-line-overlay + (skip-chars-forward " \t")) + (point))) + (selected-window)) candidates)) + (if visual-line-mode + (line-move-visual 1 t) + (forward-line 1))))))) + (if bottom-up + candidates + (nreverse candidates)))) + +(defun avy--linum-strings () + "Get strings for `avy-linum-mode'." + (let* ((lines (mapcar #'car (avy--line-cands))) + (line-tree (avy-tree lines avy-keys)) + (line-list nil)) + (avy-traverse + line-tree + (lambda (path _leaf) + (let ((str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (> (length str) 1) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (push str line-list)))) + (nreverse line-list))) + +(defvar linum-available) +(defvar linum-overlays) +(defvar linum-format) +(declare-function linum--face-width "linum") +(declare-function linum-mode "linum") + +(define-minor-mode avy-linum-mode + "Minor mode that uses avy hints for `linum-mode'." + :group 'avy + (if avy-linum-mode + (progn + (require 'linum) + (advice-add 'linum-update-window :around 'avy--linum-update-window) + (linum-mode 1)) + (advice-remove 'linum-update-window 'avy--linum-update-window) + (linum-mode -1))) + +(defun avy--linum-update-window (_ win) + "Update line numbers for the portion visible in window WIN." + (goto-char (window-start win)) + (let ((line (line-number-at-pos)) + (limit (window-end win t)) + (fmt (cond ((stringp linum-format) linum-format) + ((eq linum-format 'dynamic) + (let ((w (length (number-to-string + (count-lines (point-min) (point-max)))))) + (concat "%" (number-to-string w) "d"))))) + (width 0) + (avy-strs (when avy-linum-mode + (avy--linum-strings)))) + (run-hooks 'linum-before-numbering-hook) + ;; Create an overlay (or reuse an existing one) for each + ;; line visible in this window, if necessary. + (while (and (not (eobp)) (< (point) limit)) + (let* ((str + (cond (avy-linum-mode + (pop avy-strs)) + (fmt + (propertize (format fmt line) 'face 'linum)) + (t + (funcall linum-format line)))) + (visited (catch 'visited + (dolist (o (overlays-in (point) (point))) + (when (equal-including-properties + (overlay-get o 'linum-str) str) + (unless (memq o linum-overlays) + (push o linum-overlays)) + (setq linum-available (delq o linum-available)) + (throw 'visited t)))))) + (setq width (max width (length str))) + (unless visited + (let ((ov (if (null linum-available) + (make-overlay (point) (point)) + (move-overlay (pop linum-available) (point) (point))))) + (push ov linum-overlays) + (overlay-put ov 'before-string + (propertize " " 'display `((margin left-margin) ,str))) + (overlay-put ov 'linum-str str)))) + ;; Text may contain those nasty intangible properties, but that + ;; shouldn't prevent us from counting those lines. + (let ((inhibit-point-motion-hooks t)) + (forward-line)) + (setq line (1+ line))) + (when (display-graphic-p) + (setq width (ceiling + (/ (* width 1.0 (linum--face-width 'linum)) + (frame-char-width))))) + (set-window-margins win width (cdr (window-margins win))))) + +(defun avy--line (&optional arg beg end bottom-up) + "Select a line. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (setq avy-action (or avy-action #'identity)) + (let ((avy-style (if avy-linum-mode + (progn + (message "Goto line:") + 'ignore) + avy-style))) + (avy-process + (avy--line-cands arg beg end bottom-up)))) + +;;;###autoload +(defun avy-goto-line (&optional arg) + "Jump to a line start in current buffer. + +When ARG is 1, jump to lines currently visible, with the option +to cancel to `goto-line' by entering a number. + +When ARG is 4, negate the window scope determined by +`avy-all-windows'. + +Otherwise, forward to `goto-line' with ARG." + (interactive "p") + (setq arg (or arg 1)) + (if (not (memq arg '(1 4))) + (progn + (goto-char (point-min)) + (forward-line (1- arg))) + (avy-with avy-goto-line + (let* ((avy-handler-old avy-handler-function) + (avy-handler-function + (lambda (char) + (if (or (< char ?0) + (> char ?9)) + (funcall avy-handler-old char) + (let ((line (read-from-minibuffer + "Goto line: " (string char)))) + (when line + (avy-push-mark) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- (string-to-number line)))) + (throw 'done 'exit)))))) + (r (avy--line (eq arg 4)))) + (when (and (not (memq r '(t nil))) (eq avy-action #'identity)) + (avy-action-goto r)))))) + +;;;###autoload +(defun avy-goto-line-above (&optional offset bottom-up) + "Goto visible line above the cursor. +OFFSET changes the distance between the closest key to the cursor and +the cursor +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (interactive) + (if offset + (setq offset (+ 2 (- offset)))) + (let* ((avy-all-windows nil) + (r (avy--line nil (window-start) + (line-beginning-position (or offset 1)) + bottom-up))) + (unless (eq r t) + (avy-action-goto r)))) + +;;;###autoload +(defun avy-goto-line-below (&optional offset bottom-up) + "Goto visible line below the cursor. +OFFSET changes the distance between the closest key to the cursor and +the cursor +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (interactive) + (if offset + (setq offset (+ offset 1))) + (let* ((avy-all-windows nil) + (r (avy--line + nil (line-beginning-position (or offset 2)) + (window-end (selected-window) t) + bottom-up))) + (unless (eq r t) + (avy-action-goto r)))) + +(defcustom avy-line-insert-style 'above + "How to insert the newly copied/cut line." + :type '(choice + (const :tag "Above" above) + (const :tag "Below" below))) + +;;;###autoload +(defun avy-goto-end-of-line (&optional arg) + "Call `avy-goto-line' and move to the end of the line." + (interactive "p") + (avy-goto-line arg) + (end-of-line)) + +;;;###autoload +(defun avy-copy-line (arg) + "Copy a selected line above the current line. +ARG lines can be used." + (interactive "p") + (let ((initial-window (selected-window))) + (avy-with avy-copy-line + (let* ((start (avy--line)) + (str (buffer-substring-no-properties + start + (save-excursion + (goto-char start) + (move-end-of-line arg) + (point))))) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert str "\n"))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (insert "\n" str) + (beginning-of-line)) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-move-line (arg) + "Move a selected line above the current line. +ARG lines can be used." + (interactive "p") + (let ((initial-window (selected-window))) + (avy-with avy-move-line + (let ((start (avy--line))) + (save-excursion + (goto-char start) + (kill-whole-line arg)) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert + (current-kill 0)))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (newline) + (save-excursion + (insert (substring (current-kill 0) 0 -1)))) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-copy-region (arg) + "Select two lines and copy the text between them to point. + +The window scope is determined by `avy-all-windows' or +`avy-all-windows-alt' when ARG is non-nil." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-copy-region + (let* ((beg (save-selected-window + (avy--line arg))) + (end (avy--line arg)) + (str (buffer-substring-no-properties + beg + (save-excursion + (goto-char end) + (line-end-position))))) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert str "\n"))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (newline) + (save-excursion + (insert str))) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-move-region () + "Select two lines and move the text between them above the current line." + (interactive) + (avy-with avy-move-region + (let* ((initial-window (selected-window)) + (beg (avy--line)) + (end (avy--line)) + text) + (when (> beg end) + (cl-rotatef beg end)) + (setq end (save-excursion + (goto-char end) + (1+ (line-end-position)))) + (setq text (buffer-substring beg end)) + (move-beginning-of-line nil) + (delete-region beg end) + (select-window initial-window) + (insert text)))) + +;;;###autoload +(defun avy-kill-region (arg) + "Select two lines and kill the region between them. + +The window scope is determined by `avy-all-windows' or +`avy-all-windows-alt' when ARG is non-nil." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-region + (let* ((beg (save-selected-window + (list (avy--line arg) (selected-window)))) + (end (list (avy--line arg) (selected-window)))) + (cond + ((not (numberp (car beg))) + (user-error "Fail to select the beginning of region")) + ((not (numberp (car end))) + (user-error "Fail to select the end of region")) + ;; Restrict operation to same window. It's better if it can be + ;; different windows but same buffer; however, then the cloned + ;; buffers with different narrowed regions might cause problem. + ((not (equal (cdr beg) (cdr end))) + (user-error "Selected points are not in the same window")) + ((< (car beg) (car end)) + (save-excursion + (kill-region + (car beg) + (progn (goto-char (car end)) (forward-visible-line 1) (point))))) + (t + (save-excursion + (kill-region + (progn (goto-char (car beg)) (forward-visible-line 1) (point)) + (car end))))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-ring-save-region (arg) + "Select two lines and save the region between them to the kill ring. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-ring-save-region + (let* ((beg (save-selected-window + (list (avy--line arg) (selected-window)))) + (end (list (avy--line arg) (selected-window)))) + (cond + ((not (numberp (car beg))) + (user-error "Fail to select the beginning of region")) + ((not (numberp (car end))) + (user-error "Fail to select the end of region")) + ((not (equal (cdr beg) (cdr end))) + (user-error "Selected points are not in the same window")) + ((< (car beg) (car end)) + (save-excursion + (kill-ring-save + (car beg) + (progn (goto-char (car end)) (forward-visible-line 1) (point))))) + (t + (save-excursion + (kill-ring-save + (progn (goto-char (car beg)) (forward-visible-line 1) (point)) + (car end))))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-whole-line (arg) + "Select line and kill the whole selected line. + +With a numerical prefix ARG, kill ARG line(s) starting from the +selected line. If ARG is negative, kill backward. + +If ARG is zero, kill the selected line but exclude the trailing +newline. + +\\[universal-argument] 3 \\[avy-kil-whole-line] kill three lines +starting from the selected line. \\[universal-argument] -3 + +\\[avy-kill-whole-line] kill three lines backward including the +selected line." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-whole-line + (let* ((start (avy--line))) + (if (not (numberp start)) + (user-error "Fail to select the line to kill") + (save-excursion (goto-char start) + (kill-whole-line arg))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-ring-save-whole-line (arg) + "Select line and save the whole selected line as if killed, but don’t kill it. + +This command is similar to `avy-kill-whole-line', except that it +saves the line(s) as if killed, but does not kill it(them). + +With a numerical prefix ARG, kill ARG line(s) starting from the +selected line. If ARG is negative, kill backward. + +If ARG is zero, kill the selected line but exclude the trailing +newline." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-ring-save-whole-line + (let* ((start (avy--line))) + (if (not (numberp start)) + (user-error "Fail to select the line to kill") + (save-excursion + (let ((kill-read-only-ok t) + (buffer-read-only t)) + (goto-char start) + (kill-whole-line arg)))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-setup-default () + "Setup the default shortcuts." + (eval-after-load "isearch" + '(define-key isearch-mode-map (kbd "C-'") 'avy-isearch))) + +(defcustom avy-timeout-seconds 0.5 + "How many seconds to wait for the second char." + :type 'float) + +(defcustom avy-enter-times-out t + "Whether enter exits avy-goto-char-timer early. If nil it matches newline" + :type 'boolean) + +(defvar avy-text "" + "Store the input read by `avy--read-candidates'.") + +(defun avy--read-candidates (&optional re-builder) + "Read as many chars as possible and return their occurrences. +At least one char must be read, and then repeatedly one next char +may be read if it is entered before `avy-timeout-seconds'. DEL +deletes the last char entered, and RET exits with the currently +read string immediately instead of waiting for another char for +`avy-timeout-seconds'. +The format of the result is the same as that of `avy--regex-candidates'. +This function obeys `avy-all-windows' setting. +RE-BUILDER is a function that takes a string and returns a regex. +When nil, `regexp-quote' is used. +If a group is captured, the first group is highlighted. +Otherwise, the whole regex is highlighted." + (setq avy-text "") + (let ((re-builder (or re-builder #'regexp-quote)) + char break overlays regex) + (unwind-protect + (progn + (avy--make-backgrounds + (avy-window-list)) + (while (and (not break) + (setq char + (read-char (format "%d char%s: " + (length overlays) + (if (string= avy-text "") + avy-text + (format " (%s)" avy-text))) + t + (and (not (string= avy-text "")) + avy-timeout-seconds)))) + ;; Unhighlight + (dolist (ov overlays) + (delete-overlay ov)) + (setq overlays nil) + (cond + ;; Handle RET + ((= char 13) + (if avy-enter-times-out + (setq break t) + (setq avy-text (concat avy-text (list ?\n))))) + ;; Handle C-h, DEL + ((memq char avy-del-last-char-by) + (let ((l (length avy-text))) + (when (>= l 1) + (setq avy-text (substring avy-text 0 (1- l)))))) + ;; Handle ESC + ((= char 27) + (keyboard-quit)) + (t + (setq avy-text (concat avy-text (list char))))) + ;; Highlight + (when (>= (length avy-text) 1) + (let ((case-fold-search + (or avy-case-fold-search (string= avy-text (downcase avy-text)))) + found) + (avy-dowindows current-prefix-arg + (dolist (pair (avy--find-visible-regions + (window-start) + (window-end (selected-window) t))) + (save-excursion + (goto-char (car pair)) + (setq regex (funcall re-builder avy-text)) + (while (re-search-forward regex (cdr pair) t) + (unless (not (avy--visible-p (1- (point)))) + (let* ((idx (if (= (length (match-data)) 4) 1 0)) + (ov (make-overlay + (match-beginning idx) (match-end idx)))) + (setq found t) + (push ov overlays) + (overlay-put + ov 'window (selected-window)) + (overlay-put + ov 'face 'avy-goto-char-timer-face))))))) + ;; No matches at all, so there's surely a typo in the input. + (unless found (beep))))) + (nreverse (mapcar (lambda (ov) + (cons (cons (overlay-start ov) + (overlay-end ov)) + (overlay-get ov 'window))) + overlays))) + (dolist (ov overlays) + (delete-overlay ov)) + (avy--done)))) + +(defvar avy--old-cands nil) + +;;;###autoload +(defun avy-goto-char-timer (&optional arg) + "Read one or many consecutive chars and jump to the first one. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive "P") + (let ((avy-all-windows (if arg + (not avy-all-windows) + avy-all-windows))) + (avy-with avy-goto-char-timer + (setq avy--old-cands (avy--read-candidates)) + (avy-process avy--old-cands)))) + +(defun avy-push-mark () + "Store the current point and window." + (let ((inhibit-message t)) + (ring-insert avy-ring + (cons (point) (selected-window))) + (unless (region-active-p) + (push-mark)))) + +(defun avy-pop-mark () + "Jump back to the last location of `avy-push-mark'." + (interactive) + (let (res) + (condition-case nil + (progn + (while (not (window-live-p + (cdr (setq res (ring-remove avy-ring 0)))))) + (let* ((window (cdr res)) + (frame (window-frame window))) + (when (and (frame-live-p frame) + (not (eq frame (selected-frame)))) + (select-frame-set-input-focus frame)) + (select-window window) + (goto-char (car res)))) + (error + (set-mark-command 4))))) + +;;;###autoload +(defun avy-transpose-lines-in-region () + "Transpose lines in the active region." + (interactive) + (when (and (use-region-p) (> (count-lines (region-beginning) (region-end)) 1)) + (let ((avy-all-windows nil) + (fst-line-point (avy--line nil (region-beginning) (region-end)))) + (when fst-line-point + (let ((snd-line-point (avy--line nil (region-beginning) (region-end)))) + (when snd-line-point + (save-mark-and-excursion + (push-mark fst-line-point) + (goto-char snd-line-point) + (transpose-lines 0)) + (avy-transpose-lines-in-region))))))) + +;; ** Org-mode +(defvar org-reverse-note-order) +(declare-function org-refile "org") +(declare-function org-back-to-heading "org") +(declare-function org-reveal "org") + +(defvar org-after-refile-insert-hook) + +(defun avy-org-refile-as-child () + "Refile current heading as first child of heading selected with `avy.'" + ;; Inspired by `org-teleport': http://kitchingroup.cheme.cmu.edu/blog/2016/03/18/Org-teleport-headlines/ + (interactive) + (let* ((org-reverse-note-order t) + (marker (save-excursion + (avy-with avy-goto-line + (unless (eq 't (avy-jump (rx bol (1+ "*") (1+ space)))) + ;; `avy-jump' returns t when aborted with C-g. + (point-marker))))) + (filename (buffer-file-name (or (buffer-base-buffer (marker-buffer marker)) + (marker-buffer marker)))) + (rfloc (list nil filename nil marker)) + ;; Ensure the refiled heading is visible. + (org-after-refile-insert-hook (if (member 'org-reveal org-after-refile-insert-hook) + org-after-refile-insert-hook + (cons #'org-reveal org-after-refile-insert-hook)))) + (when marker + ;; Only attempt refile if avy session was not aborted. + (org-refile nil nil rfloc)))) + +(defun avy-org-goto-heading-timer (&optional arg) + "Read one or many characters and jump to matching Org headings. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive "P") + (let ((avy-all-windows (if arg + (not avy-all-windows) + avy-all-windows))) + (avy-with avy-goto-char-timer + (avy-process + (avy--read-candidates + (lambda (input) + (format "^\\*+ .*\\(%s\\)" input)))) + (org-back-to-heading)))) + +(provide 'avy) + +;;; avy.el ends here 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 "