From 92c3e19a468aeb0adab6818acaaad45a21a1e8b0 Mon Sep 17 00:00:00 2001 From: liding Date: Mon, 23 Oct 2023 14:13:34 +0800 Subject: [PATCH] First release. --- .gitattributes | 6 + .gitignore | 0 .gitmodules | 45 + LICENSE | 661 +++ README.md | 53 + site-lisp/extensions-local/auto-save.el | 126 + site-lisp/extensions-local/cmake-mode.el | 533 ++ site-lisp/extensions-local/company-ctags.el | 528 ++ .../extensions-local/dired-display-buffer.el | 87 + .../extensions-local/dired-hacks-utils.el | 273 + site-lisp/extensions-local/dired-narrow.el | 356 ++ site-lisp/extensions-local/dired-subtree.el | 784 +++ site-lisp/extensions-local/echo-keys.el | 126 + site-lisp/extensions-local/evals.el | 21 + site-lisp/extensions-local/force-indent.el | 81 + site-lisp/extensions-local/frame-restore.el | 93 + .../extensions-local/goto-last-change.el | 141 + .../extensions-local/goto-line-preview.el | 124 + .../extensions-local/highlight-indentation.el | 312 ++ .../extensions-local/highlight-parentheses.el | 157 + site-lisp/extensions-local/lazy-load.el | 49 + .../extensions-local/ld-buffer-operations.el | 72 + site-lisp/extensions-local/ld-delete-block.el | 38 + .../extensions-local/ld-file-operations.el | 14 + .../extensions-local/ld-goto-cursor-stack.el | 39 + site-lisp/extensions-local/ld-goto-simple.el | 30 + .../ld-org-publish-project-desc.el | 106 + .../extensions-local/ld-text-operations.el | 109 + .../extensions-local/ld-toggle-one-window.el | 22 + site-lisp/extensions-local/ld-tools.el | 167 + site-lisp/extensions-local/neotree.el | 2228 ++++++++ .../extensions-local/scroll-next-window.el | 42 + site-lisp/extensions-local/undo-tree.el | 4653 +++++++++++++++++ site-lisp/extensions-submodule/ace-window | 1 + site-lisp/extensions-submodule/avy | 1 + site-lisp/extensions-submodule/citre | 1 + site-lisp/extensions-submodule/company-mode | 1 + site-lisp/extensions-submodule/dash.el | 1 + .../extensions-submodule/emacs-which-key | 1 + site-lisp/extensions-submodule/go-mode.el | 1 + site-lisp/extensions-submodule/jsonian | 1 + site-lisp/extensions-submodule/lua-mode | 1 + site-lisp/extensions-submodule/markdown-mode | 1 + site-lisp/extensions-submodule/modus-themes | 1 + .../extensions-submodule/multiple-cursors.el | 1 + site-lisp/extensions-submodule/swiper | 1 + site-lisp/extensions-submodule/web-mode | 1 + site-lisp/extensions-submodule/yasnippet | 1 + site-lisp/init-config/init-ace-window.el | 10 + site-lisp/init-config/init-auto-save.el | 14 + site-lisp/init-config/init-avy.el | 19 + site-lisp/init-config/init-citre.el | 10 + site-lisp/init-config/init-coding-system.el | 34 + site-lisp/init-config/init-company-mode.el | 13 + site-lisp/init-config/init-dired.el | 23 + site-lisp/init-config/init-generic.el | 149 + .../init-config/init-highlight-parentheses.el | 11 + site-lisp/init-config/init-indent.el | 59 + site-lisp/init-config/init-mode.el | 92 + site-lisp/init-config/init-neotree.el | 12 + site-lisp/init-config/init-org-todo.el | 37 + site-lisp/init-config/init-org.el | 233 + site-lisp/init-config/init-proxy.el | 45 + site-lisp/init-config/init-session.el | 51 + site-lisp/init-config/init-shortcut.el | 256 + site-lisp/init-config/init-swiper.el | 34 + site-lisp/init-config/init-theme.el | 82 + site-lisp/init-config/init-time.el | 14 + site-lisp/init-config/init-undo-tree.el | 19 + site-lisp/init-config/init-which-key.el | 17 + site-lisp/init-config/init-yasnippet.el | 17 + site-lisp/init-config/init.el | 46 + site-lisp/snippets/lua-mode/function | 6 + site-lisp/snippets/org-mode/bloghead | 8 + site-lisp/snippets/org-mode/notehead | 7 + site-lisp/snippets/sh-mode/bang | 6 + site-lisp/snippets/snippet-mode/cont | 5 + site-lisp/snippets/snippet-mode/elisp | 5 + site-lisp/snippets/snippet-mode/field | 6 + site-lisp/snippets/snippet-mode/group | 5 + site-lisp/snippets/snippet-mode/mirror | 6 + site-lisp/snippets/snippet-mode/vars | 13 + site-start.el | 51 + 83 files changed, 13506 insertions(+) create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 .gitmodules create mode 100644 LICENSE create mode 100644 README.md create mode 100644 site-lisp/extensions-local/auto-save.el create mode 100644 site-lisp/extensions-local/cmake-mode.el create mode 100644 site-lisp/extensions-local/company-ctags.el create mode 100644 site-lisp/extensions-local/dired-display-buffer.el create mode 100644 site-lisp/extensions-local/dired-hacks-utils.el create mode 100644 site-lisp/extensions-local/dired-narrow.el create mode 100644 site-lisp/extensions-local/dired-subtree.el create mode 100644 site-lisp/extensions-local/echo-keys.el create mode 100644 site-lisp/extensions-local/evals.el create mode 100644 site-lisp/extensions-local/force-indent.el create mode 100644 site-lisp/extensions-local/frame-restore.el create mode 100644 site-lisp/extensions-local/goto-last-change.el create mode 100644 site-lisp/extensions-local/goto-line-preview.el create mode 100644 site-lisp/extensions-local/highlight-indentation.el create mode 100644 site-lisp/extensions-local/highlight-parentheses.el create mode 100644 site-lisp/extensions-local/lazy-load.el create mode 100644 site-lisp/extensions-local/ld-buffer-operations.el create mode 100644 site-lisp/extensions-local/ld-delete-block.el create mode 100644 site-lisp/extensions-local/ld-file-operations.el create mode 100644 site-lisp/extensions-local/ld-goto-cursor-stack.el create mode 100644 site-lisp/extensions-local/ld-goto-simple.el create mode 100644 site-lisp/extensions-local/ld-org-publish-project-desc.el create mode 100644 site-lisp/extensions-local/ld-text-operations.el create mode 100644 site-lisp/extensions-local/ld-toggle-one-window.el create mode 100644 site-lisp/extensions-local/ld-tools.el create mode 100644 site-lisp/extensions-local/neotree.el create mode 100644 site-lisp/extensions-local/scroll-next-window.el create mode 100644 site-lisp/extensions-local/undo-tree.el create mode 160000 site-lisp/extensions-submodule/ace-window create mode 160000 site-lisp/extensions-submodule/avy create mode 160000 site-lisp/extensions-submodule/citre create mode 160000 site-lisp/extensions-submodule/company-mode create mode 160000 site-lisp/extensions-submodule/dash.el create mode 160000 site-lisp/extensions-submodule/emacs-which-key create mode 160000 site-lisp/extensions-submodule/go-mode.el create mode 160000 site-lisp/extensions-submodule/jsonian create mode 160000 site-lisp/extensions-submodule/lua-mode create mode 160000 site-lisp/extensions-submodule/markdown-mode create mode 160000 site-lisp/extensions-submodule/modus-themes create mode 160000 site-lisp/extensions-submodule/multiple-cursors.el create mode 160000 site-lisp/extensions-submodule/swiper create mode 160000 site-lisp/extensions-submodule/web-mode create mode 160000 site-lisp/extensions-submodule/yasnippet create mode 100644 site-lisp/init-config/init-ace-window.el create mode 100644 site-lisp/init-config/init-auto-save.el create mode 100644 site-lisp/init-config/init-avy.el create mode 100644 site-lisp/init-config/init-citre.el create mode 100644 site-lisp/init-config/init-coding-system.el create mode 100644 site-lisp/init-config/init-company-mode.el create mode 100644 site-lisp/init-config/init-dired.el create mode 100644 site-lisp/init-config/init-generic.el create mode 100644 site-lisp/init-config/init-highlight-parentheses.el create mode 100644 site-lisp/init-config/init-indent.el create mode 100644 site-lisp/init-config/init-mode.el create mode 100644 site-lisp/init-config/init-neotree.el create mode 100644 site-lisp/init-config/init-org-todo.el create mode 100644 site-lisp/init-config/init-org.el create mode 100644 site-lisp/init-config/init-proxy.el create mode 100644 site-lisp/init-config/init-session.el create mode 100644 site-lisp/init-config/init-shortcut.el create mode 100644 site-lisp/init-config/init-swiper.el create mode 100644 site-lisp/init-config/init-theme.el create mode 100644 site-lisp/init-config/init-time.el create mode 100644 site-lisp/init-config/init-undo-tree.el create mode 100644 site-lisp/init-config/init-which-key.el create mode 100644 site-lisp/init-config/init-yasnippet.el create mode 100644 site-lisp/init-config/init.el create mode 100644 site-lisp/snippets/lua-mode/function create mode 100644 site-lisp/snippets/org-mode/bloghead create mode 100644 site-lisp/snippets/org-mode/notehead create mode 100644 site-lisp/snippets/sh-mode/bang create mode 100644 site-lisp/snippets/snippet-mode/cont create mode 100644 site-lisp/snippets/snippet-mode/elisp create mode 100644 site-lisp/snippets/snippet-mode/field create mode 100644 site-lisp/snippets/snippet-mode/group create mode 100644 site-lisp/snippets/snippet-mode/mirror create mode 100644 site-lisp/snippets/snippet-mode/vars create mode 100644 site-start.el diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..a9c0e87 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,6 @@ +# Automatically normalize line endings (to LF) for all text-based files. +* text=auto eol=lf + +# Do not modify line endings for binary files (which are sometimes auto +# detected as text files by git). +*.png binary diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e69de29 diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..a074062 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,45 @@ +[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 +[submodule "site-lisp/extensions-submodule/yasnippet"] + path = site-lisp/extensions-submodule/yasnippet + url = git@github.com:joaotavora/yasnippet.git +[submodule "site-lisp/extensions-submodule/multiple-cursors.el"] + path = site-lisp/extensions-submodule/multiple-cursors.el + url = git@github.com:magnars/multiple-cursors.el.git +[submodule "site-lisp/extensions-submodule/citre"] + path = site-lisp/extensions-submodule/citre + url = git@github.com:universal-ctags/citre.git +[submodule "site-lisp/extensions-submodule/company-mode"] + path = site-lisp/extensions-submodule/company-mode + url = git@github.com:company-mode/company-mode.git diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..0ad25db --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/README.md b/README.md new file mode 100644 index 0000000..c080d6d --- /dev/null +++ b/README.md @@ -0,0 +1,53 @@ +# Install elisp files + +## Debian / Ubuntu + +Clone this repo to home path. + +Build config symlink to emacs directory: + +```bash +sudo ln -s ~/ld-emacs/site-lisp /usr/share/emacs/ld +``` + +Copy site-start.el in emacs directory to start my config: + +```bash +sudo cp ~/ld-emacs/site-start.el /usr/share/emacs/site-lisp/ +``` + +Initialize submodules: + +```plaintext +cd ~/ld-emacs && git submodule update --init --recursive +``` + +## Windows + +Clone this repo to `C:\Users\\AppData\Roaming\ld-emacs` and initialize submodules. + +Put the content below to `~/.emacs.d/init.el` (to `C:\Users\\AppData\Roaming\.emacs.d\init.el`). + +```lisp +(load-file "~/ld-emacs/site-start.el") +``` + +# Install dependencies for extensions + +## Debian / Ubuntu + +```plaintext +# for citre (ctags frontend) +sudo apt install universal-ctags + +# for counsel-rg +sudo apt install ripgrep +``` + +Note: Emacs will load ~/.profile for env variables at the start. According to the code in ~/.profile, emacs will not load ~/.bashrc. So if user wish to add some env variables, the code should be written to ~/.profile. + +## Windows + +Download Universal-ctags binary and add it to environment variable `Path`. + +Download the ripgrep for windows from [ripgrep](https://github.com/BurntSushi/ripgrep) and add the .exe file to env variable `Path`. diff --git a/site-lisp/extensions-local/auto-save.el b/site-lisp/extensions-local/auto-save.el new file mode 100644 index 0000000..de0c16d --- /dev/null +++ b/site-lisp/extensions-local/auto-save.el @@ -0,0 +1,126 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defgroup auto-save nil + "Auto save file when emacs idle." + :group 'auto-save) + +(defcustom auto-save-idle 1 + "The idle seconds to auto save file." + :type 'integer + :group 'auto-save) + +(defcustom auto-save-silent nil + "Nothing to dirty minibuffer if this option is non-nil." + :type 'boolean + :group 'auto-save) + +(defcustom auto-save-delete-trailing-whitespace nil + "Delete trailing whitespace when save if this option is non-nil. +Note, this option is non-nil, will delete all training whitespace execpet current line, +avoid delete current indent space when you programming." + :type 'boolean + :group 'auto-save) + +(defvar auto-save-disable-predicates + nil "disable auto save in these case.") + +;; Emacs' default auto-save is stupid to generate #foo# files! +(setq make-backup-files nil) +(setq auto-save-default nil) +(setq create-lockfiles nil) + +(defun auto-save-buffers () + (interactive) + (let ((autosave-buffer-list)) + (ignore-errors + (save-current-buffer + (dolist (buf (buffer-list)) + (set-buffer buf) + (when (and + ;; Buffer associate with a filename? + (buffer-file-name) + ;; Buffer is modifiable? + (buffer-modified-p) + ;; Yassnippet is not active? + (or (not (boundp 'yas--active-snippets)) + (not yas--active-snippets)) + ;; Company is not active? + (or (not (boundp 'company-candidates)) + (not company-candidates)) + ;; Corfu is not active? + (or (not (boundp 'corfu--total)) + (zerop corfu--total)) + ;; Org-capture is not active? + (not (eq (buffer-base-buffer (get-buffer (concat "CAPTURE-" (buffer-name)))) + buf)) + ;; tell auto-save don't save + (not (seq-some (lambda (predicate) + (funcall predicate)) + auto-save-disable-predicates))) + (push (buffer-name) autosave-buffer-list) + (if auto-save-silent + ;; `inhibit-message' can shut up Emacs, but we want + ;; it doesn't clean up echo area during saving + (with-temp-message "" + (let ((inhibit-message t)) + (basic-save-buffer))) + (basic-save-buffer)) + )) + ;; Tell user when auto save files. + (unless auto-save-silent + (cond + ;; It's stupid tell user if nothing to save. + ((= (length autosave-buffer-list) 1) + (message "# Saved %s" (car autosave-buffer-list))) + ((> (length autosave-buffer-list) 1) + (message "# Saved %d files: %s" + (length autosave-buffer-list) + (mapconcat 'identity autosave-buffer-list ", "))))) + )))) + +(defun auto-save-delete-trailing-whitespace-except-current-line () + (interactive) + (when auto-save-delete-trailing-whitespace + (let ((begin (line-beginning-position)) + (end (point))) + (save-excursion + (when (< (point-min) begin) + (save-restriction + (narrow-to-region (point-min) (1- begin)) + (delete-trailing-whitespace))) + (when (> (point-max) end) + (save-restriction + (narrow-to-region end (point-max)) + (delete-trailing-whitespace))))))) + +(defvar auto-save-timer nil) + +(defun auto-save-set-timer () + "Set the auto-save timer. +Cancel any previous timer." + (auto-save-cancel-timer) + (setq auto-save-timer + (run-with-idle-timer auto-save-idle t 'auto-save-buffers))) + +(defun auto-save-cancel-timer () + (when auto-save-timer + (cancel-timer auto-save-timer) + (setq auto-save-timer nil))) + +(defun auto-save-enable () + (interactive) + (auto-save-set-timer) + (add-hook 'before-save-hook 'auto-save-delete-trailing-whitespace-except-current-line) + ) + +(defun auto-save-disable () + (interactive) + (auto-save-cancel-timer) + (remove-hook 'before-save-hook 'auto-save-delete-trailing-whitespace-except-current-line) + ) + +(provide 'auto-save) + +;;; auto-save.el ends here diff --git a/site-lisp/extensions-local/cmake-mode.el b/site-lisp/extensions-local/cmake-mode.el new file mode 100644 index 0000000..0bb114d --- /dev/null +++ b/site-lisp/extensions-local/cmake-mode.el @@ -0,0 +1,533 @@ +;;; cmake-mode.el --- major-mode for editing CMake sources + +;; Package-Requires: ((emacs "24.1")) +;; Package-Version: 20220823.1201 +;; Package-Commit: 5936d4f2adeec64e0ff748b2c6c34f0436b19a97 + +; Distributed under the OSI-approved BSD 3-Clause License. See accompanying +; file Copyright.txt or https://cmake.org/licensing for details. + +;------------------------------------------------------------------------------ + +;;; Commentary: + +;; Provides syntax highlighting and indentation for CMakeLists.txt and +;; *.cmake source files. +;; +;; Add this code to your .emacs file to use the mode: +;; +;; (setq load-path (cons (expand-file-name "/dir/with/cmake-mode") load-path)) +;; (require 'cmake-mode) + +;------------------------------------------------------------------------------ + +;;; Code: +;; +;; cmake executable variable used to run cmake --help-command +;; on commands in cmake-mode +;; +;; cmake-command-help Written by James Bigler +;; + +(require 'rst) +(require 'rx) + +(defcustom cmake-mode-cmake-executable "cmake" + "*The name of the cmake executable. + +This can be either absolute or looked up in $PATH. You can also +set the path with these commands: + (setenv \"PATH\" (concat (getenv \"PATH\") \";C:\\\\Program Files\\\\CMake 2.8\\\\bin\")) + (setenv \"PATH\" (concat (getenv \"PATH\") \":/usr/local/cmake/bin\"))" + :type 'file + :group 'cmake) + +;; Keywords +(defconst cmake-keywords-block-open '("BLOCK" "IF" "MACRO" "FOREACH" "ELSE" "ELSEIF" "WHILE" "FUNCTION")) +(defconst cmake-keywords-block-close '("ENDBLOCK" "ENDIF" "ENDFOREACH" "ENDMACRO" "ELSE" "ELSEIF" "ENDWHILE" "ENDFUNCTION")) +(defconst cmake-keywords + (let ((kwds (append cmake-keywords-block-open cmake-keywords-block-close nil))) + (delete-dups kwds))) + +;; Regular expressions used by line indentation function. +;; +(defconst cmake-regex-blank "^[ \t]*$") +(defconst cmake-regex-comment "#.*") +(defconst cmake-regex-paren-left "(") +(defconst cmake-regex-paren-right ")") +(defconst cmake-regex-closing-parens-line (concat "^[[:space:]]*\\(" + cmake-regex-paren-right + "+\\)[[:space:]]*$")) +(defconst cmake-regex-argument-quoted + (rx ?\" (* (or (not (any ?\" ?\\)) (and ?\\ anything))) ?\")) +(defconst cmake-regex-argument-unquoted + (rx (or (not (any space "()#\"\\\n")) (and ?\\ nonl)) + (* (or (not (any space "()#\\\n")) (and ?\\ nonl))))) +(defconst cmake-regex-token + (rx-to-string `(group (or (regexp ,cmake-regex-comment) + ?\( ?\) + (regexp ,cmake-regex-argument-unquoted) + (regexp ,cmake-regex-argument-quoted))))) +(defconst cmake-regex-indented + (rx-to-string `(and bol (* (group (or (regexp ,cmake-regex-token) (any space ?\n))))))) +(defconst cmake-regex-block-open + (rx-to-string `(and symbol-start (or ,@(append cmake-keywords-block-open + (mapcar 'downcase cmake-keywords-block-open))) symbol-end))) +(defconst cmake-regex-block-close + (rx-to-string `(and symbol-start (or ,@(append cmake-keywords-block-close + (mapcar 'downcase cmake-keywords-block-close))) symbol-end))) +(defconst cmake-regex-close + (rx-to-string `(and bol (* space) (regexp ,cmake-regex-block-close) + (* space) (regexp ,cmake-regex-paren-left)))) +(defconst cmake-regex-token-paren-left (concat "^" cmake-regex-paren-left "$")) +(defconst cmake-regex-token-paren-right (concat "^" cmake-regex-paren-right "$")) + +;------------------------------------------------------------------------------ + +;; Line indentation helper functions + +(defun cmake-line-starts-inside-string () + "Determine whether the beginning of the current line is in a string." + (save-excursion + (beginning-of-line) + (let ((parse-end (point))) + (goto-char (point-min)) + (nth 3 (parse-partial-sexp (point) parse-end)) + ) + ) + ) + +(defun cmake-find-last-indented-line () + "Move to the beginning of the last line that has meaningful indentation." + (let ((point-start (point)) + region) + (forward-line -1) + (setq region (buffer-substring-no-properties (point) point-start)) + (while (and (not (bobp)) + (or (looking-at cmake-regex-blank) + (cmake-line-starts-inside-string) + (not (and (string-match cmake-regex-indented region) + (= (length region) (match-end 0)))))) + (forward-line -1) + (setq region (buffer-substring-no-properties (point) point-start)) + ) + ) + ) + +;------------------------------------------------------------------------------ + +;; +;; Indentation increment. +;; +(defcustom cmake-tab-width 2 + "Number of columns to indent cmake blocks" + :type 'integer + :group 'cmake) + +;; +;; Line indentation function. +;; +(defun cmake-indent () + "Indent current line as CMake code." + (interactive) + (unless (cmake-line-starts-inside-string) + (if (bobp) + (cmake-indent-line-to 0) + (let (cur-indent) + (save-excursion + (beginning-of-line) + (let ((point-start (point)) + (closing-parens-only (looking-at cmake-regex-closing-parens-line)) + (case-fold-search t) ;; case-insensitive + token) + ;; Search back for the last indented line. + (cmake-find-last-indented-line) + ;; Start with the indentation on this line. + (setq cur-indent (current-indentation)) + (if closing-parens-only + (let ((open-parens 0)) + (while (re-search-forward cmake-regex-token point-start t) + (setq token (match-string 0)) + (cond + ((string-match cmake-regex-token-paren-left token) + (setq open-parens (+ open-parens 1))) + ((string-match cmake-regex-token-paren-right token) + (setq open-parens (- open-parens 1))))) + ;; Don't outdent if last indented line has open parens + (unless (> open-parens 0) + (setq cur-indent (- cur-indent cmake-tab-width)))) + ;; Skip detailed analysis if last indented line is a 'closing + ;; parens only line' + (unless (looking-at cmake-regex-closing-parens-line) + ;; Search forward counting tokens that adjust indentation. + (while (re-search-forward cmake-regex-token point-start t) + (setq token (match-string 0)) + (when (or (string-match cmake-regex-token-paren-left token) + (and (string-match cmake-regex-block-open token) + (looking-at (concat "[ \t]*" cmake-regex-paren-left)))) + (setq cur-indent (+ cur-indent cmake-tab-width))) + (when (string-match cmake-regex-token-paren-right token) + (setq cur-indent (- cur-indent cmake-tab-width))) + )) + (goto-char point-start) + ;; If next token closes the block, decrease indentation + (when (looking-at cmake-regex-close) + (setq cur-indent (- cur-indent cmake-tab-width)) + ) + ) + ) + ) + ;; Indent this line by the amount selected. + (cmake-indent-line-to (max cur-indent 0)) + ) + ) + ) + ) + +(defun cmake-point-in-indendation () + (string-match "^[ \\t]*$" (buffer-substring (point-at-bol) (point)))) + +(defun cmake-indent-line-to (column) + "Indent the current line to COLUMN. +If point is within the existing indentation it is moved to the end of +the indentation. Otherwise it retains the same position on the line" + (if (cmake-point-in-indendation) + (indent-line-to column) + (save-excursion (indent-line-to column)))) + +;------------------------------------------------------------------------------ + +;; +;; Helper functions for buffer +;; +(defun cmake-unscreamify-buffer () + "Convert all CMake commands to lowercase in buffer." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\([ \t]*\\)\\_<\\(\\(?:\\w\\|\\s_\\)+\\)\\_>\\([ \t]*(\\)" nil t) + (replace-match + (concat + (match-string 1) + (downcase (match-string 2)) + (match-string 3)) + t)) + ) + ) + + +;------------------------------------------------------------------------------ + +;; +;; Navigation / marking by function or macro +;; + +(defconst cmake--regex-defun-start + (rx line-start + (zero-or-more space) + (or "function" "macro") + (zero-or-more space) + "(")) + +(defconst cmake--regex-defun-end + (rx line-start + (zero-or-more space) + "end" + (or "function" "macro") + (zero-or-more space) + "(" (zero-or-more (not-char ")")) ")")) + +(defun cmake-beginning-of-defun () + "Move backward to the beginning of a CMake function or macro. + +Return t unless search stops due to beginning of buffer." + (interactive) + (when (not (region-active-p)) + (push-mark)) + (let ((case-fold-search t)) + (when (re-search-backward cmake--regex-defun-start nil 'move) + t))) + +(defun cmake-end-of-defun () + "Move forward to the end of a CMake function or macro. + +Return t unless search stops due to end of buffer." + (interactive) + (when (not (region-active-p)) + (push-mark)) + (let ((case-fold-search t)) + (when (re-search-forward cmake--regex-defun-end nil 'move) + (forward-line) + t))) + +(defun cmake-mark-defun () + "Mark the current CMake function or macro. + +This puts the mark at the end, and point at the beginning." + (interactive) + (cmake-end-of-defun) + (push-mark nil :nomsg :activate) + (cmake-beginning-of-defun)) + + +;------------------------------------------------------------------------------ + +;; +;; Keyword highlighting regex-to-face map. +;; +(defconst cmake-font-lock-keywords + `((,(rx-to-string `(and symbol-start + (or ,@cmake-keywords + ,@(mapcar #'downcase cmake-keywords)) + symbol-end)) + . font-lock-keyword-face) + (,(rx symbol-start (group (+ (or word (syntax symbol)))) (* blank) ?\() + 1 font-lock-function-name-face) + (,(rx "${" (group (+(any alnum "-_+/."))) "}") + 1 font-lock-variable-name-face t) + ) + "Highlighting expressions for CMake mode.") + +;------------------------------------------------------------------------------ + +(defun cmake--syntax-propertize-until-bracket-close (syntax) + ;; This function assumes that a previous search has matched the + ;; beginning of a bracket_comment or bracket_argument and that the + ;; second capture group has matched the equal signs between the two + ;; opening brackets + (let* ((mb (match-beginning 2)) + (me (match-end 2)) + (cb (format "]%s]" (buffer-substring mb me)))) + (save-match-data + (if (search-forward cb end 'move) + (progn + (setq me (match-end 0)) + (put-text-property + (1- me) + me + 'syntax-table + (string-to-syntax syntax))) + (setq me end))) + (put-text-property + (match-beginning 1) + me + 'syntax-multiline + t))) + +(defconst cmake--syntax-propertize-function + (syntax-propertize-rules + ("\\(#\\)\\[\\(=*\\)\\[" + (1 + (prog1 "!" (cmake--syntax-propertize-until-bracket-close "!")))) + ("\\(\\[\\)\\(=*\\)\\[" + (1 + (prog1 "|" (cmake--syntax-propertize-until-bracket-close "|")))))) + +;; Syntax table for this mode. +(defvar cmake-mode-syntax-table nil + "Syntax table for CMake mode.") +(or cmake-mode-syntax-table + (setq cmake-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + (modify-syntax-entry ?# "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?$ "'" table) + table))) + +;; +;; User hook entry point. +;; +(defvar cmake-mode-hook nil) + +;;------------------------------------------------------------------------------ +;; Mode definition. +;; +;;;###autoload +(define-derived-mode cmake-mode prog-mode "CMake" + "Major mode for editing CMake source files." + + ; Setup font-lock mode. + (set (make-local-variable 'font-lock-defaults) '(cmake-font-lock-keywords)) + ; Setup indentation function. + (set (make-local-variable 'indent-line-function) 'cmake-indent) + ; Setup comment syntax. + (set (make-local-variable 'comment-start) "#") + ;; Setup syntax propertization + (set (make-local-variable 'syntax-propertize-function) cmake--syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions #'syntax-propertize-multiline nil t)) + +;; Default cmake-mode key bindings +(define-key cmake-mode-map "\e\C-a" #'cmake-beginning-of-defun) +(define-key cmake-mode-map "\e\C-e" #'cmake-end-of-defun) +(define-key cmake-mode-map "\e\C-h" #'cmake-mark-defun) + + +; Help mode starts here + + +;;;###autoload +(defun cmake-command-run (type &optional topic buffer) + "Runs the command cmake with the arguments specified. The +optional argument topic will be appended to the argument list." + (interactive "s") + (let* ((bufname (if buffer buffer (concat "*CMake" type (if topic "-") topic "*"))) + (buffer (if (get-buffer bufname) (get-buffer bufname) (generate-new-buffer bufname))) + (command (concat cmake-mode-cmake-executable " " type " " topic)) + ;; Turn of resizing of mini-windows for shell-command. + (resize-mini-windows nil) + ) + (shell-command command buffer) + (save-selected-window + (select-window (display-buffer buffer 'not-this-window)) + (cmake-mode) + (read-only-mode 1) + (view-mode 1)) + ) + ) + +;;;###autoload +(defun cmake-command-run-help (type &optional topic buffer) + "`cmake-command-run' but rendered in `rst-mode'." + (interactive "s") + (let* ((bufname (if buffer buffer (concat "*CMake" type (if topic "-") topic "*"))) + (buffer (if (get-buffer bufname) (get-buffer bufname) (generate-new-buffer bufname))) + (command (concat cmake-mode-cmake-executable " " type " " topic)) + ;; Turn of resizing of mini-windows for shell-command. + (resize-mini-windows nil) + ) + (shell-command command buffer) + (save-selected-window + (select-window (display-buffer buffer 'not-this-window)) + (rst-mode) + (read-only-mode 1) + (view-mode 1)) + ) + ) + +;;;###autoload +(defun cmake-help-list-commands () + "Prints out a list of the cmake commands." + (interactive) + (cmake-command-run-help "--help-command-list") + ) + +(defvar cmake-commands '() "List of available topics for --help-command.") +(defvar cmake-help-command-history nil "Command read history.") +(defvar cmake-modules '() "List of available topics for --help-module.") +(defvar cmake-help-module-history nil "Module read history.") +(defvar cmake-variables '() "List of available topics for --help-variable.") +(defvar cmake-help-variable-history nil "Variable read history.") +(defvar cmake-properties '() "List of available topics for --help-property.") +(defvar cmake-help-property-history nil "Property read history.") +(defvar cmake-help-complete-history nil "Complete help read history.") +(defvar cmake-string-to-list-symbol + '(("command" cmake-commands cmake-help-command-history) + ("module" cmake-modules cmake-help-module-history) + ("variable" cmake-variables cmake-help-variable-history) + ("property" cmake-properties cmake-help-property-history) + )) + +(defun cmake-get-list (listname) + "If the value of LISTVAR is nil, run cmake --help-LISTNAME-list +and store the result as a list in LISTVAR." + (let ((listvar (car (cdr (assoc listname cmake-string-to-list-symbol))))) + (if (not (symbol-value listvar)) + (let ((temp-buffer-name "*CMake Temporary*")) + (save-window-excursion + (cmake-command-run-help (concat "--help-" listname "-list") nil temp-buffer-name) + (with-current-buffer temp-buffer-name + ; FIXME: Ignore first line if it is "cmake version ..." from CMake < 3.0. + (set listvar (split-string (buffer-substring-no-properties (point-min) (point-max)) "\n" t))))) + (symbol-value listvar) + )) + ) + +(require 'thingatpt) +(defun cmake-symbol-at-point () + (let ((symbol (symbol-at-point))) + (and (not (null symbol)) + (symbol-name symbol)))) + +(defun cmake-help-type (type) + (let* ((default-entry (cmake-symbol-at-point)) + (history (car (cdr (cdr (assoc type cmake-string-to-list-symbol))))) + (input (completing-read + (format "CMake %s: " type) ; prompt + (cmake-get-list type) ; completions + nil ; predicate + t ; require-match + default-entry ; initial-input + history + ))) + (if (string= input "") + (error "No argument given") + input)) + ) + +;;;###autoload +(defun cmake-help-command () + "Prints out the help message for the command the cursor is on." + (interactive) + (cmake-command-run-help "--help-command" (cmake-help-type "command") "*CMake Help*")) + +;;;###autoload +(defun cmake-help-module () + "Prints out the help message for the module the cursor is on." + (interactive) + (cmake-command-run-help "--help-module" (cmake-help-type "module") "*CMake Help*")) + +;;;###autoload +(defun cmake-help-variable () + "Prints out the help message for the variable the cursor is on." + (interactive) + (cmake-command-run-help "--help-variable" (cmake-help-type "variable") "*CMake Help*")) + +;;;###autoload +(defun cmake-help-property () + "Prints out the help message for the property the cursor is on." + (interactive) + (cmake-command-run-help "--help-property" (cmake-help-type "property") "*CMake Help*")) + +;;;###autoload +(defun cmake-help () + "Queries for any of the four available help topics and prints out the appropriate page." + (interactive) + (let* ((default-entry (cmake-symbol-at-point)) + (command-list (cmake-get-list "command")) + (variable-list (cmake-get-list "variable")) + (module-list (cmake-get-list "module")) + (property-list (cmake-get-list "property")) + (all-words (append command-list variable-list module-list property-list)) + (input (completing-read + "CMake command/module/variable/property: " ; prompt + all-words ; completions + nil ; predicate + t ; require-match + default-entry ; initial-input + 'cmake-help-complete-history + ))) + (if (string= input "") + (error "No argument given") + (if (member input command-list) + (cmake-command-run-help "--help-command" input "*CMake Help*") + (if (member input variable-list) + (cmake-command-run-help "--help-variable" input "*CMake Help*") + (if (member input module-list) + (cmake-command-run-help "--help-module" input "*CMake Help*") + (if (member input property-list) + (cmake-command-run-help "--help-property" input "*CMake Help*") + (error "Not a know help topic.") ; this really should not happen + )))))) + ) + +;;;###autoload +(progn + (add-to-list 'auto-mode-alist '("CMakeLists\\.txt\\'" . cmake-mode)) + (add-to-list 'auto-mode-alist '("\\.cmake\\'" . cmake-mode))) + +; This file provides cmake-mode. +(provide 'cmake-mode) + +;;; cmake-mode.el ends here diff --git a/site-lisp/extensions-local/company-ctags.el b/site-lisp/extensions-local/company-ctags.el new file mode 100644 index 0000000..2969402 --- /dev/null +++ b/site-lisp/extensions-local/company-ctags.el @@ -0,0 +1,528 @@ +;;; company-ctags.el --- Fastest company-mode completion backend for ctags -*- lexical-binding: t -*- + +;; Copyright (C) 2019,2020 Chen Bin + +;; Author: Chen Bin +;; URL: https://github.com/redguardtoo/company-ctags +;; Version: 0.0.7 +;; Keywords: convenience +;; Package-Requires: ((emacs "25.1") (company "0.9.0")) + +;; This file is NOT part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; This library completes code using tags file created by Ctags. +;; It uses a much faster algorithm optimized for ctags. +;; It takes only 9 seconds to load 300M tags file which is created by +;; scanning the Linux Kernel code v5.3.1. +;; After initial loading, this library will respond immediately +;; when new tags file is created. +;; +;; Usage: +;; +;; Step 0, Make sure `company-mode' is already set up +;; See http://company-mode.github.io/ for details. +;; +;; Step 1, insert below code into your configuration, +;; +;; (with-eval-after-load 'company +;; (company-ctags-auto-setup)) +;; +;; Step 2, Use Ctags to create tags file and enjoy. +;; +;; Tips: +;; +;; - Turn on `company-ctags-support-etags' to support tags +;; file created by etags. But it will increase initial loading time. +;; +;; - Set `company-ctags-extra-tags-files' to load extra tags files, +;; +;; (setq company-ctags-extra-tags-files '("$HOME/TAGS" "/usr/include/TAGS")) +;; +;; - Set `company-ctags-fuzzy-match-p' to fuzzy match the candidates. +;; The input could match any part of the candidate instead of the beginning of +;; the candidate. +;; +;; - Set `company-ctags-ignore-case' to ignore case when fetching candidates +;; +;; - Use rusty-tags to generate tags file for Rust programming language. +;; Add below code into ~/.emacs, +;; (setq company-ctags-tags-file-name "rusty-tags.emacs") +;; +;; - Make sure CLI program diff is executable on Windows. +;; It's optional but highly recommended. It can speed up tags file updating. +;; This package uses diff through variable `diff-command'. +;; +;; - `company-ctags-debug-info' for debugging. +;; + +;;; Code: + +(require 'find-file) +(require 'company nil t) +(require 'cl-lib) +(require 'subr-x) + +(defgroup company-ctags nil + "Completion backend for ctags." + :group 'company) + +(defcustom company-ctags-use-main-table-list t + "Always search `tags-table-list' if set. +If this is disabled, `company-ctags' will try to find the one table for each +buffer automatically." + :type '(choice (const :tag "off" nil) + (const :tag "on" t))) + +(defcustom company-ctags-ignore-case nil + "Non-nil to ignore case in completion candidates." + :type 'boolean + :package-version '(company . "0.7.3")) + +(defcustom company-ctags-extra-tags-files nil + "List of extra tags files which are loaded only once. + +A typical format is, + + (\"./TAGS\" \"/usr/include/TAGS\" \"$PROJECT/*/include/TAGS\") + +Environment variables can be inserted between slashes (`/'). +They will be replaced by their definitions. If a variable does +not exist, it is replaced (silently) with an empty string." + :type '(repeat 'string)) + +(defcustom company-ctags-quiet nil + "Be quiet and do not notify user tags file status." + :type 'boolean) + +(defcustom company-ctags-support-etags nil + "Support tags file created by etags. +If t, it increases the loading time." + :type 'boolean) + +(defcustom company-ctags-everywhere nil + "Non-nil to offer completions in comments and strings. +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")) + +(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." + :type 'string) + +(defcustom company-ctags-tag-name-valid-characters + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ$#@%_!*&1234567890" + "The characters of tag name. It's used for partition algorithm." + :type 'string) + +(defcustom company-ctags-fuzzy-match-p nil + "If t, fuzzy match the candidates. +The input could match any part of the candidate instead of the beginning of +the candidate." + :type 'boolean) + +(defvar company-ctags-modes + '(prog-mode + c-mode + objc-mode + c++-mode + java-mode + jde-mode + pascal-mode + perl-mode + python-mode + lua-mode + web-mode)) + +(defvar company-backends) ; avoid compiling warning + +(defvar-local company-ctags-buffer-table-internal nil) + +(defvar company-ctags-tags-file-caches nil + "The cached tags files.") + +(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)) + (list file)))) + +(defun company-ctags-buffer-table () + "Find buffer table." + (or (and company-ctags-use-main-table-list tags-table-list) + (or company-ctags-buffer-table-internal + (setq company-ctags-buffer-table-internal + (company-ctags-find-table))))) + +(defun company-ctags-char-in-string-p (character string) + "Test if CHARACTER is in STRING." + (let (rlt (i 0) (len (length string))) + (while (and (not rlt) (< i len)) + (setq rlt (eq (elt string i) character)) + (setq i (1+ i))) + rlt)) + +(defun company-ctags-tag-name-character-p (character) + "Test if CHARACTER is in `company-ctags-tag-name-valid-characters'." + (company-ctags-char-in-string-p character + company-ctags-tag-name-valid-characters)) + +(defmacro company-ctags-push-tagname (tagname tagname-dict) + "Push TAGNAME into TAGNAME-DICT." + `(let ((c (elt ,tagname 0))) + (when (company-ctags-tag-name-character-p c) + (push ,tagname (gethash c ,tagname-dict))))) + +(defun company-ctags-n-items (n tagnames) + "Return first N items of TAGNAMES." + (cond + ((<= (length tagnames) n) + tagnames) + (t + (let (rlt (i 0)) + (while (< i n) + (push (nth i tagnames) rlt) + (setq i (1+ i))) + (push " ..." rlt) + (nreverse rlt))))) + +;;;###autoload +(defun company-ctags-debug-info () + "Print all debug information." + (interactive) + (let* ((caches company-ctags-tags-file-caches) + (keys (hash-table-keys caches))) + (message "* cache contents") + (dolist (k keys) + (let* ((h (gethash k caches)) + (timestamp (plist-get h :timestamp)) + (filesize (plist-get h :filesize)) + (dict (plist-get h :tagname-dict)) + (dict-keys (hash-table-keys dict))) + (message "** key=%s timestamp=%s filesize=%s\n" k timestamp filesize) + (dolist (dk dict-keys) + (let* ((items (company-ctags-n-items 4 (gethash dk dict)))) + (when (> (length items) 0) + (message " %s: %s" (string dk) items)))))))) + +(defun company-ctags-init-tagname-dict () + "Initialize tagname dict." + (let* ((i 0) + (dict (make-hash-table)) + (len (length company-ctags-tag-name-valid-characters))) + (while (< i len) + (puthash (elt company-ctags-tag-name-valid-characters i) '() dict) + (setq i (1+ i))) + dict)) + +(defun company-ctags-parse-tags (text &optional dict) + "Extract tag names from TEXT. +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) + (case-fold-search company-ctags-ignore-case)) + (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 + ;; slow algorithm, need support both explicit and implicit tags name + (while (string-match company-ctags-slow-pattern text start) + (cond + ((match-beginning 2) + ;; There is an explicit tag name. + (company-ctags-push-tagname (substring text (match-beginning 2) (match-end 2)) + dict)) + (t + ;; No explicit tag name. Backtrack a little, + ;; and look for the implicit one. + (company-ctags-push-tagname (substring text (match-beginning 1) (match-end 1)) + dict))) + (setq start (+ 4 (match-end 0))))) + (t + ;; fast algorithm, support explicit tags name only + (while (string-match company-ctags-fast-pattern text start) + (company-ctags-push-tagname (substring text (match-beginning 1) (match-end 1)) + dict) + (setq start (+ 4 (match-end 0)))))) + + dict)) + +(defun company-ctags-all-completions (string collection) + "Search match to STRING in COLLECTION to see if it begins with STRING. +If `company-ctags-fuzzy-match-p' is t, check if the match contains STRING." + (let ((case-fold-search company-ctags-ignore-case)) + (cond + (company-ctags-fuzzy-match-p + (let* (rlt) + ;; code should be efficient in side the this loop + (dolist (c collection) + (if (string-match string c) (push c rlt))) + rlt)) + (t + (all-completions string collection))))) + +(defun company-ctags-fetch-by-first-char (c prefix tagname-dict) + "Fetch candidates by first character C of PREFIX from TAGNAME-DICT." + (let* ((rlt (company-ctags-all-completions prefix (gethash c tagname-dict)))) + (when company-ctags-ignore-case + (let (c2 (offset (- ?a ?A))) + (cond + ((company-ctags-char-in-string-p c "abcdefghijklmnopqrstuvwxyz") + (setq c2 (- c offset))) + + ((company-ctags-char-in-string-p c "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + (setq c2 (+ c offset)))) + + (when c2 + (setq rlt (nconc rlt (company-ctags-all-completions prefix (gethash c2 tagname-dict))))))) + rlt)) + +(defun company-ctags-all-candidates (prefix tagname-dict) + "Search for partial match to PREFIX in TAGNAME-DICT." + (cond + (company-ctags-fuzzy-match-p + (let* ((keys (hash-table-keys tagname-dict)) + rlt) + ;; search all hash tables + ;; don't care the first character of prefix + (dolist (c keys) + (setq rlt (nconc rlt (company-ctags-fetch-by-first-char c prefix tagname-dict)))) + rlt)) + (t + (company-ctags-fetch-by-first-char (elt prefix 0) prefix tagname-dict)))) + +(defun company-ctags-load-tags-file (file static-p &optional force no-diff-prog) + "Load tags from FILE. +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. +This function return t if any tag file is reloaded." + (let* (raw-content + (file-info (and company-ctags-tags-file-caches + (gethash file company-ctags-tags-file-caches))) + (use-diff (and (not no-diff-prog) + file-info + (plist-get file-info :raw-content) + (executable-find diff-command))) + tagname-dict + reloaded) + + (when (or force + (not file-info) + (and + ;; the tags file is static and is already read into cache + ;; so don't read it again + ;; (not (plist-get file-info :static-p)) + ;; time to expire cache from tags file + (> (- (float-time (current-time)) + (plist-get file-info :timestamp)) + company-ctags-check-tags-file-interval) + ;; When generating new tags file, file size could be + ;; temporarily smaller than cached file size. + ;; Don't reload tags file until new tags file is bigger. + (> (nth 7 (file-attributes file)) + (plist-get file-info :filesize)))) + + ;; Read file content + (setq reloaded t) + (cond + (use-diff + ;; actually don't change raw-content attached to file-info + (setq raw-content (plist-get file-info :raw-content)) + + ;; use diff to find the new tags + (let (diff-output) + (with-temp-buffer + (insert (plist-get file-info :raw-content)) + ;; when process finished, replace temp buffer with program output + (call-process-region (point-min) (point-max) diff-command t t nil "-ab" file "-") + (setq diff-output (buffer-string))) + + ;; compare old and new tags file, extract tag names from diff output which + ;; should be merged with old tag names + (setq tagname-dict + (company-ctags-parse-tags diff-output + (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))) + ;; collect all tag names + (setq tagname-dict (company-ctags-parse-tags raw-content)) + (unless company-ctags-quiet (message "%s is loaded." file)))) + + ;; initialize hash table if needed + (unless company-ctags-tags-file-caches + (set 'company-ctags-tags-file-caches (make-hash-table :test #'equal))) + + ;; finalize tags file info + (puthash file + ;; if the tags file is read only once, it will never be updated + ;; by `diff-command', so don't need store original raw content + ;; of tags file in order to save memory. + (list :raw-content (unless static-p raw-content) + :tagname-dict tagname-dict + :static-p static-p + :timestamp (float-time (current-time)) + :filesize (nth 7 (file-attributes file))) + company-ctags-tags-file-caches)) + reloaded)) + +(defun company-ctags--test-cached-candidates (prefix) + "Test PREFIX in `company-ctags-cached-candidates'." + (let* ((cands company-ctags-cached-candidates) + (key (plist-get cands :key)) + (keylen (length key)) + (case-fold-search company-ctags-ignore-case)) + ;; prefix is "hello" and cache's prefix "ell" + (and (>= (length prefix) keylen) + (if company-ctags-fuzzy-match-p (string-match key prefix) + ;; key is the beginning of prefix + (string= (substring prefix 0 keylen) key))))) + +(defun company-ctags--candidates (prefix) + "Get candidate with 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) + (all-tags-files (mapcar (lambda (f) + (file-truename f)) + (delete-dups (append (if file (list file)) + (company-ctags-buffer-table))))) + (extra-tags-files (ff-list-replace-env-vars company-ctags-extra-tags-files)) + rlt) + + ;; load tags files, maybe + (dolist (f all-tags-files) + (when (and f (file-exists-p f)) + (when (company-ctags-load-tags-file f + nil ; primary tags file, not static + nil + nil) + ;; invalidate cached candidates if any tags file is reloaded + (setq company-ctags-cached-candidates nil)))) + + (when extra-tags-files + (dolist (f extra-tags-files) + (when (and f (file-exists-p f)) + ;; tags file in `company-ctags-extra-tags-files' is read only once. + (company-ctags-load-tags-file f + t ; static tags file, read only once + nil + nil)))) + + (cond + ;; re-use cached candidates + ((and (not company-ctags-fuzzy-match-p) + company-ctags-cached-candidates + (company-ctags--test-cached-candidates prefix)) + + (let* ((cands (plist-get company-ctags-cached-candidates :cands))) + (setq rlt (company-ctags-all-completions prefix cands)))) + + ;; search candidates through tags files + (t + (dolist (f (nconc all-tags-files extra-tags-files)) + (let* ((cache (gethash f company-ctags-tags-file-caches)) + (tagname-dict (plist-get cache :tagname-dict))) + (when tagname-dict + (setq rlt (append rlt (company-ctags-all-candidates prefix tagname-dict)))))) + + ;; fuzzy algorithm don't use caching algorithm + (unless company-ctags-fuzzy-match-p + (setq company-ctags-cached-candidates + ;; clone the rlt into cache + (list :key prefix :cands (mapcar 'identity rlt)))))) + + ;; cleanup + (if rlt (delete-dups rlt))))) + +;;;###autoload +(defun company-ctags (command &optional arg &rest ignored) + "Completion backend of for ctags. Execute COMMAND with ARG and IGNORED." + (interactive (list 'interactive)) + (cl-case command + (interactive (company-begin-backend 'company-ctags)) + (prefix (and (apply #'derived-mode-p company-ctags-modes) + (or (eq t company-ctags-everywhere) + (apply #'derived-mode-p company-ctags-everywhere) + (not (company-in-string-or-comment))) + (company-ctags-buffer-table) + (or (company-grab-symbol) 'stop))) + (candidates (company-ctags--candidates arg)) + (location (let ((tags-table-list (company-ctags-buffer-table))) + (when (fboundp 'find-tag-noselect) + (save-excursion + (let ((buffer (find-tag-noselect arg))) + (cons buffer (with-current-buffer buffer (point)))))))) + (ignore-case company-ctags-ignore-case))) + +;;;###autoload +(defun company-ctags-replace-backend (backends) + "Replace `company-etags' with `company-ctags' in BACKENDS." + (let* (rlt) + (dolist (b backends) + (cond + ((eq b 'company-etags) + (push 'company-ctags rlt)) + ((listp b) + (let* (children) + (dolist (c b) + (cond + ((eq c 'company-etags) + (push 'company-ctags children)) + (t + (push c children)))) + (push (nreverse children) rlt))) + (t + (push b rlt)))) + (nreverse rlt))) + +;;;###autoload +(defun company-ctags-auto-setup () + "Set up `company-backends'." + (setq company-backends + (company-ctags-replace-backend company-backends))) + +(provide 'company-ctags) +;;; company-ctags.el ends here diff --git a/site-lisp/extensions-local/dired-display-buffer.el b/site-lisp/extensions-local/dired-display-buffer.el new file mode 100644 index 0000000..4794543 --- /dev/null +++ b/site-lisp/extensions-local/dired-display-buffer.el @@ -0,0 +1,87 @@ +;; -*- 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 new file mode 100644 index 0000000..d283312 --- /dev/null +++ b/site-lisp/extensions-local/dired-hacks-utils.el @@ -0,0 +1,273 @@ +;;; 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 new file mode 100644 index 0000000..1c3eda2 --- /dev/null +++ b/site-lisp/extensions-local/dired-narrow.el @@ -0,0 +1,356 @@ +;;; 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 new file mode 100644 index 0000000..87f0a69 --- /dev/null +++ b/site-lisp/extensions-local/dired-subtree.el @@ -0,0 +1,784 @@ +;;; 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/echo-keys.el b/site-lisp/extensions-local/echo-keys.el new file mode 100644 index 0000000..5b2cb5f --- /dev/null +++ b/site-lisp/extensions-local/echo-keys.el @@ -0,0 +1,126 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'cl-lib) + +;;; Code: +(defcustom echo-keys-last-record nil + "Last command processed by 'echo-keys'." + :type 'string + :group 'echo-keys) + +(defcustom echo-keys-last-record-count 0 + "Number of times the `echo-keys-last-record` command was repeated." + :type 'integer + :group 'echo-keys) + +(defcustom echo-key-window-width 40 + "Default width of the *echo-keys* window." + :type 'integer + :group 'echo-keys) + +(defcustom echo-key-password-protection nil + "Temporarily disable echo key for password input." + :type 'boolean + :group 'echo-keys) + +(defcustom echo-key-coallesce-repeats t + "If 't', show [ times]. + If 'nil', show n lines." + :type 'boolean + :group 'echo-keys) + +(defun echo-keys () + (let ((deactivate-mark deactivate-mark) + (keys (this-command-keys))) + (when (and keys + (not (eq (current-buffer) (get-buffer "*echo-keys*"))) + (not echo-key-password-protection)) + (save-excursion + (with-current-buffer (get-buffer-create "*echo-keys*") + (goto-char (point-max)) + (if (eql this-command 'self-insert-command) + (let ((desc (key-description keys))) + (if (= 1 (length desc)) + (insert desc) + (insert " " desc " ")) + (setf echo-keys-last-record this-command + echo-keys-last-record-count 1)) + (if (and echo-key-coallesce-repeats + (eql echo-keys-last-record this-command)) + (progn + (incf echo-keys-last-record-count) + ;; update the last line + (forward-line -1) + (if (= 2 echo-keys-last-record-count) + (progn + (end-of-line) + (insert (format " [%d times]" echo-keys-last-record-count))) + (save-match-data + (when (re-search-forward " \\[\\([0-9]+\\) times\\]" nil t) + (delete-region (match-beginning 1) (match-end 1)) + (goto-char (match-beginning 1)) + (insert (format "%d" echo-keys-last-record-count))))) + (forward-line 1)) + (progn + (insert (if (eq 'self-insert-command echo-keys-last-record) + "\n" + "") + (format "%-12s %s\n" + (key-description keys) + this-command)) + (setf echo-keys-last-record this-command + echo-keys-last-record-count 1)))) + (dolist (window (window-list)) + (when (eq (window-buffer window) (current-buffer)) + (with-selected-window window + ;; We need to use both to get the effect. + (set-window-point window (point)) + (end-of-buffer))))))))) + +(defun toggle-echo-keys () + "Toggle displaying the *echo-key* buffer." + (interactive) + (if (member 'echo-keys (default-value 'pre-command-hook)) + (let ((echo-buffer (get-buffer "*echo-keys*"))) + (remove-hook 'pre-command-hook 'echo-keys) + (dolist (window (window-list)) + (when (eq (window-buffer window) echo-buffer) + (delete-window window)))) + (progn + (delete-other-windows) + (split-window nil (- (window-width) echo-key-window-width) t) + (other-window 1) + (switch-to-buffer (get-buffer-create "*echo-keys*")) + (unless (eq major-mode 'echo-keys-mode) + (echo-keys-mode)) + (toggle-truncate-lines +1) + (set-window-dedicated-p (selected-window) t) + (other-window 1) + (add-hook 'pre-command-hook 'echo-keys)))) + +(defadvice echo-key--read-passwd--disable (before read-passwd) + (message "echo-key--read-passwd--disable") + (setf echo-key-password-protection t)) + +(defadvice echo-key--read-passwd--enable (after read-passwd) + (message "echo-key--read-passwd--enable") + (setf echo-key-password-protection nil)) + +(defun echo-keys-clean () + "Erase the `*echo-keys*' buffer." + (interactive) + (with-current-buffer "*echo-keys*" + (erase-buffer))) + +(defvar echo-keys-mode-map + (let ((ek-mode-map (make-sparse-keymap))) + (define-key ek-mode-map (kbd "C-c e e") #'toggle-echo-keys) + (define-key ek-mode-map (kbd "C-c e c") #'echo-keys-clean) + ek-mode-map)) + +(define-derived-mode echo-keys-mode fundamental-mode "Echo-keys" + "Major mode for echo-keys.") + +(provide 'echo-keys) + +;;; echo-keys.el ends here. diff --git a/site-lisp/extensions-local/evals.el b/site-lisp/extensions-local/evals.el new file mode 100644 index 0000000..f4c8ce8 --- /dev/null +++ b/site-lisp/extensions-local/evals.el @@ -0,0 +1,21 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defun ld-eval-elisp-to-next-line () + "Replace the preceding sexp with its value." + (interactive) + (let ((value (eval (elisp--preceding-sexp)))) + (newline-and-indent) + (insert (format "%S" value)))) + +(defun ld-eval-elisp-and-replace () + "Replace the preceding sexp with its value." + (interactive) + (let ((value (eval (elisp--preceding-sexp)))) + (backward-kill-sexp) + (insert (format "%S" value)))) + +(provide 'evals) + +;;; evals.el ends here diff --git a/site-lisp/extensions-local/force-indent.el b/site-lisp/extensions-local/force-indent.el new file mode 100644 index 0000000..08461c2 --- /dev/null +++ b/site-lisp/extensions-local/force-indent.el @@ -0,0 +1,81 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: + +;; use variable 'tab-width' value as indent size + +(defun force-indent-line () + (let (col) + (save-excursion + (back-to-indentation) + (setq col (+ (current-column) tab-width)) + (indent-line-to col)) + (when (< (current-column) col) + (back-to-indentation)))) + +(defun indent-line () + (interactive) + (let ((bt (save-excursion + (back-to-indentation) + (current-column)))) + (cond + ((< (current-column) bt) + (back-to-indentation)) + ((looking-at "\\s-*\n") + (let ((col (save-excursion + (forward-line -1) + (back-to-indentation) + (current-column)))) + (if (< (current-column) col) + (indent-line-to col) + (force-indent-line)))) + (t + (force-indent-line))))) + +(defun un-indent-line () + (interactive) + (let (col) + (save-excursion + (back-to-indentation) + (setq col (- (current-column) tab-width)) + (when (>= col 0) + (indent-line-to col))))) + +(defun indent-region (start stop) + (interactive "r") + (setq stop (copy-marker stop)) + (goto-char start) + (while (< (point) stop) + (unless (and (bolp) (eolp)) + (force-indent-line)) + (forward-line 1))) + +(defun un-indent-region (start stop) + (interactive "r") + (setq stop (copy-marker stop)) + (goto-char start) + (while (< (point) stop) + (unless (and (bolp) (eolp)) + (un-indent-line)) + (forward-line 1))) + +(defun ld-indent () + (interactive) + (if (use-region-p) + (save-excursion + (indent-region (region-beginning) (region-end)) + (setq deactivate-mark nil)) + (indent-line))) + +(defun ld-un-indent () + (interactive) + (if (use-region-p) + (save-excursion + (un-indent-region (region-beginning) (region-end)) + (setq deactivate-mark nil)) + (un-indent-line))) + +(provide 'force-indent) + +;;; force-indent.el ends here \ No newline at end of file diff --git a/site-lisp/extensions-local/frame-restore.el b/site-lisp/extensions-local/frame-restore.el new file mode 100644 index 0000000..df69ddc --- /dev/null +++ b/site-lisp/extensions-local/frame-restore.el @@ -0,0 +1,93 @@ +;;; frame-restore.el --- save/restore frame size&position at shutdown/startup + +;; Copyright (C) 2002 by Free Software Foundation, Inc. + +;; Author: Patrick Anderson +;; Version: 1.3 + +;; 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 2, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; ChangeLog +;; 1.3: simplified install (now just copy one line to .emacs, and eval the next) +;; 1.3: added checks for running in terminal +;; 1.3: added checks for running on non-w32 +;; 1.2: added font save/restore +;; 1.1: added more descriptive, correct installation docs + +;;;installation: +;;1. put this file in your load path and add to your .emacs file (as the last thing) (without the semicolon): +;;(require 'frame-restore) +;;2. now evaluate the next line (don't uncomment it) [by putting the cursor at the end and pressing C-xC-e] +;;(progn (require 'desktop) (customize-set-variable 'desktop-enable t) (desktop-save "~/") (require 'frame-restore)) +;;3. now change your font using S-down-mouse-1, adjust your frame size, then shutdown/restart emacs to test. +;;once installed, i never have problems, but before that, it seems possible to get into strange states. if that happens try: +;;1. shutdown emacs +;;2. delete .emacs.desktop +;;3. restart +;;4. follow normal install +;;since the font is stored here, don't also store it through a customization of the 'default' face. you may customize that face, just make sure the "Font Family" attribute box is unchecked. + +;;;Code: +(require 'cl-lib) + + ;this must be global - as that is how desktop-globals-to-save works + ;(defvar final-frame-params '((frame-parameter (selected-frame) 'font) 50 50 150 50 nil)) ;font, left, top, width, height, maximized +(defvar final-frame-params '("-adobe-courier-medium-r-normal--*-120-*-*-m-*-iso8859-1" 50 50 150 50 nil)) ;font, left, top, width, height, maximized + +(if window-system + (add-hook 'after-init-hook + '(lambda() + "this is executed as emacs is coming up - _after_ final-frame-params have been read from `.emacs.desktop'." + (when desktop-enable + (desktop-load-default) + (desktop-read) + ;;now size and position frame according to the values read from disk + (set-default-font (first final-frame-params)) ;do font first - as it will goof with the frame size + (set-frame-size (selected-frame) (fourth final-frame-params) (fifth final-frame-params)) + (set-frame-position (selected-frame) (max (eval (second final-frame-params)) 0) (max (eval (third final-frame-params)) 0)) + (if (sixth final-frame-params) + (if (eq window-system 'w32) + (w32-send-sys-command ?\xf030) + ;else, do X something + )))))) + +(if window-system + (add-hook 'desktop-save-hook + '(lambda() + (let ((maximized (listp (frame-parameter (selected-frame) 'left)))) + "this hook sets the fram size/pos vars before `desktop.el' writes them out to disk" + (if (eq window-system 'w32) + (w32-send-sys-command ?\xf120) ;restore the frame (so we can save the 'restored' size/pos) + ;else, do X something + ) + ;;prepend our vars to the save list so `desktop.el' will save them out to disk + (setq desktop-globals-to-save (cons 'final-frame-params + desktop-globals-to-save)) + + (setq final-frame-params + (list + (frame-parameter (selected-frame) 'font) + (frame-parameter (selected-frame) 'left) ;x + (frame-parameter (selected-frame) 'top) ;y + (frame-width) ;width + (frame-height) ;height + maximized))))) ;if this frame param is a list, we're probably maximized (not guaranteed) + ) + +(provide 'frame-restore) +;;; frame-restore.el ends here diff --git a/site-lisp/extensions-local/goto-last-change.el b/site-lisp/extensions-local/goto-last-change.el new file mode 100644 index 0000000..524219f --- /dev/null +++ b/site-lisp/extensions-local/goto-last-change.el @@ -0,0 +1,141 @@ +;;; 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 new file mode 100644 index 0000000..16d5575 --- /dev/null +++ b/site-lisp/extensions-local/goto-line-preview.el @@ -0,0 +1,124 @@ +;;; goto-line-preview.el --- Preview line when executing `goto-line` command -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2023 Shen, Jen-Chieh +;; Created date 2019-03-01 14:53:00 + +;; Author: Shen, Jen-Chieh +;; URL: https://github.com/emacs-vs/goto-line-preview +;; Version: 0.1.1 +;; Package-Requires: ((emacs "25")) +;; Keywords: convenience line navigation + +;; 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: +;; +;; Preview line when executing `goto-line` command. +;; + +;;; Code: + +(defgroup goto-line-preview nil + "Preview line when executing `goto-line` command." + :prefix "goto-line-preview-" + :group 'convenience + :group 'tools + :link '(url-link :tag "Repository" "https://github.com/emacs-vs/goto-line-preview")) + +(defcustom goto-line-preview-before-hook nil + "Hooks run before `goto-line-preview' is run." + :group 'goto-line-preview + :type 'hook) + +(defcustom goto-line-preview-after-hook nil + "Hooks run after `goto-line-preview' is run." + :group 'goto-line-preview + :type 'hook) + +(defvar goto-line-preview--prev-window nil + "Record down the previous window before we do preivew display.") + +(defvar goto-line-preview--prev-line-num nil + "Record down the previous line number before we do preivew display.") + +(defvar goto-line-preview--relative-p nil + "Flag to see if this command relative.") + +(defun goto-line-preview--do (line-num) + "Do goto LINE-NUM." + (save-selected-window + (select-window goto-line-preview--prev-window) + (goto-char (point-min)) + (forward-line (1- line-num)))) + +(defun goto-line-preview--do-preview () + "Do the goto line preview action." + (save-selected-window + (when goto-line-preview--prev-window + (let ((line-num-str (thing-at-point 'line))) + (select-window goto-line-preview--prev-window) + (if line-num-str + (let ((line-num (string-to-number line-num-str))) + (when goto-line-preview--relative-p + (setq line-num (+ goto-line-preview--prev-line-num line-num))) + (unless (zerop line-num) (goto-line-preview--do line-num))) + (goto-line-preview--do goto-line-preview--prev-line-num)))))) + +;;;###autoload +(defun goto-line-preview () + "Preview goto line." + (interactive) + (let ((goto-line-preview--prev-window (selected-window)) + (window-point (window-point)) + (goto-line-preview--prev-line-num (line-number-at-pos)) + jumped) + (run-hooks 'goto-line-preview-before-hook) + (unwind-protect + (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) ") + goto-line-preview--prev-line-num + (max 0 (min 1 lines)) + lines)))) + (if jumped + (with-current-buffer (window-buffer goto-line-preview--prev-window) + (unless (region-active-p) (push-mark window-point))) + (set-window-point goto-line-preview--prev-window window-point)) + (run-hooks 'goto-line-preview-after-hook)))) + +;;;###autoload +(defun goto-line-preview-relative () + "Preview goto line relative." + (interactive) + (let ((goto-line-preview--relative-p t)) + (goto-line-preview))) + +;;;###autoload +(define-obsolete-function-alias 'goto-line-preview-goto-line 'goto-line-preview "0.1.1") + +(defun goto-line-preview--minibuffer-setup () + "Locally set up preview hooks for this minibuffer command." + (when (memq this-command '(goto-line-preview + goto-line-preview-goto-line + goto-line-preview-relative)) + (add-hook 'post-command-hook #'goto-line-preview--do-preview nil t))) + +(add-hook 'minibuffer-setup-hook 'goto-line-preview--minibuffer-setup) + +(provide 'goto-line-preview) +;;; goto-line-preview.el ends here diff --git a/site-lisp/extensions-local/highlight-indentation.el b/site-lisp/extensions-local/highlight-indentation.el new file mode 100644 index 0000000..bfe93b6 --- /dev/null +++ b/site-lisp/extensions-local/highlight-indentation.el @@ -0,0 +1,312 @@ +;;; highlight-indentation.el --- Minor modes for highlighting indentation +;; Author: Anton Johansson - http://antonj.se +;; Created: Dec 15 23:42:04 2010 +;; Version: 0.7.0 +;; URL: https://github.com/antonj/Highlight-Indentation-for-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 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. +;; +;;; Commentary: +;; Customize `highlight-indentation-face', and +;; `highlight-indentation-current-column-face' to suit your theme. + +;;; Code: + +(defgroup highlight-indentation nil + "Highlight Indentation" + :prefix "highlight-indentation-" + :group 'basic-faces) + +(defface highlight-indentation-face + ;; Fringe has non intrusive color in most color-themes + '((t :inherit fringe)) + "Basic face for highlighting indentation guides." + :group 'highlight-indentation) + +(defcustom highlight-indentation-offset + (if (and (boundp 'standard-indent) standard-indent) standard-indent 2) + "Default indentation offset, used if no other can be found from + major mode. This value is always used by + `highlight-indentation-mode' if set buffer local. Set buffer + local with `highlight-indentation-set-offset'" + :type 'integer + :group 'highlight-indentation) + +(defcustom highlight-indentation-blank-lines nil + "Show indentation guides on blank lines. Experimental. +Known issues: +- Doesn't work well with completion popups that use overlays +- Overlays on blank lines sometimes aren't cleaned up or updated perfectly + Can be refreshed by scrolling +- Not yet implemented for highlight-indentation-current-column-mode +- May not work perfectly near the bottom of the screen +- Point appears after indent guides on blank lines" + :type 'boolean + :group 'highlight-indentation) + +(defvar highlight-indentation-overlay-priority 1) +(defvar highlight-indentation-current-column-overlay-priority 2) + +(defconst highlight-indentation-hooks + '((after-change-functions (lambda (start end length) + (highlight-indentation-redraw-region + start end + 'highlight-indentation-overlay + 'highlight-indentation-put-overlays-region)) + t t) + (window-scroll-functions (lambda (win start) + (highlight-indentation-redraw-window + win + 'highlight-indentation-overlay + 'highlight-indentation-put-overlays-region + start)) + nil t))) + +(defun highlight-indentation-get-buffer-windows (&optional all-frames) + "Return a list of windows displaying the current buffer." + (get-buffer-window-list (current-buffer) 'no-minibuf all-frames)) + +(defun highlight-indentation-delete-overlays-buffer (overlay) + "Delete all overlays in the current buffer." + (save-restriction + (widen) + (highlight-indentation-delete-overlays-region (point-min) (point-max) overlay))) + +(defun highlight-indentation-delete-overlays-region (start end overlay) + "Delete overlays between START and END." + (mapc #'(lambda (o) + (if (overlay-get o overlay) (delete-overlay o))) + (overlays-in start end))) + +(defun highlight-indentation-redraw-window (win overlay func &optional start) + "Redraw win starting from START." + (highlight-indentation-redraw-region (or start (window-start win)) (window-end win t) overlay func)) + +(defun highlight-indentation-redraw-region (start end overlay func) + "Erase and read overlays between START and END." + (save-match-data + (save-excursion + (let ((inhibit-point-motion-hooks t) + (start (save-excursion (goto-char start) (beginning-of-line) (point))) + + (end (save-excursion (goto-char end) (line-beginning-position 2)))) + (highlight-indentation-delete-overlays-region start end overlay) + (funcall func start end overlay))))) + +(defun highlight-indentation-redraw-all-windows (overlay func &optional all-frames) + "Redraw the all windows showing the current buffer." + (dolist (win (highlight-indentation-get-buffer-windows all-frames)) + (highlight-indentation-redraw-window win overlay func))) + +(defun highlight-indentation-put-overlays-region (start end overlay) + "Place overlays between START and END." + (goto-char end) + (let (o ;; overlay + (last-indent 0) + (last-char 0) + (pos (point)) + (loop t)) + (while (and loop + (>= pos start)) + (save-excursion + (beginning-of-line) + (let ((c 0) + (cur-column (current-column))) + (while (and (setq c (char-after)) + (integerp c) + (not (= 10 c)) ;; newline + (= 32 c)) ;; space + (when (= 0 (% cur-column highlight-indentation-offset)) + (let ((p (point))) + (setq o (make-overlay p (+ p 1)))) + (overlay-put o overlay t) + (overlay-put o 'priority highlight-indentation-overlay-priority) + (overlay-put o 'face 'highlight-indentation-face)) + (forward-char) + (setq cur-column (current-column))) + (when (and highlight-indentation-blank-lines + (integerp c) + (or (= 10 c) + (= 13 c))) + (when (< cur-column last-indent) + (let ((column cur-column) + (s nil) + (show t) + num-spaces) + (while (< column last-indent) + (if (>= 0 + (setq num-spaces + (% + (- last-indent column) + highlight-indentation-offset))) + (progn + (setq num-spaces (1- highlight-indentation-offset)) + (setq show t)) + (setq show nil)) + (setq s (cons (concat + (if show + (propertize " " + 'face + 'highlight-indentation-face) + "") + (make-string num-spaces 32)) + s)) + (setq column (+ column num-spaces (if show 1 0)))) + (setq s (apply 'concat (reverse s))) + (let ((p (point))) + (setq o (make-overlay p p))) + (overlay-put o overlay t) + (overlay-put o 'priority highlight-indentation-overlay-priority) + (overlay-put o 'after-string s)) + (setq cur-column last-indent))) + (setq last-indent (* highlight-indentation-offset + (ceiling (/ (float cur-column) + highlight-indentation-offset)))))) + (when (= pos start) + (setq loop nil)) + (forward-line -1) ;; previous line + (setq pos (point))))) + +(defun highlight-indentation-guess-offset () + "Get indentation offset of current buffer." + (cond ((and (eq major-mode 'python-mode) (boundp 'python-indent)) + python-indent) + ((and (eq major-mode 'python-mode) (boundp 'py-indent-offset)) + py-indent-offset) + ((and (eq major-mode 'python-mode) (boundp 'python-indent-offset)) + python-indent-offset) + ((and (eq major-mode 'ruby-mode) (boundp 'ruby-indent-level)) + ruby-indent-level) + ((and (eq major-mode 'scala-mode) (boundp 'scala-indent:step)) + scala-indent:step) + ((and (eq major-mode 'scala-mode) (boundp 'scala-mode-indent:step)) + scala-mode-indent:step) + ((and (or (eq major-mode 'scss-mode) (eq major-mode 'css-mode)) (boundp 'css-indent-offset)) + css-indent-offset) + ((and (eq major-mode 'nxml-mode) (boundp 'nxml-child-indent)) + nxml-child-indent) + ((and (eq major-mode 'coffee-mode) (boundp 'coffee-tab-width)) + coffee-tab-width) + ((and (eq major-mode 'js-mode) (boundp 'js-indent-level)) + js-indent-level) + ((and (eq major-mode 'js2-mode) (boundp 'js2-basic-offset)) + js2-basic-offset) + ((and (fboundp 'derived-mode-class) (eq (derived-mode-class major-mode) 'sws-mode) (boundp 'sws-tab-width)) + sws-tab-width) + ((and (eq major-mode 'web-mode) (boundp 'web-mode-markup-indent-offset)) + web-mode-markup-indent-offset) ; other similar vars: web-mode-{css-indent,scripts}-offset + ((and (eq major-mode 'web-mode) (boundp 'web-mode-html-offset)) ; old var + web-mode-html-offset) + ((and (local-variable-p 'c-basic-offset) (boundp 'c-basic-offset)) + c-basic-offset) + ((and (eq major-mode 'yaml-mode) (boundp 'yaml-indent-offset)) + yaml-indent-offset) + ((and (eq major-mode 'elixir-mode) (boundp 'elixir-smie-indent-basic)) + elixir-smie-indent-basic) + (t + (default-value 'highlight-indentation-offset)))) + +;;;###autoload +(define-minor-mode highlight-indentation-mode + "Highlight indentation minor mode highlights indentation based on spaces" + :lighter " ||" + (when (not highlight-indentation-mode) ;; OFF + (highlight-indentation-delete-overlays-buffer 'highlight-indentation-overlay) + (dolist (hook highlight-indentation-hooks) + (remove-hook (car hook) (nth 1 hook) (nth 3 hook)))) + + (when highlight-indentation-mode ;; ON + (when (not (local-variable-p 'highlight-indentation-offset)) + (set (make-local-variable 'highlight-indentation-offset) + (highlight-indentation-guess-offset))) + + ;; Setup hooks + (dolist (hook highlight-indentation-hooks) + (apply 'add-hook hook)) + (highlight-indentation-redraw-all-windows 'highlight-indentation-overlay + 'highlight-indentation-put-overlays-region))) + +;;;###autoload +(defun highlight-indentation-set-offset (offset) + "Set indentation offset locally in buffer, will prevent +highlight-indentation from trying to guess indentation offset +from major mode" + (interactive + (if (and current-prefix-arg (not (consp current-prefix-arg))) + (list (prefix-numeric-value current-prefix-arg)) + (list (read-number "Indentation offset: ")))) + (set (make-local-variable 'highlight-indentation-offset) offset) + (when highlight-indentation-mode + (highlight-indentation-mode))) + +;;; This minor mode will highlight the indentation of the current line +;;; as a vertical bar (grey background color) aligned with the column of the +;;; first character of the current line. +(defface highlight-indentation-current-column-face + ;; Fringe has non intrusive color in most color-themes + '((t (:background "black"))) + "Basic face for highlighting indentation guides." + :group 'highlight-indentation) + +(defconst highlight-indentation-current-column-hooks + '((post-command-hook (lambda () + (highlight-indentation-redraw-all-windows 'highlight-indentation-current-column-overlay + 'highlight-indentation-current-column-put-overlays-region)) nil t))) + +(defun highlight-indentation-current-column-put-overlays-region (start end overlay) + "Place overlays between START and END." + (let (o ;; overlay + (last-indent 0) + (indent (save-excursion (back-to-indentation) (current-column))) + (pos start)) + (goto-char start) + ;; (message "doing it %d" indent) + (while (< pos end) + (beginning-of-line) + (while (and (integerp (char-after)) + (not (= 10 (char-after))) ;; newline + (= 32 (char-after))) ;; space + (when (= (current-column) indent) + (setq pos (point) + last-indent pos + o (make-overlay pos (+ pos 1))) + (overlay-put o overlay t) + (overlay-put o 'priority highlight-indentation-current-column-overlay-priority) + (overlay-put o 'face 'highlight-indentation-current-column-face)) + (forward-char)) + (forward-line) ;; Next line + (setq pos (point))))) + +;;;###autoload +(define-minor-mode highlight-indentation-current-column-mode + "Highlight Indentation minor mode displays a vertical bar +corresponding to the indentation of the current line" + :lighter " |" + + (when (not highlight-indentation-current-column-mode) ;; OFF + (highlight-indentation-delete-overlays-buffer 'highlight-indentation-current-column-overlay) + (dolist (hook highlight-indentation-current-column-hooks) + (remove-hook (car hook) (nth 1 hook) (nth 3 hook)))) + + (when highlight-indentation-current-column-mode ;; ON + (when (not (local-variable-p 'highlight-indentation-offset)) + (set (make-local-variable 'highlight-indentation-offset) + (highlight-indentation-guess-offset))) + + ;; Setup hooks + (dolist (hook highlight-indentation-current-column-hooks) + (apply 'add-hook hook)) + (highlight-indentation-redraw-all-windows 'highlight-indentation-current-column-overlay + 'highlight-indentation-current-column-put-overlays-region))) + +(provide 'highlight-indentation) + +;;; highlight-indentation.el ends here diff --git a/site-lisp/extensions-local/highlight-parentheses.el b/site-lisp/extensions-local/highlight-parentheses.el new file mode 100644 index 0000000..ba30756 --- /dev/null +++ b/site-lisp/extensions-local/highlight-parentheses.el @@ -0,0 +1,157 @@ +;;; highlight-parentheses.el --- highlight surrounding parentheses +;; +;; Copyright (C) 2007 Nikolaj Schumacher +;; +;; Author: Nikolaj Schumacher +;; Version: 1.0 +;; Keywords: faces, matching +;; URL: http://nschum.de/src/emacs/highlight-parentheses/ +;; Compatibility: GNU Emacs 22.x +;; +;; 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 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: +;; +;; Add the following to your .emacs file: +;; (require 'highlight-parentheses) +;; +;; Enable `highlight-symbol-mode'. +;; +;;; Changes Log: +;; +;; 2007-07-30 (1.0) +;; Added background highlighting and faces. +;; +;; 2007-05-15 (0.9.1) +;; Support for defcustom. Changed from vector to list. +;; +;; 2007-04-26 (0.9) +;; Initial Release. +;; +;;; Code: + +(eval-when-compile (require 'cl)) + +(defgroup highlight-parentheses nil + "Highlight surrounding parentheses" + :group 'faces + :group 'matching) + +(defvar hl-paren-overlays nil + "This buffers currently active overlays.") +(make-variable-buffer-local 'hl-paren-overlays) + +(defcustom hl-paren-colors + '("firebrick1" "IndianRed4" "IndianRed") + "*List of colors for the highlighted parentheses. +The list starts with the the inside parentheses and moves outwards." + :type '(repeat color) + :group 'highlight-parentheses) + +(defcustom hl-paren-background-colors nil + "*List of colors for the background highlighted parentheses. +The list starts with the the inside parentheses and moves outwards." + :type '(repeat color) + :group 'highlight-parentheses) + +(defface hl-paren-face nil + "*Face used for highlighting parentheses. +Color attributes might be overriden by `hl-paren-colors' and +`hl-paren-background-colors'." + :group 'highlight-parentheses) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar hl-paren-last-point 0 + "The last point for which parentheses were highlighted. +This is used to prevent analyzing the same context over and over.") +(make-variable-buffer-local 'hl-paren-last-point) + +(defun hl-paren-highlight () + "Highlight the parentheses around point." + (unless (= (point) hl-paren-last-point) + (save-excursion + (let ((pos (point)) + (match-pos (point)) + (level -1) + (max (1- (length hl-paren-overlays)))) + (while (and match-pos (< level max)) + (setq match-pos + (when (setq pos (cadr (syntax-ppss pos))) + (ignore-errors (scan-sexps pos 1)))) + (when match-pos + (hl-paren-put-overlay (cl-incf level) pos 'hl-paren-face) + (hl-paren-put-overlay (cl-incf level) (1- match-pos) 'hl-paren-face))) + (while (< level max) + (hl-paren-put-overlay (cl-incf level) nil nil)))) + (setq hl-paren-last-point (point)))) + +(defun hl-paren-put-overlay (n pos face) + "Move or create the N'th overlay so its shown at POS." + (let ((ov (elt hl-paren-overlays n)) end) + (if (null pos) + (when ov + (delete-overlay ov) + (aset hl-paren-overlays n nil)) + (if (atom pos) + (setq end (1+ pos)) + (setq end (cdr pos)) + (setq pos (car pos))) + (if ov + (move-overlay ov pos end) + (let ((face-attributes (face-attr-construct face)) + (color-value (nth (/ n 2) hl-paren-colors)) + (background-value (nth (/ n 2) hl-paren-background-colors))) + (when color-value + (let ((attribute (memq :foreground face-attributes))) + (if attribute + (setcar (cdr attribute) color-value) + (push color-value face-attributes) + (push :foreground face-attributes)))) + (when background-value + (let ((attribute (memq :background face-attributes))) + (if attribute + (setcar (cdr attribute) background-value) + (push background-value face-attributes) + (push :background face-attributes)))) + (setq ov (make-overlay pos end)) + (aset hl-paren-overlays n ov) + (overlay-put ov 'face face-attributes)))))) + +;;;###autoload +(define-minor-mode highlight-parentheses-mode + "Minor mode to highlight the surrounding parentheses." + :init-value nil + :lighter " hl-p" + :keymap nil + (if highlight-parentheses-mode + (progn + (setq hl-paren-overlays + (make-vector (* 2 (max (length hl-paren-colors) + (length hl-paren-background-colors))) nil)) + (add-hook 'post-command-hook 'hl-paren-highlight nil t)) + (let (ov) + (dotimes (i (length hl-paren-overlays)) + (when (setq ov (elt hl-paren-overlays i)) + (delete-overlay ov)))) + (kill-local-variable 'hl-paren-overlays) + (kill-local-variable 'hl-paren-point) + (remove-hook 'post-command-hook 'hl-paren-highlight t))) + +(provide 'highlight-parentheses) + +;;; highlight-parentheses.el ends here diff --git a/site-lisp/extensions-local/lazy-load.el b/site-lisp/extensions-local/lazy-load.el new file mode 100644 index 0000000..555e6a5 --- /dev/null +++ b/site-lisp/extensions-local/lazy-load.el @@ -0,0 +1,49 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defun lazy-load-global-keys (key-alist filename &optional key-prefix) + (lazy-load-set-keys key-alist nil key-prefix) + (dolist (element key-alist) + (setq fun (cdr element)) + (autoload fun filename nil t))) + +(defun lazy-load-local-keys (key-alist keymap filename &optional key-prefix) + (lazy-load-set-keys key-alist keymap key-prefix) + (dolist (element key-alist) + (setq fun (cdr element)) + (autoload fun filename nil t))) + +(defun lazy-load-set-keys (key-alist &optional keymap key-prefix) + "This function is to little type when define key binding. +`KEYMAP' is a add keymap for some binding, default is `current-global-map'. +`KEY-ALIST' is a alist contain main-key and command. +`KEY-PREFIX' is a add prefix for some binding, default is nil." + (let (key def) + (or keymap (setq keymap (current-global-map))) + (if key-prefix + (setq key-prefix (concat key-prefix " ")) + (setq key-prefix "")) + (dolist (element key-alist) + (setq key (car element)) + (setq def (cdr element)) + (cond ((stringp key) (setq key (read-kbd-macro (concat key-prefix key)))) + ((vectorp key) nil) + (t (signal 'wrong-type-argument (list 'array key)))) + (define-key keymap key def)))) + +(defun lazy-load-unset-keys (key-list &optional keymap) + "This function is to little type when unset key binding. +`KEYMAP' is add keymap for some binding, default is `current-global-map' +`KEY-LIST' is list contain key." + (let (key) + (or keymap (setq keymap (current-global-map))) + (dolist (key key-list) + (cond ((stringp key) (setq key (read-kbd-macro (concat key)))) + ((vectorp key) nil) + (t (signal 'wrong-type-argument (list 'array key)))) + (define-key keymap key nil)))) + +(provide 'lazy-load) + +;;; lazy-load.el ends here diff --git a/site-lisp/extensions-local/ld-buffer-operations.el b/site-lisp/extensions-local/ld-buffer-operations.el new file mode 100644 index 0000000..426084e --- /dev/null +++ b/site-lisp/extensions-local/ld-buffer-operations.el @@ -0,0 +1,72 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defun ld-indent-buffer () + "Automatic format current buffer." + (interactive) + (cond + ((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.")) + (t + (save-excursion + (indent-region (point-min) (point-max) nil) + (delete-trailing-whitespace) + (untabify (point-min) (point-max)))))) + +; --- + +(defun ld-rename-file-and-buffer () + "Rename current buffer and if the buffer is visiting a file, rename it too." + (interactive) + (let ((filename (buffer-file-name))) + (if (not (and filename (file-exists-p filename))) + (rename-buffer (read-from-minibuffer "New name: " (buffer-name))) + (let* ((new-name (read-file-name "New name: " (file-name-directory filename))) + (containing-dir (file-name-directory new-name))) + (make-directory containing-dir t) + (cond + ((vc-backend filename) (vc-rename-file filename new-name)) + (t + (rename-file filename new-name t) + (set-visited-file-name new-name t t))))))) + +; --- + +(defun ld-delete-file-and-buffer () + "Kill the current buffer and deletes the file it is visiting." + (interactive) + (let ((filename (buffer-file-name))) + (when filename + (if (vc-backend filename) + (vc-delete-file filename) + (when (y-or-n-p (format "Sure to delete %s? " filename)) + (delete-file filename delete-by-moving-to-trash) + (message "Deleted file %s" filename) + (kill-buffer)))))) + +; --- + +(defun ld-revert-buffer-no-confirm () + "Revert buffer without confirmation." + (interactive) + (revert-buffer :ignore-auto :noconfirm)) + +; --- + +(defun ld-unmark-all-buffers () + "Unmark all have marked buffers." + (interactive) + (let ((current-element (current-buffer))) + (save-excursion + (dolist (element (buffer-list)) + (set-buffer element) + (deactivate-mark))) + (switch-to-buffer current-element) + (deactivate-mark))) + +(provide 'ld-buffer-operations) + +;;; ld-buffer-operations.el ends here diff --git a/site-lisp/extensions-local/ld-delete-block.el b/site-lisp/extensions-local/ld-delete-block.el new file mode 100644 index 0000000..494a9ed --- /dev/null +++ b/site-lisp/extensions-local/ld-delete-block.el @@ -0,0 +1,38 @@ +;; -*- 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-file-operations.el b/site-lisp/extensions-local/ld-file-operations.el new file mode 100644 index 0000000..0b08aad --- /dev/null +++ b/site-lisp/extensions-local/ld-file-operations.el @@ -0,0 +1,14 @@ +;; -*- 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 new file mode 100644 index 0000000..0d065c1 --- /dev/null +++ b/site-lisp/extensions-local/ld-goto-cursor-stack.el @@ -0,0 +1,39 @@ +;; -*- 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-goto-simple.el b/site-lisp/extensions-local/ld-goto-simple.el new file mode 100644 index 0000000..11afc39 --- /dev/null +++ b/site-lisp/extensions-local/ld-goto-simple.el @@ -0,0 +1,30 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defun ld-goto-column (number) + "Untabify, and go to a column NUMBER within the current line (0 is beginning of the line)." + (interactive "nColumn number: ") + (move-to-column number t)) + +; --- + +(defun ld-goto-percent-text (percent) + "Move the cursor to the character, + which is % far from the top character." + (interactive "n(text) Goto percent: ") + (goto-char (/ (* percent (point-max)) 100))) + +; --- + +(defun ld-goto-percent-line (percent) + "Move the cursor to the line, + which is % far from the top line." + (interactive "n(line) Goto percent: ") + (goto-line (/ (* percent (count-lines (point-min) (point-max))) + 100))) + +(provide 'ld-goto-simple) + +;;; ld-goto-simple.el ends here + diff --git a/site-lisp/extensions-local/ld-org-publish-project-desc.el b/site-lisp/extensions-local/ld-org-publish-project-desc.el new file mode 100644 index 0000000..cd21e2b --- /dev/null +++ b/site-lisp/extensions-local/ld-org-publish-project-desc.el @@ -0,0 +1,106 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(setq + org-publish-project-alist + (let* ((ld-site-path "~/Documents/ld_org_article/") + (ld-site-pub-path "~/Public/ld_org_article_publish/") + (get-content (lambda (x) + (with-temp-buffer + (insert-file-contents (concat ld-site-path x)) + (buffer-string)))) + (ld-site-postamble (funcall get-content "template/postamble.html")) + (ld-site-preamble (funcall get-content "template/preamble.html")) + (ld-site-head (funcall get-content "template/head.html"))) + `( + ("blog" + :base-directory ,(concat ld-site-path "article/blog/") + :base-extension "org" + :publishing-directory ,(concat ld-site-pub-path "article/blog/") + :publishing-function org-html-publish-to-html + :recursive t + :headline-levels 4 + + :auto-sitemap t + :sitemap-filename "sitemap-index.org" + :sitemap-title "blog" + + :html-doctype "html5" + :html-head ,ld-site-head + :html-preamble ,ld-site-preamble + :html-postamble ,ld-site-postamble + ;; :htmlized-source t + + :with-toc t + ) + ("wiki" + :base-directory ,(concat ld-site-path "article/wiki/") + :base-extension "org" + :publishing-directory ,(concat ld-site-pub-path "article/wiki/") + :publishing-function org-html-publish-to-html + :recursive t + :headline-levels 4 + + :auto-sitemap t + :sitemap-filename "sitemap-index.org" + :sitemap-title "wiki" + + :html-doctype "html5" + :html-head ,ld-site-head + :html-preamble ,ld-site-preamble + :html-postamble ,ld-site-postamble + ;; :htmlized-source t + + :with-toc t + ) + ("translation" + :base-directory ,(concat ld-site-path "article/translation/") + :base-extension "org" + :publishing-directory ,(concat ld-site-pub-path "article/translation/") + :publishing-function org-html-publish-to-html + :recursive t + :headline-levels 4 + + :auto-sitemap t + :sitemap-filename "sitemap-index.org" + :sitemap-title "translation" + + :html-doctype "html5" + :html-head ,ld-site-head + :html-preamble ,ld-site-preamble + :html-postamble ,ld-site-postamble + ;; :htmlized-source t + + :with-toc t + ) + ("site" + :base-directory ,(concat ld-site-path "article/site/") + :base-extension "org" + :publishing-directory ,(concat ld-site-pub-path "article/site/") + :publishing-function org-html-publish-to-html + :recursive t + :headline-levels 4 + + :html-doctype "html5" + :html-head ,ld-site-head + :html-preamble ,ld-site-preamble + :html-postamble ,ld-site-postamble + ;; :htmlized-source t + + :with-toc nil + ) + ("static" + :base-directory ,(concat ld-site-path "article_static/") + ;; :base-extension "css\\|js\\|ico\\|png\\|jpg\\|gif\\|zip\\|7z\\|rar\\|pdf" + :base-extension ".*" + :publishing-directory ,(concat ld-site-pub-path "/article_static") + :publishing-function org-publish-attachment + :recursive t + ) + ("all" :components ("blog" "wiki" "site" "translation" "static")) + ))) + +(provide 'ld-org-publish-project-desc) + +;;; ld-org-publish-project-desc.el ends here diff --git a/site-lisp/extensions-local/ld-text-operations.el b/site-lisp/extensions-local/ld-text-operations.el new file mode 100644 index 0000000..f08c12b --- /dev/null +++ b/site-lisp/extensions-local/ld-text-operations.el @@ -0,0 +1,109 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +; --- move lines +(defun ld-move-text-internal (arg) + (cond + ((and mark-active transient-mark-mode) + (if (> (point) (mark)) + (exchange-point-and-mark)) + (let ((column (current-column)) + (text (delete-and-extract-region (point) (mark)))) + (forward-line arg) + (move-to-column column t) + (set-mark (point)) + (insert text) + (exchange-point-and-mark) + (setq deactivate-mark nil))) + (t + (beginning-of-line) + (when (or (> arg 0) (not (bobp))) + (forward-line) + (when (or (< arg 0) (not (eobp))) + (transpose-lines arg)) + (forward-line -1))))) + +(defun ld-move-text-down (arg) + "Move region (transient-mark-mode active) or current line + arg lines down." + (interactive "*p") + (ld-move-text-internal arg)) + +(defun ld-move-text-up (arg) + "Move region (transient-mark-mode active) or current line + arg lines up." + (interactive "*p") + (ld-move-text-internal (- arg))) + +; --- duplicate line +(defun ld-get-positions-of-line-or-region () + "Return positions (beg . end) of the current line or region." + (let (beg end) + (if (and mark-active (> (point) (mark))) + (exchange-point-and-mark)) + (setq beg (line-beginning-position)) + (if mark-active + (exchange-point-and-mark)) + (setq end (line-end-position)) + (cons beg end))) + +(defun ld-duplicate-current-line-or-region (arg) + "Duplicates the current line or region ARG times. +If there's no region, the current line will be duplicated. However, if +there's a region, all lines that region covers will be duplicated." + (interactive "p") + (pcase-let* ((origin (point)) + (`(,beg . ,end) (ld-get-positions-of-line-or-region)) + (region (buffer-substring-no-properties beg end))) + (dotimes (_i arg) + (goto-char end) + (unless (use-region-p) + (newline)) + (insert region) + (setq end (point))) + (goto-char (+ origin (* (length region) arg) arg)))) + +(defun ld-duplicate-and-comment-current-line-or-region (arg) + "Duplicates and comments the current line or region ARG times. +If there's no region, the current line will be duplicated. However, if +there's a region, all lines that region covers will be duplicated." + (interactive "p") + (pcase-let* ((origin (point)) + (`(,beg . ,end) (ld-get-positions-of-line-or-region)) + (region (buffer-substring-no-properties beg end))) + (comment-or-uncomment-region beg end) + (setq end (line-end-position)) + (dotimes (_ arg) + (goto-char end) + (unless (use-region-p) + (newline)) + (insert region) + (setq end (point))) + (goto-char (+ origin (* (length region) arg) arg)))) + +; --- + +(defun ld-delete-current-line () + "Delete (not kill) the current line." + (interactive) + (save-excursion + (delete-region + (progn (forward-visible-line 0) (point)) + (progn (forward-visible-line 1) (point))))) + +; --- + +(defun ld-mark-line () + "Mark one whole line, similar to `mark-paragraph'." + (interactive) + (beginning-of-line) + (if mark-active + (exchange-point-and-mark) + (push-mark nil nil t)) + (forward-line) + (exchange-point-and-mark)) + +(provide 'ld-text-operations) + +;;; ld-text-operations.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 new file mode 100644 index 0000000..0690222 --- /dev/null +++ b/site-lisp/extensions-local/ld-toggle-one-window.el @@ -0,0 +1,22 @@ +;; -*- 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/ld-tools.el b/site-lisp/extensions-local/ld-tools.el new file mode 100644 index 0000000..ae80331 --- /dev/null +++ b/site-lisp/extensions-local/ld-tools.el @@ -0,0 +1,167 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(defun insert-line-number (beg end &optional start-line) + "Insert line numbers into buffer." + (interactive "r") + (save-excursion + (let ((max (count-lines beg end)) + (line (or start-line 1)) + (counter 1)) + (goto-char beg) + (while (<= counter max) + (insert (format "%0d " line)) + (beginning-of-line 2) + (cl-incf line) + (cl-incf counter))))) + +(defun insert-line-number+ () + "Insert line number into buffer." + (interactive) + (if mark-active + (insert-line-number (region-beginning) (region-end) (read-number "Start line: ")) + (insert-line-number (point-min) (point-max)))) + +(defun strip-blank-lines() + "Strip all blank lines in select area of buffer, +if not select any area, then strip all blank lines of buffer." + (interactive) + (strip-regular-expression-string "^[ \t]*\n") + (message "Blanks line striped. ^_^")) + +(defun strip-line-number() + "Strip all line number in select area of buffer, +if not select any area, then strip all line number of buffer." + (interactive) + (strip-regular-expression-string "^[0-9]+ ") + (message "Line number striped. ^_^")) + +(defun strip-regular-expression-string (regular-expression) + "Strip all string that match REGULAR-EXPRESSION in select area of buffer. +If not select any area, then strip current buffer" + (interactive) + (let ((begin (point-min)) + (end (point-max))) + (if mark-active + (setq begin (region-beginning) + end (region-end))) + (save-excursion + (goto-char end) + (while (and (> (point) begin) + (re-search-backward regular-expression nil t)) + (replace-match "" t t))))) + +(defun indent-comment-buffer () + "Indent comment of buffer." + (interactive) + (indent-comment-region (point-min) (point-max))) + +(defun indent-comment-region (start end) + "Indent region." + (interactive "r") + (save-excursion + (setq end (copy-marker end)) + (goto-char start) + (while (< (point) end) + (if (comment-search-forward end t) + (comment-indent) + (goto-char end))))) + +(defun capitalize-one-char (arg) + "Change the letter pointed by the cursor to uppercase." + (interactive "P") + (upcase-region (point) (+ (point) (or arg 1))) + (forward-char (or arg 1))) + +(defun lowercase-one-char (arg) + "Change the letter pointed by the cursor to lowercase." + (interactive "P") + (downcase-region (point) (+ (point) (or arg 1))) + (forward-char (or arg 1))) + +(defun delete-chars-hungry-forward (&optional reverse) + "Delete chars forward use `hungry' style. +Optional argument REVERSE default is delete forward, if reverse is non-nil delete backward." + (delete-region + (point) + (progn + (if reverse + (skip-chars-backward " \t\n\r") + (skip-chars-forward " \t\n\r")) + (point)))) + +(defun delete-chars-hungry-backward () + "Delete chars backward use `hungry' style." + (delete-chars-hungry-forward t)) + +(defun reverse-chars-in-region (start end) + "Reverse the region character by character without reversing lines." + (interactive "r") + (let ((str (buffer-substring start end))) + (delete-region start end) + (dolist (line (split-string str "\n")) + (let ((chars (mapcar (lambda (c) + (or (matching-paren c) + c)) + (reverse (append line nil))))) + (when chars + (apply 'insert chars)) + (newline))))) + +(defun underline-line-with (char) + "Insert some char below at current line." + (interactive "cType one char: ") + (save-excursion + (let ((length (- (point-at-eol) (point-at-bol)))) + (end-of-line) + (insert "\n") + (insert (make-string length char))))) + +(defun prettyfy-string (string &optional after) + "Strip starting and ending whitespace and pretty `STRING'. +Replace any chars after AFTER with '...'. +Argument STRING the string that need pretty." + (let ((replace-map (list + (cons "^[ \t]*" "") + (cons "[ \t]*$" "") + (cons (concat "^\\(.\\{" + (or (number-to-string after) "10") + "\\}\\).*") + "\\1...")))) + (dolist (replace replace-map) + (when (string-match (car replace) string) + (setq string (replace-match (cdr replace) nil nil string)))) + string)) + +(defun forward-button-with-line-begin () + "Move to next button with line begin." + (interactive) + (call-interactively 'forward-button) + (while (not (bolp)) + (call-interactively 'forward-button))) + +(defun backward-button-with-line-begin () + "Move to previous button with line begin." + (interactive) + (call-interactively 'backward-button) + (while (not (bolp)) + (call-interactively 'backward-button))) + +(defun only-comment-p () + "Return t if current line only contains comment. Otherwise return nil." + (interactive) + (save-excursion + (beginning-of-line) + (if (search-forward comment-start (line-end-position) t) + (progn + (backward-char (length comment-start)) + (equal (point) + (progn + (back-to-indentation) + (point)))) + nil))) + +(provide 'ld-tools) + +;;; ld-tools.el ends here diff --git a/site-lisp/extensions-local/neotree.el b/site-lisp/extensions-local/neotree.el new file mode 100644 index 0000000..4a303f1 --- /dev/null +++ b/site-lisp/extensions-local/neotree.el @@ -0,0 +1,2228 @@ +;;; neotree.el --- A tree plugin like NerdTree for Vim + +;; Copyright (C) 2014 jaypei + +;; Author: jaypei +;; URL: https://github.com/jaypei/emacs-neotree +;; Version: 0.6.0 +;; Package-Requires: ((cl-lib "0.5")) + +;; 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: + +;; To use this file, put something like the following in your +;; ~/.emacs: +;; +;; (add-to-list 'load-path "/directory/containing/neotree/") +;; (require 'neotree) +;; +;; Type M-x neotree to start. +;; +;; To set options for NeoTree, type M-x customize, then select +;; Applications, NeoTree. +;; + +;;; Code: + +(require 'cl-lib) + +;; +;; Constants +;; + +(defconst neo-buffer-name " *NeoTree*" + "Name of the buffer where neotree shows directory contents.") + +(defconst neo-dir + (expand-file-name (if load-file-name + (file-name-directory load-file-name) + default-directory))) + +(defconst neo-header-height 5) + +(eval-and-compile + + ;; Added in Emacs 24.3 + (unless (fboundp 'user-error) + (defalias 'user-error 'error)) + + ;; Added in Emacs 24.3 (mirrors/emacs@b335efc3). + (unless (fboundp 'setq-local) + (defmacro setq-local (var val) + "Set variable VAR to value VAL in current buffer." + (list 'set (list 'make-local-variable (list 'quote var)) val))) + + ;; Added in Emacs 24.3 (mirrors/emacs@b335efc3). + (unless (fboundp 'defvar-local) + (defmacro defvar-local (var val &optional docstring) + "Define VAR as a buffer-local variable with default value VAL. +Like `defvar' but additionally marks the variable as being automatically +buffer-local wherever it is set." + (declare (debug defvar) (doc-string 3)) + (list 'progn (list 'defvar var val docstring) + (list 'make-variable-buffer-local (list 'quote var)))))) + +;; Add autoload function for vc (#153). +(autoload 'vc-responsible-backend "vc.elc") + +;; +;; Macros +;; + +(defmacro neo-util--to-bool (obj) + "If OBJ is non-nil, return t, else return nil." + `(and ,obj t)) + +(defmacro neo-global--with-buffer (&rest body) + "Execute the forms in BODY with global NeoTree buffer." + (declare (indent 0) (debug t)) + `(let ((neotree-buffer (neo-global--get-buffer))) + (unless (null neotree-buffer) + (with-current-buffer neotree-buffer + ,@body)))) + +(defmacro neo-global--with-window (&rest body) + "Execute the forms in BODY with global NeoTree window." + (declare (indent 0) (debug t)) + `(save-selected-window + (neo-global--select-window) + ,@body)) + +(defmacro neo-global--when-window (&rest body) + "Execute the forms in BODY when selected window is NeoTree window." + (declare (indent 0) (debug t)) + `(when (eq (selected-window) neo-global--window) + ,@body)) + +(defmacro neo-global--switch-to-buffer () + "Switch to NeoTree buffer." + `(let ((neotree-buffer (neo-global--get-buffer))) + (unless (null neotree-buffer) + (switch-to-buffer neotree-buffer)))) + +(defmacro neo-buffer--with-editing-buffer (&rest body) + "Execute BODY in neotree buffer without read-only restriction." + `(let (rlt) + (neo-global--with-buffer + (setq buffer-read-only nil) + (setq rlt (progn ,@body)) + (setq buffer-read-only t)) + rlt)) + +(defmacro neo-buffer--with-resizable-window (&rest body) + "Execute BODY in neotree window without `window-size-fixed' restriction." + `(let (rlt) + (neo-global--with-buffer + (neo-buffer--unlock-width)) + (setq rlt (progn ,@body)) + (neo-global--with-buffer + (neo-buffer--lock-width)) + rlt)) + +(defmacro neotree-make-executor (&rest fn-form) + "Make an open event handler, FN-FORM is event handler form." + (let* ((get-args-fn + (lambda (sym) (or (plist-get fn-form sym) (lambda (&rest _))))) + (file-fn (funcall get-args-fn :file-fn)) + (dir-fn (funcall get-args-fn :dir-fn))) + `(lambda (&optional arg) + (interactive "P") + (neo-global--select-window) + (neo-buffer--execute arg ,file-fn ,dir-fn)))) + + +;; +;; Customization +;; + +(defgroup neotree nil + "Options for neotree." + :prefix "neo-" + :group 'files) + +(defgroup neotree-vc-options nil + "Neotree-VC customizations." + :prefix "neo-vc-" + :group 'neotree + :link '(info-link "(neotree)Configuration")) + +(defgroup neotree-confirmations nil + "Neotree confirmation customizations." + :prefix "neo-confirm-" + :group 'neotree) + +(defcustom neo-window-position 'left + "*The position of NeoTree window." + :group 'neotree + :type '(choice (const left) + (const right))) + +(defcustom neo-display-action '(neo-default-display-fn) + "*Action to use for displaying NeoTree window. +If you change the action so it doesn't use +`neo-default-display-fn', then other variables such as +`neo-window-position' won't be respected when opening NeoTree +window." + :type 'sexp + :group 'neotree) + +(defcustom neo-create-file-auto-open nil + "*If non-nil, the file will auto open when created." + :type 'boolean + :group 'neotree) + +(defcustom neo-banner-message nil + "*The banner message of neotree window." + :type 'string + :group 'neotree) + +(defcustom neo-show-updir-line t + "*If non-nil, show the updir line (..)." + :type 'boolean + :group 'neotree) + +(defcustom neo-show-slash-for-folder t + "*If non-nil, show the slash at the end of folder (folder/)" + :type 'boolean + :group 'neotree) + +(defcustom neo-reset-size-on-open nil + "*If non-nil, the width of the noetree window will be reseted every time a file is open." + :type 'boolean + :group 'neotree) + +(defcustom neo-theme 'classic + "*The tree style to display. +`classic' use icon to display, it only it suitable for GUI mode. +`ascii' is the simplest style, it will use +/- to display the fold state, +it suitable for terminal. +`arrow' use unicode arrow. +`nerd' use the nerdtree indentation mode and arrow." + :group 'neotree + :type '(choice (const classic) + (const ascii) + (const arrow) + (const icons) + (const nerd))) + +(defcustom neo-mode-line-type 'neotree + "*The mode-line type to display, `default' is a non-modified mode-line, \ +`neotree' is a compact mode-line that shows useful information about the + current node like the parent directory and the number of nodes, +`custom' uses the format stored in `neo-mode-line-custom-format', +`none' hide the mode-line." + :group 'neotree + :type '(choice (const default) + (const neotree) + (const custom) + (const none))) + +(defcustom neo-mode-line-custom-format nil + "*If `neo-mode-line-type' is set to `custom', this variable specifiy \ +the mode-line format." + :type 'sexp + :group 'neotree) + +(defcustom neo-smart-open nil + "*If non-nil, every time when the neotree window is opened, it will try to find current file and jump to node." + :type 'boolean + :group 'neotree) + +(defcustom neo-show-hidden-files nil + "*If non-nil, the hidden files are shown by default." + :type 'boolean + :group 'neotree) + +(defcustom neo-autorefresh nil + "*If non-nil, the neotree buffer will auto refresh." + :type 'boolean + :group 'neotree) + +(defcustom neo-window-width 25 + "*Specifies the width of the NeoTree window." + :type 'integer + :group 'neotree) + +(defcustom neo-window-fixed-size t + "*If the neotree windows is fixed, it won't be resize when rebalance windows." + :type 'boolean + :group 'neotree) + +(defcustom neo-keymap-style 'default + "*The default keybindings for neotree-mode-map." + :group 'neotree + :type '(choice (const default) + (const concise))) + +(defcustom neo-cwd-line-style 'text + "*The default header style." + :group 'neotree + :type '(choice (const text) + (const button))) + +(defcustom neo-help-echo-style 'default + "The message NeoTree displays when the mouse moves onto nodes. +`default' means the node name is displayed if it has a +width (including the indent) larger than `neo-window-width', and +`none' means NeoTree doesn't display any messages." + :group 'neotree + :type '(choice (const default) + (const none))) + +(defcustom neo-click-changes-root nil + "*If non-nil, clicking on a directory will change the current root to the directory." + :type 'boolean + :group 'neotree) + +(defcustom neo-auto-indent-point nil + "*If non-nil the point is autmotically put on the first letter of a node." + :type 'boolean + :group 'neotree) + +(defcustom neo-hidden-regexp-list + '("^\\." "\\.pyc$" "~$" "^#.*#$" "\\.elc$" "\\.o$") + "*The regexp list matching hidden files." + :type '(repeat (choice regexp)) + :group 'neotree) + +(defcustom neo-enter-hook nil + "Functions to run if enter node occured." + :type 'hook + :group 'neotree) + +(defcustom neo-after-create-hook nil + "Hooks called after creating the neotree buffer." + :type 'hook + :group 'neotree) + +(defcustom neo-vc-integration nil + "If non-nil, show VC status." + :group 'neotree-vc + :type '(set (const :tag "Use different faces" face) + (const :tag "Use different characters" char))) + +(defcustom neo-vc-state-char-alist + '((up-to-date . ?\s) + (edited . ?E) + (added . ?+) + (removed . ?-) + (missing . ?!) + (needs-merge . ?M) + (conflict . ?!) + (unlocked-changes . ?!) + (needs-update . ?U) + (ignored . ?\s) + (user . ?U) + (unregistered . ?\s) + (nil . ?\s)) + "Alist of vc-states to indicator characters. +This variable is used in `neo-vc-for-node' when +`neo-vc-integration' contains `char'." + :group 'neotree-vc + :type '(alist :key-type symbol + :value-type character)) + +(defcustom neo-confirm-change-root 'yes-or-no-p + "Confirmation asking for permission to change root if file was not found in root path." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-confirm-create-file 'yes-or-no-p + "Confirmation asking whether *NeoTree* should create a file." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-confirm-create-directory 'yes-or-no-p + "Confirmation asking whether *NeoTree* should create a directory." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-confirm-delete-file 'yes-or-no-p + "Confirmation asking whether *NeoTree* should delete the file." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-confirm-delete-directory-recursively 'yes-or-no-p + "Confirmation asking whether the directory should be deleted recursively." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-confirm-kill-buffers-for-files-in-directory 'yes-or-no-p + "Confirmation asking whether *NeoTree* should kill buffers for the directory in question." + :type '(choice (function-item :tag "Verbose" yes-or-no-p) + (function-item :tag "Succinct" y-or-n-p) + (function-item :tag "Off" off-p)) + :group 'neotree-confirmations) + +(defcustom neo-toggle-window-keep-p nil + "If not nil, not switch to *NeoTree* buffer when executing `neotree-toggle'." + :type 'boolean + :group 'neotree) + +(defcustom neo-force-change-root t + "If not nil, do not prompt when switching root." + :type 'boolean + :group 'neotree) + +(defcustom neo-filepath-sort-function 'string< + "Function to be called when sorting neotree nodes." + :type '(symbol (const :tag "Normal" string<) + (const :tag "Sort Hidden at Bottom" neo-sort-hidden-last) + (function :tag "Other")) + :group 'neotree) + +(defcustom neo-default-system-application "xdg-open" + "*Name of the application that is used to open a file under point. +By default it is xdg-open." + :type 'string + :group 'neotree) + +(defcustom neo-hide-cursor nil + "If not nil, hide cursor in NeoTree buffer and turn on line higlight." + :type 'boolean + :group 'neotree) + +;; +;; Faces +;; + +(defface neo-banner-face + '((((background dark)) (:foreground "lightblue" :weight bold)) + (t (:foreground "DarkMagenta"))) + "*Face used for the banner in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-banner-face 'neo-banner-face) + +(defface neo-header-face + '((((background dark)) (:foreground "White")) + (t (:foreground "DarkMagenta"))) + "*Face used for the header in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-header-face 'neo-header-face) + +(defface neo-root-dir-face + '((((background dark)) (:foreground "lightblue" :weight bold)) + (t (:foreground "DarkMagenta"))) + "*Face used for the root dir in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-root-dir-face 'neo-root-dir-face) + +(defface neo-dir-link-face + '((((background dark)) (:foreground "DeepSkyBlue")) + (t (:foreground "MediumBlue"))) + "*Face used for expand sign [+] in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-dir-link-face 'neo-dir-link-face) + +(defface neo-file-link-face + '((((background dark)) (:foreground "White")) + (t (:foreground "Black"))) + "*Face used for open file/dir in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-file-link-face 'neo-file-link-face) + +(defface neo-button-face + '((t (:underline nil))) + "*Face used for open file/dir in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-button-face 'neo-button-face) + +(defface neo-expand-btn-face + '((((background dark)) (:foreground "SkyBlue")) + (t (:foreground "DarkCyan"))) + "*Face used for open file/dir in neotree buffer." + :group 'neotree :group 'font-lock-highlighting-faces) +(defvar neo-expand-btn-face 'neo-expand-btn-face) + +(defface neo-vc-default-face + '((((background dark)) (:foreground "White")) + (t (:foreground "Black"))) + "*Face used for unknown files in the neotree buffer. +Used only when \(vc-state node\) returns nil." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-default-face 'neo-vc-default-face) + +(defface neo-vc-user-face + '((t (:foreground "Red" :slant italic))) + "*Face used for user-locked files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-user-face 'neo-vc-user-face) + +(defface neo-vc-up-to-date-face + '((((background dark)) (:foreground "LightGray")) + (t (:foreground "DarkGray"))) + "*Face used for vc-up-to-date files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-up-to-date-face 'neo-vc-up-to-date-face) + +(defface neo-vc-edited-face + '((((background dark)) (:foreground "Magenta")) + (t (:foreground "DarkMagenta"))) + "*Face used for vc-edited files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-edited-face 'neo-vc-edited-face) + +(defface neo-vc-needs-update-face + '((t (:underline t))) + "*Face used for vc-needs-update files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-needs-update-face 'neo-vc-needs-update-face) + +(defface neo-vc-needs-merge-face + '((((background dark)) (:foreground "Red1")) + (t (:foreground "Red3"))) + "*Face used for vc-needs-merge files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-needs-merge-face 'neo-vc-needs-merge-face) + +(defface neo-vc-unlocked-changes-face + '((t (:foreground "Red" :background "Blue"))) + "*Face used for vc-unlocked-changes files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-unlocked-changes-face 'neo-vc-unlocked-changes-face) + +(defface neo-vc-added-face + '((((background dark)) (:foreground "LightGreen")) + (t (:foreground "DarkGreen"))) + "*Face used for vc-added files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-added-face 'neo-vc-added-face) + +(defface neo-vc-removed-face + '((t (:strike-through t))) + "*Face used for vc-removed files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-removed-face 'neo-vc-removed-face) + +(defface neo-vc-conflict-face + '((((background dark)) (:foreground "Red1")) + (t (:foreground "Red3"))) + "*Face used for vc-conflict files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-conflict-face 'neo-vc-conflict-face) + +(defface neo-vc-missing-face + '((((background dark)) (:foreground "Red1")) + (t (:foreground "Red3"))) + "*Face used for vc-missing files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-missing-face 'neo-vc-missing-face) + +(defface neo-vc-ignored-face + '((((background dark)) (:foreground "DarkGrey")) + (t (:foreground "LightGray"))) + "*Face used for vc-ignored files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-ignored-face 'neo-vc-ignored-face) + +(defface neo-vc-unregistered-face + nil + "*Face used for vc-unregistered files in the neotree buffer." + :group 'neotree-vc :group 'font-lock-highlighting-faces) +(defvar neo-vc-unregistered-face 'neo-vc-unregistered-face) + +;; +;; Variables +;; + +(defvar neo-global--buffer nil) + +(defvar neo-global--window nil) + +(defvar neo-global--autorefresh-timer nil) + +(defvar neo-mode-line-format + (list + '(:eval + (let* ((fname (neo-buffer--get-filename-current-line)) + (current (if fname fname neo-buffer--start-node)) + (parent (if fname (file-name-directory current) current)) + (nodes (neo-buffer--get-nodes parent)) + (dirs (car nodes)) + (files (cdr nodes)) + (ndirs (length dirs)) + (nfiles (length files)) + (index + (when fname + (1+ (if (file-directory-p current) + (neo-buffer--get-node-index current dirs) + (+ ndirs (neo-buffer--get-node-index current files))))))) + (neo-mode-line--compute-format parent index ndirs nfiles)))) + "Neotree mode-line displaying information on the current node. +This mode-line format is used if `neo-mode-line-type' is set to `neotree'") + +(defvar-local neo-buffer--start-node nil + "Start node(i.e. directory) for the window.") + +(defvar-local neo-buffer--start-line nil + "Index of the start line of the root.") + +(defvar-local neo-buffer--cursor-pos (cons nil 1) + "To save the cursor position. +The car of the pair will store fullpath, and cdr will store line number.") + +(defvar-local neo-buffer--last-window-pos (cons nil 1) + "To save the scroll position for NeoTree window.") + +(defvar-local neo-buffer--show-hidden-file-p nil + "Show hidden nodes in tree.") + +(defvar-local neo-buffer--expanded-node-list nil + "A list of expanded dir nodes.") + +(defvar-local neo-buffer--node-list nil + "The model of current NeoTree buffer.") + +(defvar-local neo-buffer--node-list-1 nil + "The model of current NeoTree buffer (temp).") + +;; +;; Major mode definitions +;; + +(defvar neotree-file-button-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-2] + (neotree-make-executor + :file-fn 'neo-open-file)) + map) + "Keymap for file-node button.") + +(defvar neotree-dir-button-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-2] + (neotree-make-executor :dir-fn 'neo-open-dir)) + map) + "Keymap for dir-node button.") + +(defvar neotree-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "TAB") (neotree-make-executor + :dir-fn 'neo-open-dir)) + (define-key map (kbd "RET") (neotree-make-executor + :file-fn 'neo-open-file + :dir-fn 'neo-open-dir)) + (define-key map (kbd "|") (neotree-make-executor + :file-fn 'neo-open-file-vertical-split)) + (define-key map (kbd "-") (neotree-make-executor + :file-fn 'neo-open-file-horizontal-split)) + (define-key map (kbd "a") (neotree-make-executor + :file-fn 'neo-open-file-ace-window)) + (define-key map (kbd "d") (neotree-make-executor + :dir-fn 'neo-open-dired)) + (define-key map (kbd "O") (neotree-make-executor + :dir-fn 'neo-open-dir-recursive)) + (define-key map (kbd "SPC") 'neotree-quick-look) + (define-key map (kbd "g") 'neotree-refresh) + (define-key map (kbd "q") 'neotree-hide) + (define-key map (kbd "p") 'neotree-previous-line) + (define-key map (kbd "C-p") 'neotree-previous-line) + (define-key map (kbd "n") 'neotree-next-line) + (define-key map (kbd "C-n") 'neotree-next-line) + (define-key map (kbd "A") 'neotree-stretch-toggle) + (define-key map (kbd "U") 'neotree-select-up-node) + (define-key map (kbd "D") 'neotree-select-down-node) + (define-key map (kbd "H") 'neotree-hidden-file-toggle) + (define-key map (kbd "S") 'neotree-select-previous-sibling-node) + (define-key map (kbd "s") 'neotree-select-next-sibling-node) + (define-key map (kbd "o") 'neotree-open-file-in-system-application) + (define-key map (kbd "C-x C-f") 'find-file-other-window) + (define-key map (kbd "C-x 1") 'neotree-empty-fn) + (define-key map (kbd "C-x 2") 'neotree-empty-fn) + (define-key map (kbd "C-x 3") 'neotree-empty-fn) + (define-key map (kbd "C-c C-f") 'find-file-other-window) + (define-key map (kbd "C-c C-c") 'neotree-change-root) + (define-key map (kbd "C-c c") 'neotree-dir) + (define-key map (kbd "C-c C-a") 'neotree-collapse-all) + (cond + ((eq neo-keymap-style 'default) + (define-key map (kbd "C-c C-n") 'neotree-create-node) + (define-key map (kbd "C-c C-d") 'neotree-delete-node) + (define-key map (kbd "C-c C-r") 'neotree-rename-node) + (define-key map (kbd "C-c C-p") 'neotree-copy-node)) + ((eq neo-keymap-style 'concise) + (define-key map (kbd "C") 'neotree-change-root) + (define-key map (kbd "c") 'neotree-create-node) + (define-key map (kbd "+") 'neotree-create-node) + (define-key map (kbd "d") 'neotree-delete-node) + (define-key map (kbd "r") 'neotree-rename-node) + (define-key map (kbd "e") 'neotree-enter))) + map) + "Keymap for `neotree-mode'.") + +(define-derived-mode neotree-mode special-mode "NeoTree" + "A major mode for displaying the directory tree in text mode." + (setq indent-tabs-mode nil ; only spaces + buffer-read-only t ; read only + truncate-lines -1 + neo-buffer--show-hidden-file-p neo-show-hidden-files) + (when neo-hide-cursor + (progn + (setq cursor-type nil) + (hl-line-mode +1))) + (pcase neo-mode-line-type + (`neotree + (setq-local mode-line-format neo-mode-line-format) + (add-hook 'post-command-hook 'force-mode-line-update nil t)) + (`none (setq-local mode-line-format nil)) + (`custom + (setq-local mode-line-format neo-mode-line-custom-format) + (add-hook 'post-command-hook 'force-mode-line-update nil t)) + (_ nil)) + ;; fix for electric-indent-mode + ;; for emacs 24.4 + (if (fboundp 'electric-indent-local-mode) + (electric-indent-local-mode -1) + ;; for emacs 24.3 or less + (add-hook 'electric-indent-functions + (lambda (arg) 'no-indent) nil 'local)) + (when neo-auto-indent-point + (add-hook 'post-command-hook 'neo-hook--node-first-letter nil t))) + +;; +;; Global methods +;; + +(defun neo-global--window-exists-p () + "Return non-nil if neotree window exists." + (and (not (null (window-buffer neo-global--window))) + (eql (window-buffer neo-global--window) (neo-global--get-buffer)))) + +(defun neo-global--select-window () + "Select the NeoTree window." + (interactive) + (let ((window (neo-global--get-window t))) + (select-window window))) + +(defun neo-global--get-window (&optional auto-create-p) + "Return the neotree window if it exists, else return nil. +But when the neotree window does not exist and AUTO-CREATE-P is non-nil, +it will create the neotree window and return it." + (unless (neo-global--window-exists-p) + (setf neo-global--window nil)) + (when (and (null neo-global--window) + auto-create-p) + (setq neo-global--window + (neo-global--create-window))) + neo-global--window) + +(defun neo-default-display-fn (buffer _alist) + "Display BUFFER to the left or right of the root window. +The side is decided according to `neo-window-position'. +The root window is the root window of the selected frame. +_ALIST is ignored." + (let ((window-pos (if (eq neo-window-position 'left) 'left 'right))) + (display-buffer-in-side-window buffer `((side . ,window-pos))))) + +(defun neo-global--create-window () + "Create global neotree window." + (let ((window nil) + (buffer (neo-global--get-buffer t))) + (setq window + (select-window + (display-buffer buffer neo-display-action))) + (neo-window--init window buffer) + (neo-global--attach) + (neo-global--reset-width) + window)) + +(defun neo-global--get-buffer (&optional init-p) + "Return the global neotree buffer if it exists. +If INIT-P is non-nil and global NeoTree buffer not exists, then create it." + (unless (equal (buffer-name neo-global--buffer) + neo-buffer-name) + (setf neo-global--buffer nil)) + (when (and init-p + (null neo-global--buffer)) + (save-window-excursion + (setq neo-global--buffer + (neo-buffer--create)))) + neo-global--buffer) + +(defun neo-global--file-in-root-p (path) + "Return non-nil if PATH in root dir." + (neo-global--with-buffer + (and (not (null neo-buffer--start-node)) + (neo-path--file-in-directory-p path neo-buffer--start-node)))) + +(defun neo-global--alone-p () + "Check whether the global neotree window is alone with some other window." + (let ((windows (window-list))) + (and (= (length windows) + 2) + (member neo-global--window windows)))) + +(defun neo-global--do-autorefresh () + "Do auto refresh." + (interactive) + (when (and neo-autorefresh (neo-global--window-exists-p) + (buffer-file-name)) + (neotree-refresh t))) + +(defun neo-global--open () + "Show the NeoTree window." + (let ((valid-start-node-p nil)) + (neo-global--with-buffer + (setf valid-start-node-p (neo-buffer--valid-start-node-p))) + (if (not valid-start-node-p) + (neo-global--open-dir (neo-path--get-working-dir)) + (neo-global--get-window t)))) + +(defun neo-global--open-dir (path) + "Show the NeoTree window, and change root to PATH." + (neo-global--get-window t) + (neo-global--with-buffer + (neo-buffer--change-root path))) + +(defun neo-global--open-and-find (path) + "Quick select node which specified PATH in NeoTree." + (let ((npath path) + root-dir) + (when (null npath) + (throw 'invalid-path "Invalid path to select.")) + (setq root-dir (if (file-directory-p npath) + npath (neo-path--updir npath))) + (when (or (not (neo-global--window-exists-p)) + (not (neo-global--file-in-root-p npath))) + (neo-global--open-dir root-dir)) + (neo-global--with-window + (neo-buffer--select-file-node npath t)))) + +(defun neo-global--select-mru-window (arg) + "Create or find a window to select when open a file node. +The description of ARG is in `neotree-enter'." + (when (eq (safe-length (window-list)) 1) + (neo-buffer--with-resizable-window + (split-window-horizontally))) + (when neo-reset-size-on-open + (neo-global--when-window + (neo-window--zoom 'minimize))) + ;; select target window + (cond + ;; select window with winum + ((and (integerp arg) + (bound-and-true-p winum-mode) + (fboundp 'winum-select-window-by-number)) + (winum-select-window-by-number arg)) + ;; select window with window numbering + ((and (integerp arg) + (boundp 'window-numbering-mode) + (symbol-value window-numbering-mode) + (fboundp 'select-window-by-number)) + (select-window-by-number arg)) + ;; open node in a new vertically split window + ((and (stringp arg) (string= arg "a") + (fboundp 'ace-select-window)) + (ace-select-window)) + ((and (stringp arg) (string= arg "|")) + (select-window (get-mru-window)) + (split-window-right) + (windmove-right)) + ;; open node in a new horizontally split window + ((and (stringp arg) (string= arg "-")) + (select-window (get-mru-window)) + (split-window-below) + (windmove-down))) + ;; open node in last active window + (select-window (get-mru-window))) + +(defun neo-global--detach () + "Detach the global neotree buffer." + (when neo-global--autorefresh-timer + (cancel-timer neo-global--autorefresh-timer)) + (neo-global--with-buffer + (neo-buffer--unlock-width)) + (setq neo-global--buffer nil) + (setq neo-global--window nil)) + +(defun neo-global--attach () + "Attach the global neotree buffer" + (when neo-global--autorefresh-timer + (cancel-timer neo-global--autorefresh-timer)) + (when neo-autorefresh + (setq neo-global--autorefresh-timer + (run-with-idle-timer 2 10 'neo-global--do-autorefresh))) + (setq neo-global--buffer (get-buffer neo-buffer-name)) + (setq neo-global--window (get-buffer-window + neo-global--buffer)) + (neo-global--with-buffer + (neo-buffer--lock-width)) + (run-hook-with-args 'neo-after-create-hook '(window))) + +(defun neo-global--set-window-width (width) + "Set neotree window width to WIDTH." + (neo-global--with-window + (neo-buffer--with-resizable-window + (neo-util--set-window-width (selected-window) width)))) + +(defun neo-global--reset-width () + "Set neotree window width to `neo-window-width'." + (neo-global--set-window-width neo-window-width)) + +;; +;; Advices +;; + +(defadvice mouse-drag-vertical-line + (around neotree-drag-vertical-line (start-event) activate) + "Drag and drop is not affected by the lock." + (neo-buffer--with-resizable-window + ad-do-it)) + +(defadvice balance-windows + (around neotree-balance-windows activate) + "Fix neotree inhibits balance-windows." + (if (neo-global--window-exists-p) + (let (old-width) + (neo-global--with-window + (setq old-width (window-width))) + (neo-buffer--with-resizable-window + ad-do-it) + (neo-global--with-window + (neo-global--set-window-width old-width))) + ad-do-it)) + +(eval-after-load 'popwin + '(progn + (defadvice popwin:create-popup-window + (around neotree/popwin-popup-buffer activate) + (let ((neo-exists-p (neo-global--window-exists-p))) + (when neo-exists-p + (neo-global--detach)) + ad-do-it + (when neo-exists-p + (neo-global--attach) + (neo-global--reset-width)))) + + (defadvice popwin:close-popup-window + (around neotree/popwin-close-popup-window activate) + (let ((neo-exists-p (neo-global--window-exists-p))) + (when neo-exists-p + (neo-global--detach)) + ad-do-it + (when neo-exists-p + (neo-global--attach) + (neo-global--reset-width)))))) + +;; +;; Hooks +;; + +(defun neo-hook--node-first-letter () + "Move point to the first letter of the current node." + (when (or (eq this-command 'next-line) + (eq this-command 'previous-line)) + (neo-point-auto-indent))) + +;; +;; Util methods +;; + +(defun neo-util--filter (condp lst) + "Apply CONDP to elements of LST keeping those that return non-nil. + +Example: + (neo-util--filter 'symbolp '(a \"b\" 3 d4)) + => (a d4) + +This procedure does not work when CONDP is the `null' function." + (delq nil + (mapcar (lambda (x) (and (funcall condp x) x)) lst))) + +(defun neo-util--find (where which) + "Find element of the list WHERE matching predicate WHICH." + (catch 'found + (dolist (elt where) + (when (funcall which elt) + (throw 'found elt))) + nil)) + +(defun neo-util--make-printable-string (string) + "Strip newline character from STRING, like 'Icon\n'." + (replace-regexp-in-string "\n" "" string)) + +(defun neo-util--walk-dir (path) + "Return the subdirectories and subfiles of the PATH." + (let* ((full-path (neo-path--file-truename path))) + (condition-case nil + (directory-files + path 'full directory-files-no-dot-files-regexp) + ('file-error + (message "Walk directory %S failed." path) + nil)))) + +(defun neo-util--hidden-path-filter (node) + "A filter function, if the NODE can not match each item in \ +`neo-hidden-regexp-list', return t." + (if (not neo-buffer--show-hidden-file-p) + (let ((shortname (neo-path--file-short-name node))) + (null (neo-util--filter + (lambda (x) (not (null (string-match-p x shortname)))) + neo-hidden-regexp-list))) + node)) + +(defun neo-str--trim-left (s) + "Remove whitespace at the beginning of S." + (if (string-match "\\`[ \t\n\r]+" s) + (replace-match "" t t s) + s)) + +(defun neo-str--trim-right (s) + "Remove whitespace at the end of S." + (if (string-match "[ \t\n\r]+\\'" s) + (replace-match "" t t s) + s)) + +(defun neo-str--trim (s) + "Remove whitespace at the beginning and end of S." + (neo-str--trim-left (neo-str--trim-right s))) + +(defun neo-path--expand-name (path &optional current-dir) + (expand-file-name (or (if (file-name-absolute-p path) path) + (let ((r-path path)) + (setq r-path (substitute-in-file-name r-path)) + (setq r-path (expand-file-name r-path current-dir)) + r-path)))) + +(defun neo-path--shorten (path len) + "Shorten a given PATH to a specified LEN. +This is needed for paths, which are to long for the window to display +completely. The function cuts of the first part of the path to remain +the last folder (the current one)." + (let ((result + (if (> (length path) len) + (concat "<" (substring path (- (- len 2)))) + path))) + (when result + (decode-coding-string result 'utf-8)))) + +(defun neo-path--insert-chroot-button (label path face) + (insert-button + label + 'action '(lambda (x) (neotree-change-root)) + 'follow-link t + 'face face + 'neo-full-path path)) + +(defun neo-path--insert-header-buttonized (path) + "Shortens the PATH to (window-body-width) and displays any \ +visible remains as buttons that, when clicked, navigate to that +parent directory." + (let* ((dirs (reverse (cl-maplist 'identity (reverse (split-string path "/" :omitnulls))))) + (last (car-safe (car-safe (last dirs))))) + (neo-path--insert-chroot-button "/" "/" 'neo-root-dir-face) + (dolist (dir dirs) + (if (string= (car dir) last) + (neo-buffer--insert-with-face last 'neo-root-dir-face) + (neo-path--insert-chroot-button + (concat (car dir) "/") + (apply 'neo-path--join (cons "/" (reverse dir))) + 'neo-root-dir-face)))) + ;;shorten the line if need be + (when (> (current-column) (window-body-width)) + (forward-char (- (window-body-width))) + (delete-region (point-at-bol) (point)) + (let* ((button (button-at (point))) + (path (if button (overlay-get button 'neo-full-path) "/"))) + (neo-path--insert-chroot-button "<" path 'neo-root-dir-face)) + (end-of-line))) + +(defun neo-path--updir (path) + (let ((r-path (neo-path--expand-name path))) + (if (and (> (length r-path) 0) + (equal (substring r-path -1) "/")) + (setq r-path (substring r-path 0 -1))) + (if (eq (length r-path) 0) + (setq r-path "/")) + (directory-file-name + (file-name-directory r-path)))) + +(defun neo-path--join (root &rest dirs) + "Joins a series of directories together with ROOT and DIRS. +Like Python's os.path.join, + (neo-path--join \"/tmp\" \"a\" \"b\" \"c\") => /tmp/a/b/c ." + (or (if (not dirs) root) + (let ((tdir (car dirs)) + (epath nil)) + (setq epath + (or (if (equal tdir ".") root) + (if (equal tdir "..") (neo-path--updir root)) + (neo-path--expand-name tdir root))) + (apply 'neo-path--join + epath + (cdr dirs))))) + +(defun neo-path--file-short-name (file) + "Base file/directory name by FILE. +Taken from http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg01238.html" + (or (if (string= file "/") "/") + (neo-util--make-printable-string (file-name-nondirectory (directory-file-name file))))) + +(defun neo-path--file-truename (path) + (let ((rlt (file-truename path))) + (if (not (null rlt)) + (progn + (if (and (file-directory-p rlt) + (> (length rlt) 0) + (not (equal (substring rlt -1) "/"))) + (setq rlt (concat rlt "/"))) + rlt) + nil))) + +(defun neo-path--has-subfile-p (dir) + "To determine whether a directory(DIR) contain files." + (and (file-exists-p dir) + (file-directory-p dir) + (neo-util--walk-dir dir) + t)) + +(defun neo-path--match-path-directory (path) + (let ((true-path (neo-path--file-truename path)) + (rlt-path nil)) + (setq rlt-path + (catch 'rlt + (if (file-directory-p true-path) + (throw 'rlt true-path)) + (setq true-path + (file-name-directory true-path)) + (if (file-directory-p true-path) + (throw 'rlt true-path)))) + (if (not (null rlt-path)) + (setq rlt-path (neo-path--join "." rlt-path "./"))) + rlt-path)) + +(defun neo-path--get-working-dir () + "Return a directory name of the current buffer." + (file-name-as-directory (file-truename default-directory))) + +(defun neo-path--strip (path) + "Remove whitespace at the end of PATH." + (let* ((rlt (neo-str--trim path)) + (pos (string-match "[\\\\/]+\\'" rlt))) + (when pos + (setq rlt (replace-match "" t t rlt)) + (when (eq (length rlt) 0) + (setq rlt "/"))) + rlt)) + +(defun neo-path--path-equal-p (path1 path2) + "Return non-nil if pathes PATH1 and PATH2 are the same path." + (string-equal (neo-path--strip path1) + (neo-path--strip path2))) + +(defun neo-path--file-equal-p (file1 file2) + "Return non-nil if files FILE1 and FILE2 name the same file. +If FILE1 or FILE2 does not exist, the return value is unspecified." + (unless (or (null file1) + (null file2)) + (let ((nfile1 (neo-path--strip file1)) + (nfile2 (neo-path--strip file2))) + (file-equal-p nfile1 nfile2)))) + +(defun neo-path--file-in-directory-p (file dir) + "Return non-nil if FILE is in DIR or a subdirectory of DIR. +A directory is considered to be \"in\" itself. +Return nil if DIR is not an existing directory." + (let ((nfile (neo-path--strip file)) + (ndir (neo-path--strip dir))) + (setq ndir (concat ndir "/")) + (file-in-directory-p nfile ndir))) + +(defun neo-util--kill-buffers-for-path (path) + "Kill all buffers for files in PATH." + (let ((buffer (find-buffer-visiting path))) + (when buffer + (kill-buffer buffer))) + (dolist (filename (directory-files path t directory-files-no-dot-files-regexp)) + (let ((buffer (find-buffer-visiting filename))) + (when buffer + (kill-buffer buffer)) + (when (and + (file-directory-p filename) + (neo-path--has-subfile-p filename)) + (neo-util--kill-buffers-for-path filename))))) + +(defun neo-util--set-window-width (window n) + "Make WINDOW N columns width." + (let ((w (max n window-min-width))) + (unless (null window) + (if (> (window-width) w) + (shrink-window-horizontally (- (window-width) w)) + (if (< (window-width) w) + (enlarge-window-horizontally (- w (window-width)))))))) + +(defun neo-point-auto-indent () + "Put the point on the first letter of the current node." + (when (neo-buffer--get-filename-current-line) + (beginning-of-line 1) + (re-search-forward "[^-\s+]" (line-end-position 1) t) + (backward-char 1))) + +(defun off-p (msg) + "Returns true regardless of message value in the argument." + t) + +(defun neo-sort-hidden-last (x y) + "Sort normally but with hidden files last." + (let ((x-hidden (neo-filepath-hidden-p x)) + (y-hidden (neo-filepath-hidden-p y))) + (cond + ((and x-hidden (not y-hidden)) + nil) + ((and (not x-hidden) y-hidden) + t) + (t + (string< x y))))) + +(defun neo-filepath-hidden-p (node) + "Return whether or not node is a hidden path." + (let ((shortname (neo-path--file-short-name node))) + (neo-util--filter + (lambda (x) (not (null (string-match-p x shortname)))) + neo-hidden-regexp-list))) + +(defun neo-get-unsaved-buffers-from-projectile () + "Return list of unsaved buffers from projectile buffers." + (interactive) + (let ((rlist '()) + (rtag t)) + (condition-case nil + (projectile-project-buffers) + (error (setq rtag nil))) + (when (and rtag (fboundp 'projectile-project-buffers)) + (dolist (buf (projectile-project-buffers)) + (with-current-buffer buf + (if (and (buffer-modified-p) buffer-file-name) + (setq rlist (cons (buffer-file-name) rlist)) + )))) + rlist)) + +;; +;; Buffer methods +;; + +(defun neo-buffer--newline-and-begin () + "Insert new line." + (newline) + (beginning-of-line)) + +(defun neo-buffer--get-icon (name) + "Get image by NAME." + (let ((icon-path (neo-path--join neo-dir "icons")) + image) + (setq image (create-image + (neo-path--join icon-path (concat name ".xpm")) + 'xpm nil :ascent 'center :mask '(heuristic t))) + image)) + +(defun neo-buffer--insert-fold-symbol (name &optional node-name) + "Write icon by NAME, the icon style affected by neo-theme. +`open' write opened folder icon. +`close' write closed folder icon. +`leaf' write leaf icon. +Optional NODE-NAME is used for the `icons' theme" + (let ((n-insert-image (lambda (n) + (insert-image (neo-buffer--get-icon n)))) + (n-insert-symbol (lambda (n) + (neo-buffer--insert-with-face + n 'neo-expand-btn-face)))) + (cond + ((and (display-graphic-p) (equal neo-theme 'classic)) + (or (and (equal name 'open) (funcall n-insert-image "open")) + (and (equal name 'close) (funcall n-insert-image "close")) + (and (equal name 'leaf) (funcall n-insert-image "leaf")))) + ((equal neo-theme 'arrow) + (or (and (equal name 'open) (funcall n-insert-symbol "▾")) + (and (equal name 'close) (funcall n-insert-symbol "▸")))) + ((equal neo-theme 'nerd) + (or (and (equal name 'open) (funcall n-insert-symbol "▾ ")) + (and (equal name 'close) (funcall n-insert-symbol "▸ ")) + (and (equal name 'leaf) (funcall n-insert-symbol " ")))) + ((and (display-graphic-p) (equal neo-theme 'icons)) + (unless (require 'all-the-icons nil 'noerror) + (error "Package `all-the-icons' isn't installed")) + (setq-local tab-width 1) + (or (and (equal name 'open) (insert (all-the-icons-icon-for-dir-with-chevron (directory-file-name node-name) "down"))) + (and (equal name 'close) (insert (all-the-icons-icon-for-dir-with-chevron (directory-file-name node-name) "right"))) + (and (equal name 'leaf) (insert (format "\t\t\t%s\t" (all-the-icons-icon-for-file node-name)))))) + (t + (or (and (equal name 'open) (funcall n-insert-symbol "- ")) + (and (equal name 'close) (funcall n-insert-symbol "+ "))))))) + +(defun neo-buffer--save-cursor-pos (&optional node-path line-pos) + "Save cursor position. +If NODE-PATH and LINE-POS is nil, it will be save the current line node position." + (let ((cur-node-path nil) + (cur-line-pos nil) + (ws-wind (selected-window)) + (ws-pos (window-start))) + (setq cur-node-path (if node-path + node-path + (neo-buffer--get-filename-current-line))) + (setq cur-line-pos (if line-pos + line-pos + (line-number-at-pos))) + (setq neo-buffer--cursor-pos (cons cur-node-path cur-line-pos)) + (setq neo-buffer--last-window-pos (cons ws-wind ws-pos)))) + +(defun neo-buffer--goto-cursor-pos () + "Jump to saved cursor position." + (let ((line-pos nil) + (node (car neo-buffer--cursor-pos)) + (line-pos (cdr neo-buffer--cursor-pos)) + (ws-wind (car neo-buffer--last-window-pos)) + (ws-pos (cdr neo-buffer--last-window-pos))) + (catch 'line-pos-founded + (unless (null node) + (setq line-pos 0) + (mapc + (lambda (x) + (setq line-pos (1+ line-pos)) + (unless (null x) + (when (neo-path--path-equal-p x node) + (throw 'line-pos-founded line-pos)))) + neo-buffer--node-list)) + (setq line-pos (cdr neo-buffer--cursor-pos)) + (throw 'line-pos-founded line-pos)) + ;; goto line + (goto-char (point-min)) + (neo-buffer--forward-line (1- line-pos)) + ;; scroll window + (when (equal (selected-window) ws-wind) + (set-window-start ws-wind ws-pos t)))) + +(defun neo-buffer--node-list-clear () + "Clear node list." + (setq neo-buffer--node-list nil)) + +(defun neo-buffer--node-list-set (line-num path) + "Set value in node list. +LINE-NUM is the index of node list. +PATH is value." + (let ((node-list-length (length neo-buffer--node-list)) + (node-index line-num)) + (when (null node-index) + (setq node-index (line-number-at-pos))) + (when (< node-list-length node-index) + (setq neo-buffer--node-list + (vconcat neo-buffer--node-list + (make-vector (- node-index node-list-length) nil)))) + (aset neo-buffer--node-list (1- node-index) path)) + neo-buffer--node-list) + +(defun neo-buffer--insert-with-face (content face) + (let ((pos-start (point))) + (insert content) + (set-text-properties pos-start + (point) + (list 'face face)))) + +(defun neo-buffer--valid-start-node-p () + (and (not (null neo-buffer--start-node)) + (file-accessible-directory-p neo-buffer--start-node))) + +(defun neo-buffer--create () + "Create and switch to NeoTree buffer." + (switch-to-buffer + (generate-new-buffer-name neo-buffer-name)) + (neotree-mode) + ;; disable linum-mode + (when (and (boundp 'linum-mode) + (not (null linum-mode))) + (linum-mode -1)) + ;; Use inside helm window in NeoTree + ;; Refs https://github.com/jaypei/emacs-neotree/issues/226 + (setq-local helm-split-window-inside-p t) + (current-buffer)) + +(defun neo-buffer--insert-banner () + (unless (null neo-banner-message) + (let ((start (point))) + (insert neo-banner-message) + (set-text-properties start (point) '(face neo-banner-face))) + (neo-buffer--newline-and-begin))) + +(defun neo-buffer--insert-root-entry (node) + (neo-buffer--node-list-set nil node) + (cond ((eq neo-cwd-line-style 'button) + (neo-path--insert-header-buttonized node)) + (t + (neo-buffer--insert-with-face (neo-path--shorten node (window-body-width)) + 'neo-root-dir-face))) + (neo-buffer--newline-and-begin) + (when neo-show-updir-line + (neo-buffer--insert-fold-symbol 'close node) + (insert-button ".." + 'action '(lambda (x) (neotree-change-root)) + 'follow-link t + 'face neo-dir-link-face + 'neo-full-path (neo-path--updir node)) + (neo-buffer--newline-and-begin))) + +(defun neo-buffer--help-echo-message (node-name) + (cond + ((eq neo-help-echo-style 'default) + (if (<= (+ (current-column) (string-width node-name)) + neo-window-width) + nil + node-name)) + (t nil))) + +(defun neo-buffer--insert-dir-entry (node depth expanded) + (let ((node-short-name (neo-path--file-short-name node))) + (insert-char ?\s (* (- depth 1) 2)) ; indent + (when (memq 'char neo-vc-integration) + (insert-char ?\s 2)) + (neo-buffer--insert-fold-symbol + (if expanded 'open 'close) node) + (insert-button (if neo-show-slash-for-folder (concat node-short-name "/") node-short-name) + 'follow-link t + 'face neo-dir-link-face + 'neo-full-path node + 'keymap neotree-dir-button-keymap + 'help-echo (neo-buffer--help-echo-message node-short-name)) + (neo-buffer--node-list-set nil node) + (neo-buffer--newline-and-begin))) + +(defun neo-buffer--insert-file-entry (node depth) + (let ((node-short-name (neo-path--file-short-name node)) + (vc (when neo-vc-integration (neo-vc-for-node node)))) + (insert-char ?\s (* (- depth 1) 2)) ; indent + (when (memq 'char neo-vc-integration) + (insert-char (car vc)) + (insert-char ?\s)) + (neo-buffer--insert-fold-symbol 'leaf node-short-name) + (insert-button node-short-name + 'follow-link t + 'face (if (memq 'face neo-vc-integration) + (cdr vc) + neo-file-link-face) + 'neo-full-path node + 'keymap neotree-file-button-keymap + 'help-echo (neo-buffer--help-echo-message node-short-name)) + (neo-buffer--node-list-set nil node) + (neo-buffer--newline-and-begin))) + +(defun neo-vc-for-node (node) + (let* ((backend (ignore-errors + (vc-responsible-backend node))) + (vc-state (when backend (vc-state node backend)))) + (cons (cdr (assoc vc-state neo-vc-state-char-alist)) + (cl-case vc-state + (up-to-date neo-vc-up-to-date-face) + (edited neo-vc-edited-face) + (needs-update neo-vc-needs-update-face) + (needs-merge neo-vc-needs-merge-face) + (unlocked-changes neo-vc-unlocked-changes-face) + (added neo-vc-added-face) + (removed neo-vc-removed-face) + (conflict neo-vc-conflict-face) + (missing neo-vc-missing-face) + (ignored neo-vc-ignored-face) + (unregistered neo-vc-unregistered-face) + (user neo-vc-user-face) + (otherwise neo-vc-default-face))))) + +(defun neo-buffer--get-nodes (path) + (let* ((nodes (neo-util--walk-dir path)) + (comp neo-filepath-sort-function) + (nodes (neo-util--filter 'neo-util--hidden-path-filter nodes))) + (cons (sort (neo-util--filter 'file-directory-p nodes) comp) + (sort (neo-util--filter #'(lambda (f) (not (file-directory-p f))) nodes) comp)))) + +(defun neo-buffer--get-node-index (node nodes) + "Return the index of NODE in NODES. + +NODES can be a list of directory or files. +Return nil if NODE has not been found in NODES." + (let ((i 0) + (l (length nodes)) + (cur (car nodes)) + (rest (cdr nodes))) + (while (and cur (not (equal cur node))) + (setq i (1+ i)) + (setq cur (car rest)) + (setq rest (cdr rest))) + (if (< i l) i))) + +(defun neo-buffer--expanded-node-p (node) + "Return non-nil if NODE is expanded." + (neo-util--to-bool + (neo-util--find + neo-buffer--expanded-node-list + #'(lambda (x) (equal x node))))) + +(defun neo-buffer--set-expand (node do-expand) + "Set the expanded state of the NODE to DO-EXPAND. +Return the new expand state for NODE (t for expanded, nil for collapsed)." + (if (not do-expand) + (setq neo-buffer--expanded-node-list + (neo-util--filter + #'(lambda (x) (not (equal node x))) + neo-buffer--expanded-node-list)) + (push node neo-buffer--expanded-node-list)) + do-expand) + +(defun neo-buffer--toggle-expand (node) + (neo-buffer--set-expand node (not (neo-buffer--expanded-node-p node)))) + +(defun neo-buffer--insert-tree (path depth) + (if (eq depth 1) + (neo-buffer--insert-root-entry path)) + (let* ((contents (neo-buffer--get-nodes path)) + (nodes (car contents)) + (leafs (cdr contents)) + (default-directory path)) + (dolist (node nodes) + (let ((expanded (neo-buffer--expanded-node-p node))) + (neo-buffer--insert-dir-entry + node depth expanded) + (if expanded (neo-buffer--insert-tree (concat node "/") (+ depth 1))))) + (dolist (leaf leafs) + (neo-buffer--insert-file-entry leaf depth)))) + +(defun neo-buffer--refresh (save-pos-p &optional non-neotree-buffer) + "Refresh the NeoTree buffer. +If SAVE-POS-P is non-nil, it will be auto save current line number." + (let ((start-node neo-buffer--start-node)) + (unless start-node + (setq start-node default-directory)) + (neo-buffer--with-editing-buffer + ;; save context + (when save-pos-p + (neo-buffer--save-cursor-pos)) + (when non-neotree-buffer + (setq neo-buffer--start-node start-node)) + ;; starting refresh + (erase-buffer) + (neo-buffer--node-list-clear) + (neo-buffer--insert-banner) + (setq neo-buffer--start-line neo-header-height) + (neo-buffer--insert-tree start-node 1)) + ;; restore context + (neo-buffer--goto-cursor-pos))) + +(defun neo-buffer--post-move () + "Reset current directory when position moved." + (funcall + (neotree-make-executor + :file-fn + '(lambda (path _) + (setq default-directory (neo-path--updir btn-full-path))) + :dir-fn + '(lambda (path _) + (setq default-directory (file-name-as-directory path)))))) + +(defun neo-buffer--get-button-current-line () + "Return the first button in current line." + (let* ((btn-position nil) + (pos-line-start (line-beginning-position)) + (pos-line-end (line-end-position)) + ;; NOTE: cannot find button when the button + ;; at beginning of the line + (current-button (or (button-at (point)) + (button-at pos-line-start)))) + (if (null current-button) + (progn + (setf btn-position + (catch 'ret-button + (let* ((next-button (next-button pos-line-start)) + (pos-btn nil)) + (if (null next-button) (throw 'ret-button nil)) + (setf pos-btn (overlay-start next-button)) + (if (> pos-btn pos-line-end) (throw 'ret-button nil)) + (throw 'ret-button pos-btn)))) + (if (null btn-position) + nil + (setf current-button (button-at btn-position))))) + current-button)) + +(defun neo-buffer--get-filename-current-line (&optional default) + "Return filename for first button in current line. +If there is no button in current line, then return DEFAULT." + (let ((btn (neo-buffer--get-button-current-line))) + (if (not (null btn)) + (button-get btn 'neo-full-path) + default))) + +(defun neo-buffer--lock-width () + "Lock the width size for NeoTree window." + (if neo-window-fixed-size + (setq window-size-fixed 'width))) + +(defun neo-buffer--unlock-width () + "Unlock the width size for NeoTree window." + (setq window-size-fixed nil)) + +(defun neo-buffer--rename-node () + "Rename current node as another path." + (interactive) + (let* ((current-path (neo-buffer--get-filename-current-line)) + (buffer (find-buffer-visiting current-path)) + to-path + msg) + (unless (null current-path) + (setq msg (format "Rename [%s] to: " (neo-path--file-short-name current-path))) + (setq to-path (read-file-name msg (file-name-directory current-path))) + (if buffer + (with-current-buffer buffer + (set-visited-file-name to-path nil t))) + (if (vc-registered current-path) + (vc-rename-file current-path to-path) + (rename-file current-path to-path 1)) + (neo-buffer--refresh t) + (message "Rename successful.")))) + +(defun neo-buffer--copy-node () + "Copies current node as another path." + (interactive) + (let* ((current-path (neo-buffer--get-filename-current-line)) + (buffer (find-buffer-visiting current-path)) + to-path + msg) + (unless (null current-path) + (setq msg (format "Copy [%s] to: " (neo-path--file-short-name current-path))) + (setq to-path (read-file-name msg (file-name-directory current-path))) + (if (file-directory-p current-path) + (copy-directory current-path to-path) + (copy-file current-path to-path)) + (neo-buffer--refresh t) + (message "Copy successful.")))) + +(defun neo-buffer--select-file-node (file &optional recursive-p) + "Select the node that corresponds to the FILE. +If RECURSIVE-P is non nil, find files will recursively." + (let ((efile file) + (iter-curr-dir nil) + (file-node-find-p nil) + (file-node-list nil)) + (unless (file-name-absolute-p efile) + (setq efile (expand-file-name efile))) + (setq iter-curr-dir efile) + (catch 'return + (while t + (setq iter-curr-dir (neo-path--updir iter-curr-dir)) + (push iter-curr-dir file-node-list) + (when (neo-path--file-equal-p iter-curr-dir neo-buffer--start-node) + (setq file-node-find-p t) + (throw 'return nil)) + (let ((niter-curr-dir (file-remote-p iter-curr-dir 'localname))) + (unless niter-curr-dir + (setq niter-curr-dir iter-curr-dir)) + (when (neo-path--file-equal-p niter-curr-dir "/") + (setq file-node-find-p nil) + (throw 'return nil))))) + (when file-node-find-p + (dolist (p file-node-list) + (neo-buffer--set-expand p t)) + (neo-buffer--save-cursor-pos file) + (neo-buffer--refresh nil)))) + +(defun neo-buffer--change-root (root-dir) + "Change the tree root to ROOT-DIR." + (let ((path root-dir) + start-path) + (unless (and (file-exists-p path) + (file-directory-p path)) + (throw 'error "The path is not a valid directory.")) + (setq start-path (expand-file-name (substitute-in-file-name path))) + (setq neo-buffer--start-node start-path) + (cd start-path) + (neo-buffer--save-cursor-pos path nil) + (neo-buffer--refresh nil))) + +(defun neo-buffer--get-nodes-for-select-down-node (path) + "Return the node list for the down dir selection." + (if path + (when (file-name-directory path) + (if (neo-buffer--expanded-node-p path) + (neo-buffer--get-nodes path) + (neo-buffer--get-nodes (file-name-directory path)))) + (neo-buffer--get-nodes (file-name-as-directory neo-buffer--start-node)))) + +(defun neo-buffer--get-nodes-for-sibling (path) + "Return the node list for the sibling selection. Return nil of no nodes can +be found. +The returned list is a directory list if path is a directory, otherwise it is +a file list." + (when path + (let ((nodes (neo-buffer--get-nodes (file-name-directory path)))) + (if (file-directory-p path) + (car nodes) + (cdr nodes))))) + +(defun neo-buffer--sibling (path &optional previous) + "Return the next sibling of node PATH. +If PREVIOUS is non-nil the previous sibling is returned." + (let* ((nodes (neo-buffer--get-nodes-for-sibling path))) + (when nodes + (let ((i (neo-buffer--get-node-index path nodes)) + (l (length nodes))) + (if i (nth (mod (+ i (if previous -1 1)) l) nodes)))))) + +(defun neo-buffer--execute (arg &optional file-fn dir-fn) + "Define the behaviors for keyboard event. +ARG is the parameter for command. +If FILE-FN is non-nil, it will executed when a file node. +If DIR-FN is non-nil, it will executed when a dir node." + (interactive "P") + (let* ((btn-full-path (neo-buffer--get-filename-current-line)) + is-file-p + enter-fn) + (unless (null btn-full-path) + (setq is-file-p (not (file-directory-p btn-full-path)) + enter-fn (if is-file-p file-fn dir-fn)) + (unless (null enter-fn) + (funcall enter-fn btn-full-path arg) + (run-hook-with-args + 'neo-enter-hook + (if is-file-p 'file 'directory) + btn-full-path + arg))) + btn-full-path)) + +(defun neo-buffer--set-show-hidden-file-p (show-p) + "If SHOW-P is non-nil, show hidden nodes in tree." + (setq neo-buffer--show-hidden-file-p show-p) + (neo-buffer--refresh t)) + +(defun neo-buffer--forward-line (n) + "Move N lines forward in NeoTree buffer." + (forward-line (or n 1)) + (neo-buffer--post-move)) + +;; +;; Mode-line methods +;; + +(defun neo-mode-line--compute-format (parent index ndirs nfiles) + "Return a formated string to be used in the `neotree' mode-line." + (let* ((nall (+ ndirs nfiles)) + (has-dirs (> ndirs 0)) + (has-files (> nfiles 0)) + (msg-index (when index (format "[%s/%s] " index nall))) + (msg-ndirs (when has-dirs (format (if has-files " (D:%s" " (D:%s)") ndirs))) + (msg-nfiles (when has-files (format (if has-dirs " F:%s)" " (F:%s)") nfiles))) + (msg-directory (file-name-nondirectory (directory-file-name parent))) + (msg-directory-max-length (- (window-width) + (length msg-index) + (length msg-ndirs) + (length msg-nfiles)))) + (setq msg-directory (if (<= (length msg-directory) msg-directory-max-length) + msg-directory + (concat (substring msg-directory + 0 (- msg-directory-max-length 3)) + "..."))) + (propertize + (decode-coding-string (concat msg-index msg-directory msg-ndirs msg-nfiles) 'utf-8) + 'help-echo (decode-coding-string parent 'utf-8)))) + +;; +;; Window methods +;; + +(defun neo-window--init (window buffer) + "Make WINDOW a NeoTree window. +NeoTree buffer is BUFFER." + (neo-buffer--with-resizable-window + (switch-to-buffer buffer) + (set-window-parameter window 'no-delete-other-windows t) + (set-window-dedicated-p window t)) + window) + +(defun neo-window--zoom (method) + "Zoom the NeoTree window, the METHOD should one of these options: +'maximize 'minimize 'zoom-in 'zoom-out." + (neo-buffer--unlock-width) + (cond + ((eq method 'maximize) + (maximize-window)) + ((eq method 'minimize) + (neo-util--set-window-width (selected-window) neo-window-width)) + ((eq method 'zoom-in) + (shrink-window-horizontally 2)) + ((eq method 'zoom-out) + (enlarge-window-horizontally 2))) + (neo-buffer--lock-width)) + +(defun neo-window--minimize-p () + "Return non-nil when the NeoTree window is minimize." + (<= (window-width) neo-window-width)) + +;; +;; Interactive functions +;; + +(defun neotree-next-line (&optional count) + "Move next line in NeoTree buffer. +Optional COUNT argument, moves COUNT lines down." + (interactive "p") + (neo-buffer--forward-line (or count 1))) + +(defun neotree-previous-line (&optional count) + "Move previous line in NeoTree buffer. +Optional COUNT argument, moves COUNT lines up." + (interactive "p") + (neo-buffer--forward-line (- (or count 1)))) + +;;;###autoload +(defun neotree-find (&optional path default-path) + "Quick select node which specified PATH in NeoTree. +If path is nil and no buffer file name, then use DEFAULT-PATH," + (interactive) + (let* ((ndefault-path (if default-path default-path + (neo-path--get-working-dir))) + (npath (if path path + (or (buffer-file-name) ndefault-path))) + (do-open-p nil)) + (if (and (not neo-force-change-root) + (not (neo-global--file-in-root-p npath)) + (neo-global--window-exists-p)) + (setq do-open-p (funcall neo-confirm-change-root "File not found in root path, do you want to change root?")) + (setq do-open-p t)) + (when do-open-p + (neo-global--open-and-find npath)) + (when neo-auto-indent-point + (neo-point-auto-indent))) + (neo-global--select-window)) + +(defun neotree-click-changes-root-toggle () + "Toggle the variable neo-click-changes-root. +If true, clicking on a directory will change the current root to +the directory instead of showing the directory contents." + (interactive) + (setq neo-click-changes-root (not neo-click-changes-root))) + +(defun neo-open-dir (full-path &optional arg) + "Toggle fold a directory node. + +FULL-PATH is the path of the directory. +ARG is ignored." + (if neo-click-changes-root + (neotree-change-root) + (progn + (let ((new-state (neo-buffer--toggle-expand full-path))) + (neo-buffer--refresh t) + (when neo-auto-indent-point + (when new-state (forward-line 1)) + (neo-point-auto-indent)))))) + + +(defun neo--expand-recursive (path state) + "Set the state of children recursively. + +The children of PATH will have state STATE." + (let ((children (car (neo-buffer--get-nodes path) ))) + (dolist (node children) + (neo-buffer--set-expand node state) + (neo--expand-recursive node state )))) + +(defun neo-open-dir-recursive (full-path &optional arg) + "Toggle fold a directory node recursively. + +The children of the node will also be opened recursively. +FULL-PATH is the path of the directory. +ARG is ignored." + (if neo-click-changes-root + (neotree-change-root) + (let ((new-state (neo-buffer--toggle-expand full-path)) + (children (car (neo-buffer--get-nodes full-path)))) + (dolist (node children) + (neo-buffer--set-expand node new-state) + (neo--expand-recursive node new-state)) + (neo-buffer--refresh t)))) + +(defun neo-open-dired (full-path &optional arg) + "Open file or directory node in `dired-mode'. + +FULL-PATH is the path of node. +ARG is same as `neo-open-file'." + (neo-global--select-mru-window arg) + (dired full-path)) + +(defun neo-open-file (full-path &optional arg) + "Open a file node. + +FULL-PATH is the file path you want to open. +If ARG is an integer then the node is opened in a window selected via +`winum' or`window-numbering' (if available) according to the passed number. +If ARG is `|' then the node is opened in new vertically split window. +If ARG is `-' then the node is opened in new horizontally split window." + (neo-global--select-mru-window arg) + (find-file full-path)) + +(defun neo-open-file-vertical-split (full-path arg) + "Open the current node is a vertically split window. +FULL-PATH and ARG are the same as `neo-open-file'." + (neo-open-file full-path "|")) + +(defun neo-open-file-horizontal-split (full-path arg) + "Open the current node is horizontally split window. +FULL-PATH and ARG are the same as `neo-open-file'." + (neo-open-file full-path "-")) + +(defun neo-open-file-ace-window (full-path arg) + "Open the current node in a window chosen by ace-window. +FULL-PATH and ARG are the same as `neo-open-file'." + (neo-open-file full-path "a")) + +(defun neotree-open-file-in-system-application () + "Open a file under point in the system application." + (interactive) + (call-process neo-default-system-application nil 0 nil + (neo-buffer--get-filename-current-line))) + +(defun neotree-change-root () + "Change root to current node dir. +If current node is a file, then it will do nothing. +If cannot find any node in current line, it equivalent to using `neotree-dir'." + (interactive) + (neo-global--select-window) + (let ((btn-full-path (neo-buffer--get-filename-current-line))) + (if (null btn-full-path) + (call-interactively 'neotree-dir) + (neo-global--open-dir btn-full-path)))) + +(defun neotree-select-up-node () + "Select the parent directory of the current node. Change the root if +necessary. " + (interactive) + (neo-global--select-window) + (let* ((btn-full-path (neo-buffer--get-filename-current-line)) + (btn-parent-dir (if btn-full-path (file-name-directory btn-full-path))) + (root-slash (file-name-as-directory neo-buffer--start-node))) + (cond + ((equal btn-parent-dir root-slash) (neo-global--open-dir root-slash)) + (btn-parent-dir (neotree-find btn-parent-dir)) + (t (neo-global--open-dir (file-name-directory + (directory-file-name root-slash))))))) + +(defun neotree-select-down-node () + "Select an expanded directory or content directory according to the +current node, in this order: +- select the first expanded child node if the current node has one +- select the content of current node if it is expanded +- select the next expanded sibling if the current node is not expanded." + (interactive) + (let* ((btn-full-path (neo-buffer--get-filename-current-line)) + (path (if btn-full-path btn-full-path neo-buffer--start-node)) + (nodes (neo-buffer--get-nodes-for-select-down-node path))) + (when nodes + (if (or (equal path neo-buffer--start-node) + (neo-buffer--expanded-node-p path)) + ;; select the first expanded child node + (let ((expanded-dir (catch 'break + (dolist (node (car nodes)) + (if (neo-buffer--expanded-node-p node) + (throw 'break node))) + nil))) + (if expanded-dir + (neotree-find expanded-dir) + ;; select the directory content if needed + (let ((dirs (car nodes)) + (files (cdr nodes))) + (if (> (length dirs) 0) + (neotree-find (car dirs)) + (when (> (length files) 0) + (neotree-find (car files))))))) + ;; select the next expanded sibling + (let ((sibling (neo-buffer--sibling path))) + (while (and (not (neo-buffer--expanded-node-p sibling)) + (not (equal sibling path))) + (setq sibling (neo-buffer--sibling sibling))) + (when (not (string< sibling path)) + ;; select next expanded sibling + (neotree-find sibling))))))) + +(defun neotree-select-next-sibling-node () + "Select the next sibling of current node. +If the current node is the last node then the first node is selected." + (interactive) + (let ((sibling (neo-buffer--sibling (neo-buffer--get-filename-current-line)))) + (when sibling (neotree-find sibling)))) + +(defun neotree-select-previous-sibling-node () + "Select the previous sibling of current node. +If the current node is the first node then the last node is selected." + (interactive) + (let ((sibling (neo-buffer--sibling (neo-buffer--get-filename-current-line) t))) + (when sibling (neotree-find sibling)))) + +(defun neotree-create-node (filename) + "Create a file or directory use specified FILENAME in current node." + (interactive + (let* ((current-dir (neo-buffer--get-filename-current-line neo-buffer--start-node)) + (current-dir (neo-path--match-path-directory current-dir)) + (filename (read-file-name "Filename:" current-dir))) + (if (file-directory-p filename) + (setq filename (concat filename "/"))) + (list filename))) + (catch 'rlt + (let ((is-file nil)) + (when (= (length filename) 0) + (throw 'rlt nil)) + (setq is-file (not (equal (substring filename -1) "/"))) + (when (file-exists-p filename) + (message "File %S already exists." filename) + (throw 'rlt nil)) + (when (and is-file + (funcall neo-confirm-create-file (format "Do you want to create file %S ?" + filename))) + ;; ensure parent directory exist before saving + (mkdir (substring filename 0 (+ 1 (cl-position ?/ filename :from-end t))) t) + ;; NOTE: create a empty file + (write-region "" nil filename) + (neo-buffer--save-cursor-pos filename) + (neo-buffer--refresh nil) + (if neo-create-file-auto-open + (find-file-other-window filename))) + (when (and (not is-file) + (funcall neo-confirm-create-directory (format "Do you want to create directory %S?" + filename))) + (mkdir filename t) + (neo-buffer--save-cursor-pos filename) + (neo-buffer--refresh nil))))) + +(defun neotree-delete-node () + "Delete current node." + (interactive) + (let* ((filename (neo-buffer--get-filename-current-line)) + (buffer (find-buffer-visiting filename)) + (deleted-p nil) + (trash delete-by-moving-to-trash)) + (catch 'end + (if (null filename) (throw 'end nil)) + (if (not (file-exists-p filename)) (throw 'end nil)) + (if (not (funcall neo-confirm-delete-file (format "Do you really want to delete %S?" + filename))) + (throw 'end nil)) + (if (file-directory-p filename) + ;; delete directory + (progn + (unless (neo-path--has-subfile-p filename) + (delete-directory filename nil trash) + (setq deleted-p t) + (throw 'end nil)) + (when (funcall neo-confirm-delete-directory-recursively + (format "%S is a directory, delete it recursively?" + filename)) + (when (funcall neo-confirm-kill-buffers-for-files-in-directory + (format "kill buffers for files in directory %S?" + filename)) + (neo-util--kill-buffers-for-path filename)) + (delete-directory filename t trash) + (setq deleted-p t))) + ;; delete file + (progn + (delete-file filename trash) + (when buffer + (kill-buffer-ask buffer)) + (setq deleted-p t)))) + (when deleted-p + (message "%S deleted." filename) + (neo-buffer--refresh t)) + filename)) + +(defun neotree-rename-node () + "Rename current node." + (interactive) + (neo-buffer--rename-node)) + +(defun neotree-copy-node () + "Copy current node." + (interactive) + (neo-buffer--copy-node)) + +(defun neotree-hidden-file-toggle () + "Toggle show hidden files." + (interactive) + (neo-buffer--set-show-hidden-file-p (not neo-buffer--show-hidden-file-p))) + +(defun neotree-empty-fn () + "Used to bind the empty function to the shortcut." + (interactive)) + +(defun neotree-refresh (&optional is-auto-refresh) + "Refresh the NeoTree buffer." + (interactive) + (if (eq (current-buffer) (neo-global--get-buffer)) + (neo-buffer--refresh t) + (save-excursion + (let ((cw (selected-window))) ;; save current window + (if is-auto-refresh + (let ((origin-buffer-file-name (buffer-file-name))) + (when (and (fboundp 'projectile-project-p) + (projectile-project-p) + (fboundp 'projectile-project-root)) + (neo-global--open-dir (projectile-project-root)) + (neotree-find (projectile-project-root))) + (neotree-find origin-buffer-file-name)) + (neo-buffer--refresh t t)) + (recenter) + (when (or is-auto-refresh neo-toggle-window-keep-p) + (select-window cw)))))) + +(defun neotree-stretch-toggle () + "Make the NeoTree window toggle maximize/minimize." + (interactive) + (neo-global--with-window + (if (neo-window--minimize-p) + (neo-window--zoom 'maximize) + (neo-window--zoom 'minimize)))) + +(defun neotree-collapse-all () + (interactive) + "Collapse all expanded folders in the neotree buffer" + (setq list-of-expanded-folders neo-buffer--expanded-node-list) + (dolist (folder list-of-expanded-folders) + (neo-buffer--toggle-expand folder) + (neo-buffer--refresh t) + ) + ) +;;;###autoload +(defun neotree-projectile-action () + "Integration with `Projectile'. + +Usage: + (setq projectile-switch-project-action 'neotree-projectile-action). + +When running `projectile-switch-project' (C-c p p), `neotree' will change root +automatically." + (interactive) + (cond + ((fboundp 'projectile-project-root) + (neotree-dir (projectile-project-root))) + (t + (error "Projectile is not available")))) + +;;;###autoload +(defun neotree-toggle () + "Toggle show the NeoTree window." + (interactive) + (if (neo-global--window-exists-p) + (neotree-hide) + (neotree-show))) + +;;;###autoload +(defun neotree-show () + "Show the NeoTree window." + (interactive) + (let ((cw (selected-window)) + (path (buffer-file-name))) ;; save current window and buffer + (if neo-smart-open + (progn + (when (and (fboundp 'projectile-project-p) + (projectile-project-p) + (fboundp 'projectile-project-root)) + (neotree-dir (projectile-project-root))) + (neotree-find path)) + (neo-global--open)) + (neo-global--select-window) + (when neo-toggle-window-keep-p + (select-window cw)))) + +;;;###autoload +(defun neotree-hide () + "Close the NeoTree window." + (interactive) + (if (neo-global--window-exists-p) + (delete-window neo-global--window))) + +;;;###autoload +(defun neotree-dir (path) + "Show the NeoTree window, and change root to PATH." + (interactive "DDirectory: ") + (neo-global--open-dir path) + (neo-global--select-window)) + +;;;###autoload +(defalias 'neotree 'neotree-show "Show the NeoTree window.") + +;; +;; backward compatible +;; + +(defun neo-bc--make-obsolete-message (from to) + (message "Warning: `%S' is obsolete. Use `%S' instead." from to)) + +(defun neo-buffer--enter-file (path) + (neo-bc--make-obsolete-message 'neo-buffer--enter-file 'neo-open-file)) + +(defun neo-buffer--enter-dir (path) + (neo-bc--make-obsolete-message 'neo-buffer--enter-dir 'neo-open-dir)) + +(defun neotree-enter (&optional arg) + "NeoTree typical open event. +ARG are the same as `neo-open-file'." + (interactive "P") + (neo-buffer--execute arg 'neo-open-file 'neo-open-dir)) + +(defun neotree-quick-look (&optional arg) + "Quick Look like NeoTree open event. +ARG are the same as `neo-open-file'." + (interactive "P") + (neotree-enter arg) + (neo-global--select-window)) + +(defun neotree-enter-vertical-split () + "NeoTree open event, file node will opened in new vertically split window." + (interactive) + (neo-buffer--execute nil 'neo-open-file-vertical-split 'neo-open-dir)) + +(defun neotree-enter-horizontal-split () + "NeoTree open event, file node will opened in new horizontally split window." + (interactive) + (neo-buffer--execute nil 'neo-open-file-horizontal-split 'neo-open-dir)) + +(defun neotree-enter-ace-window () + "NeoTree open event, file node will be opened in window chosen by ace-window." + (interactive) + (neo-buffer--execute nil 'neo-open-file-ace-window 'neo-open-dir)) + +(defun neotree-copy-filepath-to-yank-ring () + "Neotree convenience interactive function: file node path will be added to the kill ring." + (interactive) + (kill-new (neo-buffer--get-filename-current-line))) + +(defun neotree-split-window-sensibly (&optional window) + "An neotree-version of split-window-sensibly, +which is used to fix issue #209. +(setq split-window-preferred-function 'neotree-split-window-sensibly)" + (let ((window (or window (selected-window)))) + (or (split-window-sensibly window) + (and (get-buffer-window neo-buffer-name) + (not (window-minibuffer-p window)) + ;; If WINDOW is the only window on its frame + ;; (or only include Neo window) and is not the + ;; minibuffer window, try to split it vertically disregarding + ;; the value of `split-height-threshold'. + (let ((split-height-threshold 0)) + (when (window-splittable-p window) + (with-selected-window window + (split-window-below)))))))) + +(provide 'neotree) +;;; neotree.el ends here + diff --git a/site-lisp/extensions-local/scroll-next-window.el b/site-lisp/extensions-local/scroll-next-window.el new file mode 100644 index 0000000..c4db9b7 --- /dev/null +++ b/site-lisp/extensions-local/scroll-next-window.el @@ -0,0 +1,42 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +;'up' to see previous content +;'down' to see further content +(defun scroll-next-window-up () + (interactive) + (scroll-next-window-internal "up")) + +(defun scroll-next-window-down () + (interactive) + (scroll-next-window-internal "down")) + +(defun scroll-next-window-up-line () + (interactive) + (scroll-next-window-internal "up" 1)) + +(defun scroll-next-window-down-line () + (interactive) + (scroll-next-window-internal "down" 1)) + +(defun scroll-next-window-internal (direction &optional line) + (save-excursion + ;; Switch to next window. + (other-window 1) + ;; Do scroll operation. + (ignore-errors + (if (string-equal direction "up") + (if line + (scroll-up line) + (scroll-up)) + (if line + (scroll-down line) + (scroll-down)))) + ;; Switch back to current window. + (other-window -1) + )) + +(provide 'scroll-next-window) + +;;; scroll-next-window.el ends here diff --git a/site-lisp/extensions-local/undo-tree.el b/site-lisp/extensions-local/undo-tree.el new file mode 100644 index 0000000..9919fec --- /dev/null +++ b/site-lisp/extensions-local/undo-tree.el @@ -0,0 +1,4653 @@ +;;; undo-tree.el --- Treat undo history as a tree -*- lexical-binding: t; -*- + +;; Copyright (C) 2009-2020 Free Software Foundation, Inc + +;; Author: Toby Cubitt +;; Maintainer: Toby Cubitt +;; Version: 0.7.4 +;; Keywords: convenience, files, undo, redo, history, tree +;; URL: http://www.dr-qubit.org/emacs.php +;; Repository: http://www.dr-qubit.org/git/undo-tree.git + +;; This file is part of 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 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 GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; Emacs has a powerful undo system. Unlike the standard undo/redo system in +;; most software, it allows you to recover *any* past state of a buffer +;; (whereas the standard undo/redo system can lose past states as soon as you +;; redo). However, this power comes at a price: many people find Emacs' undo +;; system confusing and difficult to use, spawning a number of packages that +;; replace it with the less powerful but more intuitive undo/redo system. +;; +;; Both the loss of data with standard undo/redo, and the confusion of Emacs' +;; undo, stem from trying to treat undo history as a linear sequence of +;; changes. It's not. The `undo-tree-mode' provided by this package replaces +;; Emacs' undo system with a system that treats undo history as what it is: a +;; branching tree of changes. This simple idea allows the more intuitive +;; behaviour of the standard undo/redo system to be combined with the power of +;; never losing any history. An added side bonus is that undo history can in +;; some cases be stored more efficiently, allowing more changes to accumulate +;; before Emacs starts discarding history. +;; +;; The only downside to this more advanced yet simpler undo system is that it +;; was inspired by Vim. But, after all, most successful religions steal the +;; best ideas from their competitors! +;; +;; +;; Installation +;; ============ +;; +;; This package has only been tested with Emacs versions 24 and CVS. It should +;; work in Emacs versions 22 and 23 too, but will not work without +;; modifications in earlier versions of Emacs. +;; +;; To install `undo-tree-mode', make sure this file is saved in a directory in +;; your `load-path', and add the line: +;; +;; (require 'undo-tree) +;; +;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using +;; "M-x byte-compile-file" from within emacs). +;; +;; If you want to replace the standard Emacs' undo system with the +;; `undo-tree-mode' system in all buffers, you can enable it globally by +;; adding: +;; +;; (global-undo-tree-mode) +;; +;; to your .emacs file. +;; +;; +;; Quick-Start +;; =========== +;; +;; If you're the kind of person who likes to jump in the car and drive, +;; without bothering to first figure out whether the button on the left dips +;; the headlights or operates the ejector seat (after all, you'll soon figure +;; it out when you push it), then here's the minimum you need to know: +;; +;; `undo-tree-mode' and `global-undo-tree-mode' +;; Enable undo-tree mode (either in the current buffer or globally). +;; +;; C-_ C-/ (`undo-tree-undo') +;; Undo changes. +;; +;; M-_ C-? (`undo-tree-redo') +;; Redo changes. +;; +;; `undo-tree-switch-branch' +;; Switch undo-tree branch. +;; (What does this mean? Better press the button and see!) +;; +;; C-x u (`undo-tree-visualize') +;; Visualize the undo tree. +;; (Better try pressing this button too!) +;; +;; C-x r u (`undo-tree-save-state-to-register') +;; Save current buffer state to register. +;; +;; C-x r U (`undo-tree-restore-state-from-register') +;; Restore buffer state from register. +;; +;; +;; +;; In the undo-tree visualizer: +;; +;; p C-p (`undo-tree-visualize-undo') +;; Undo changes. +;; +;; n C-n (`undo-tree-visualize-redo') +;; Redo changes. +;; +;; b C-b (`undo-tree-visualize-switch-branch-left') +;; Switch to previous undo-tree branch. +;; +;; f C-f (`undo-tree-visualize-switch-branch-right') +;; Switch to next undo-tree branch. +;; +;; C- M-{ (`undo-tree-visualize-undo-to-x') +;; Undo changes up to last branch point. +;; +;; C- M-} (`undo-tree-visualize-redo-to-x') +;; Redo changes down to next branch point. +;; +;; n C-n (`undo-tree-visualize-redo') +;; Redo changes. +;; +;; (`undo-tree-visualizer-mouse-set') +;; Set state to node at mouse click. +;; +;; t (`undo-tree-visualizer-toggle-timestamps') +;; Toggle display of time-stamps. +;; +;; d (`undo-tree-visualizer-toggle-diff') +;; Toggle diff display. +;; +;; s (`undo-tree-visualizer-selection-mode') +;; Toggle keyboard selection mode. +;; +;; q (`undo-tree-visualizer-quit') +;; Quit undo-tree-visualizer. +;; +;; C-q (`undo-tree-visualizer-abort') +;; Abort undo-tree-visualizer. +;; +;; , < +;; Scroll left. +;; +;; . > +;; Scroll right. +;; +;; M-v +;; Scroll up. +;; +;; C-v +;; Scroll down. +;; +;; +;; +;; In visualizer selection mode: +;; +;; p C-p (`undo-tree-visualizer-select-previous') +;; Select previous node. +;; +;; n C-n (`undo-tree-visualizer-select-next') +;; Select next node. +;; +;; b C-b (`undo-tree-visualizer-select-left') +;; Select left sibling node. +;; +;; f C-f (`undo-tree-visualizer-select-right') +;; Select right sibling node. +;; +;; M-v +;; Select node 10 above. +;; +;; C-v +;; Select node 10 below. +;; +;; (`undo-tree-visualizer-set') +;; Set state to selected node and exit selection mode. +;; +;; s (`undo-tree-visualizer-mode') +;; Exit selection mode. +;; +;; t (`undo-tree-visualizer-toggle-timestamps') +;; Toggle display of time-stamps. +;; +;; d (`undo-tree-visualizer-toggle-diff') +;; Toggle diff display. +;; +;; q (`undo-tree-visualizer-quit') +;; Quit undo-tree-visualizer. +;; +;; C-q (`undo-tree-visualizer-abort') +;; Abort undo-tree-visualizer. +;; +;; , < +;; Scroll left. +;; +;; . > +;; Scroll right. +;; +;; +;; +;; Persistent undo history: +;; +;; Note: Requires Emacs version 24.3 or higher. +;; +;; `undo-tree-auto-save-history' (variable) +;; automatically save and restore undo-tree history along with buffer +;; (disabled by default) +;; +;; `undo-tree-save-history' (command) +;; manually save undo history to file +;; +;; `undo-tree-load-history' (command) +;; manually load undo history from file +;; +;; +;; +;; Compressing undo history: +;; +;; Undo history files cannot grow beyond the maximum undo tree size, which +;; is limited by `undo-limit', `undo-strong-limit' and +;; `undo-outer-limit'. Nevertheless, undo history files can grow quite +;; large. If you want to automatically compress undo history, add the +;; following advice to your .emacs file (replacing ".gz" with the filename +;; extension of your favourite compression algorithm): +;; +;; (defadvice undo-tree-make-history-save-file-name +;; (after undo-tree activate) +;; (setq ad-return-value (concat ad-return-value ".gz"))) +;; +;; +;; +;; +;; Undo Systems +;; ============ +;; +;; To understand the different undo systems, it's easiest to consider an +;; example. Imagine you make a few edits in a buffer. As you edit, you +;; accumulate a history of changes, which we might visualize as a string of +;; past buffer states, growing downwards: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (current buffer state) +;; +;; +;; Now imagine that you undo the last two changes. We can visualize this as +;; rewinding the current state back two steps: +;; +;; o (initial buffer state) +;; | +;; | +;; x (current buffer state) +;; | +;; | +;; o +;; | +;; | +;; o +;; +;; +;; However, this isn't a good representation of what Emacs' undo system +;; does. Instead, it treats the undos as *new* changes to the buffer, and adds +;; them to the history: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (buffer state before undo) +;; | +;; | +;; o (first undo) +;; | +;; | +;; x (second undo) +;; +;; +;; Actually, since the buffer returns to a previous state after an undo, +;; perhaps a better way to visualize it is to imagine the string of changes +;; turning back on itself: +;; +;; (initial buffer state) o +;; | +;; | +;; (first edit) o x (second undo) +;; | | +;; | | +;; (second edit) o o (first undo) +;; | / +;; |/ +;; o (buffer state before undo) +;; +;; Treating undos as new changes might seem a strange thing to do. But the +;; advantage becomes clear as soon as we imagine what happens when you edit +;; the buffer again. Since you've undone a couple of changes, new edits will +;; branch off from the buffer state that you've rewound to. Conceptually, it +;; looks like this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (new edit) +;; | +;; | +;; o +;; +;; The standard undo/redo system only lets you go backwards and forwards +;; linearly. So as soon as you make that new edit, it discards the old +;; branch. Emacs' undo just keeps adding changes to the end of the string. So +;; the undo history in the two systems now looks like this: +;; +;; Undo/Redo: Emacs' undo +;; +;; o o +;; | | +;; | | +;; o o o +;; .\ | |\ +;; . \ | | \ +;; . x (new edit) o o | +;; (discarded . | / | +;; branch) . |/ | +;; . o | +;; | +;; | +;; x (new edit) +;; +;; Now, what if you change your mind about those undos, and decide you did +;; like those other changes you'd made after all? With the standard undo/redo +;; system, you're lost. There's no way to recover them, because that branch +;; was discarded when you made the new edit. +;; +;; However, in Emacs' undo system, those old buffer states are still there in +;; the undo history. You just have to rewind back through the new edit, and +;; back through the changes made by the undos, until you reach them. Of +;; course, since Emacs treats undos (even undos of undos!) as new changes, +;; you're really weaving backwards and forwards through the history, all the +;; time adding new changes to the end of the string as you go: +;; +;; o +;; | +;; | +;; o o o (undo new edit) +;; | |\ |\ +;; | | \ | \ +;; o o | | o (undo the undo) +;; | / | | | +;; |/ | | | +;; (trying to get o | | x (undo the undo) +;; to this state) | / +;; |/ +;; o +;; +;; So far, this is still reasonably intuitive to use. It doesn't behave so +;; differently to standard undo/redo, except that by going back far enough you +;; can access changes that would be lost in standard undo/redo. +;; +;; However, imagine that after undoing as just described, you decide you +;; actually want to rewind right back to the initial state. If you're lucky, +;; and haven't invoked any command since the last undo, you can just keep on +;; undoing until you get back to the start: +;; +;; (trying to get o x (got there!) +;; to this state) | | +;; | | +;; o o o o (keep undoing) +;; | |\ |\ | +;; | | \ | \ | +;; o o | | o o (keep undoing) +;; | / | | | / +;; |/ | | |/ +;; (already undid o | | o (got this far) +;; to this state) | / +;; |/ +;; o +;; +;; But if you're unlucky, and you happen to have moved the point (say) after +;; getting to the state labelled "got this far", then you've "broken the undo +;; chain". Hold on to something solid, because things are about to get +;; hairy. If you try to undo now, Emacs thinks you're trying to undo the +;; undos! So to get back to the initial state you now have to rewind through +;; *all* the changes, including the undos you just did: +;; +;; (trying to get o x (finally got there!) +;; to this state) | | +;; | | +;; o o o o o o +;; | |\ |\ |\ |\ | +;; | | \ | \ | \ | \ | +;; o o | | o o | | o o +;; | / | | | / | | | / +;; |/ | | |/ | | |/ +;; (already undid o | | o<. | | o +;; to this state) | / : | / +;; |/ : |/ +;; o : o +;; : +;; (got this far, but +;; broke the undo chain) +;; +;; Confused? +;; +;; In practice you can just hold down the undo key until you reach the buffer +;; state that you want. But whatever you do, don't move around in the buffer +;; to *check* that you've got back to where you want! Because you'll break the +;; undo chain, and then you'll have to traverse the entire string of undos +;; again, just to get back to the point at which you broke the +;; chain. Undo-in-region and commands such as `undo-only' help to make using +;; Emacs' undo a little easier, but nonetheless it remains confusing for many +;; people. +;; +;; +;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent +;; the history we've been discussing (make a few edits, undo a couple of them, +;; and edit again)? The diagram that conceptually represented our undo +;; history, before we started discussing specific undo systems? It looked like +;; this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (current state) +;; | +;; | +;; o +;; +;; Well, that's *exactly* what the undo history looks like to +;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo +;; does), nor does it treat undos as new changes to be added to the end of a +;; linear string of buffer states (as Emacs' undo does). It just keeps track +;; of the tree of branching changes that make up the entire undo history. +;; +;; If you undo from this point, you'll rewind back up the tree to the previous +;; state: +;; +;; o +;; | +;; | +;; x (undo) +;; |\ +;; | \ +;; o o +;; | +;; | +;; o +;; +;; If you were to undo again, you'd rewind back to the initial state. If on +;; the other hand you redo the change, you'll end up back at the bottom of the +;; most recent branch: +;; +;; o (undo takes you here) +;; | +;; | +;; o (start here) +;; |\ +;; | \ +;; o x (redo takes you here) +;; | +;; | +;; o +;; +;; So far, this is just like the standard undo/redo system. But what if you +;; want to return to a buffer state located on a previous branch of the +;; history? Since `undo-tree-mode' keeps the entire history, you simply need +;; to tell it to switch to a different branch, and then redo the changes you +;; want: +;; +;; o +;; | +;; | +;; o (start here, but switch +;; |\ to the other branch) +;; | \ +;; (redo) o o +;; | +;; | +;; (redo) x +;; +;; Now you're on the other branch, if you undo and redo changes you'll stay on +;; that branch, moving up and down through the buffer states located on that +;; branch. Until you decide to switch branches again, of course. +;; +;; Real undo trees might have multiple branches and sub-branches: +;; +;; o +;; ____|______ +;; / \ +;; o o +;; ____|__ __| +;; / | \ / \ +;; o o o o x +;; | | +;; / \ / \ +;; o o o o +;; +;; Trying to imagine what Emacs' undo would do as you move about such a tree +;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're +;; just moving around this undo history tree. Most of the time, you'll +;; probably only need to stay on the most recent branch, in which case it +;; behaves like standard undo/redo, and is just as simple to understand. But +;; if you ever need to recover a buffer state on a different branch, the +;; possibility of switching between branches and accessing the full undo +;; history is still there. +;; +;; +;; +;; The Undo-Tree Visualizer +;; ======================== +;; +;; Actually, it gets better. You don't have to imagine all these tree +;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which +;; draws them for you! In fact, it draws even better diagrams: it highlights +;; the node representing the current buffer state, it highlights the current +;; branch, and you can toggle the display of time-stamps (by hitting "t") and +;; a diff of the undo changes (by hitting "d"). (There's one other tiny +;; difference: the visualizer puts the most recent branch on the left rather +;; than the right.) +;; +;; Bring up the undo tree visualizer whenever you want by hitting "C-x u". +;; +;; In the visualizer, the usual keys for moving up and down a buffer instead +;; move up and down the undo history tree (e.g. the up and down arrow keys, or +;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo +;; history you are visualizing) is updated as you move around the undo tree in +;; the visualizer. If you reach a branch point in the visualizer, the usual +;; keys for moving forward and backward in a buffer instead switch branch +;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). +;; +;; Clicking with the mouse on any node in the visualizer will take you +;; directly to that node, resetting the state of the parent buffer to the +;; state represented by that node. +;; +;; You can also select nodes directly using the keyboard, by hitting "s" to +;; toggle selection mode. The usual motion keys now allow you to move around +;; the tree without changing the parent buffer. Hitting will reset the +;; state of the parent buffer to the state represented by the currently +;; selected node. +;; +;; It can be useful to see how long ago the parent buffer was in the state +;; represented by a particular node in the visualizer. Hitting "t" in the +;; visualizer toggles the display of time-stamps for all the nodes. (Note +;; that, because of the way `undo-tree-mode' works, these time-stamps may be +;; somewhat later than the true times, especially if it's been a long time +;; since you last undid any changes.) +;; +;; To get some idea of what changes are represented by a given node in the +;; tree, it can be useful to see a diff of the changes. Hit "d" in the +;; visualizer to toggle a diff display. This normally displays a diff between +;; the current state and the previous one, i.e. it shows you the changes that +;; will be applied if you undo (move up the tree). However, the diff display +;; really comes into its own in the visualizer's selection mode (see above), +;; where it instead shows a diff between the current state and the currently +;; selected state, i.e. it shows you the changes that will be applied if you +;; reset to the selected state. +;; +;; (Note that the diff is generated by the Emacs `diff' command, and is +;; displayed using `diff-mode'. See the corresponding customization groups if +;; you want to customize the diff display.) +;; +;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in +;; whatever state you ended at. Hitting "C-q" will abort the visualizer, +;; returning the parent buffer to whatever state it was originally in when the +;; visualizer was invoked. +;; +;; +;; +;; Undo-in-Region +;; ============== +;; +;; Emacs allows a very useful and powerful method of undoing only selected +;; changes: when a region is active, only changes that affect the text within +;; that region will be undone. With the standard Emacs undo system, changes +;; produced by undoing-in-region naturally get added onto the end of the +;; linear undo history: +;; +;; o +;; | +;; | x (second undo-in-region) +;; o | +;; | | +;; | o (first undo-in-region) +;; o | +;; | / +;; |/ +;; o +;; +;; You can of course redo these undos-in-region as usual, by undoing the +;; undos: +;; +;; o +;; | +;; | o_ +;; o | \ +;; | | | +;; | o o (undo the undo-in-region) +;; o | | +;; | / | +;; |/ | +;; o x (undo the undo-in-region) +;; +;; +;; In `undo-tree-mode', undo-in-region works much the same way: when there's +;; an active region, undoing only undoes changes that affect that region. In +;; `undo-tree-mode', redoing when there's an active region similarly only +;; redoes changes that affect that region. +;; +;; However, the way these undo- and redo-in-region changes are recorded in the +;; undo history is quite different. The good news is, you don't need to +;; understand this to use undo- and redo-in-region in `undo-tree-mode' - just +;; go ahead and use them! They'll probably work as you expect. But if you're +;; masochistic enough to want to understand conceptually what's happening to +;; the undo tree as you undo- and redo-in-region, then read on... +;; +;; +;; Undo-in-region creates a new branch in the undo history. The new branch +;; consists of an undo step that undoes some of the changes that affect the +;; current region, and another step that undoes the remaining changes needed +;; to rejoin the previous undo history. +;; +;; Previous undo history Undo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o o +;; | | +;; | | +;; | | +;; o o_ +;; | | \ +;; | | x (undo-in-region) +;; | | | +;; x o o +;; +;; As long as you don't change the active region after undoing-in-region, +;; continuing to undo-in-region extends the new branch, pulling more changes +;; that affect the current region into an undo step immediately above your +;; current location in the undo tree, and pushing the point at which the new +;; branch is attached further up the tree: +;; +;; First undo-in-region Second undo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o o_ +;; | | \ +;; | | x (undo-in-region) +;; | | | +;; o_ o | +;; | \ | | +;; | x | o +;; | | | | +;; o o o o +;; +;; Redoing takes you back down the undo tree, as usual (as long as you haven't +;; changed the active region after undoing-in-region, it doesn't matter if it +;; is still active): +;; +;; o +;; | +;; | +;; | +;; o_ +;; | \ +;; | o +;; | | +;; o | +;; | | +;; | o (redo) +;; | | +;; o x (redo) +;; +;; +;; What about redo-in-region? Obviously, redo-in-region only makes sense if +;; you have already undone some changes, so that there are some changes to +;; redo! Redoing-in-region splits off a new branch of the undo history below +;; your current location in the undo tree. This time, the new branch consists +;; of a first redo step that redoes some of the redo changes that affect the +;; current region, followed by *all* the remaining redo changes. +;; +;; Previous undo history Redo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; x o_ +;; | | \ +;; | | x (redo-in-region) +;; | | | +;; o o | +;; | | | +;; | | | +;; | | | +;; o o o +;; +;; As long as you don't change the active region after redoing-in-region, +;; continuing to redo-in-region extends the new branch, pulling more redo +;; changes into a redo step immediately below your current location in the +;; undo tree. +;; +;; First redo-in-region Second redo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o_ o_ +;; | \ | \ +;; | x | o +;; | | | | +;; o | o | +;; | | | | +;; | | | x (redo-in-region) +;; | | | | +;; o o o o +;; +;; Note that undo-in-region and redo-in-region only ever add new changes to +;; the undo tree, they *never* modify existing undo history. So you can always +;; return to previous buffer states by switching to a previous branch of the +;; tree. + + + +;;; Code: + +(require 'cl-lib) +(require 'diff) +(require 'gv) + + + +;;; ===================================================================== +;;; Compatibility hacks for older Emacsen + +;; `characterp' isn't defined in Emacs versions < 23 +(unless (fboundp 'characterp) + (defalias 'characterp 'char-valid-p)) + +;; `region-active-p' isn't defined in Emacs versions < 23 +(unless (fboundp 'region-active-p) + (defun region-active-p () (and transient-mark-mode mark-active))) + + +;; `registerv' defstruct isn't defined in Emacs versions < 24 +(unless (fboundp 'registerv-make) + (defmacro registerv-make (data &rest _dummy) data)) + +(unless (fboundp 'registerv-data) + (defmacro registerv-data (data) data)) + + +;; `diff-no-select' and `diff-file-local-copy' aren't defined in Emacs +;; versions < 24 (copied and adapted from Emacs 24) +(unless (fboundp 'diff-no-select) + (defun diff-no-select (old new &optional switches no-async buf) + ;; Noninteractive helper for creating and reverting diff buffers + (unless (bufferp new) (setq new (expand-file-name new))) + (unless (bufferp old) (setq old (expand-file-name old))) + (or switches (setq switches diff-switches)) ; If not specified, use default. + (unless (listp switches) (setq switches (list switches))) + (or buf (setq buf (get-buffer-create "*Diff*"))) + (let* ((old-alt (diff-file-local-copy old)) + (new-alt (diff-file-local-copy new)) + (command + (mapconcat 'identity + `(,diff-command + ;; Use explicitly specified switches + ,@switches + ,@(mapcar #'shell-quote-argument + (nconc + (when (or old-alt new-alt) + (list "-L" (if (stringp old) + old (prin1-to-string old)) + "-L" (if (stringp new) + new (prin1-to-string new)))) + (list (or old-alt old) + (or new-alt new))))) + " ")) + (thisdir default-directory)) + (with-current-buffer buf + (setq buffer-read-only t) + (buffer-disable-undo (current-buffer)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (buffer-enable-undo (current-buffer)) + (diff-mode) + (set (make-local-variable 'revert-buffer-function) + (lambda (_ignore-auto _noconfirm) + (diff-no-select old new switches no-async (current-buffer)))) + (setq default-directory thisdir) + (let ((inhibit-read-only t)) + (insert command "\n")) + (if (and (not no-async) (fboundp 'start-process)) + (let ((proc (start-process "Diff" buf shell-file-name + shell-command-switch command))) + (set-process-filter proc 'diff-process-filter) + (set-process-sentinel + proc (lambda (proc _msg) + (with-current-buffer (process-buffer proc) + (diff-sentinel (process-exit-status proc)) + (if old-alt (delete-file old-alt)) + (if new-alt (delete-file new-alt)))))) + ;; Async processes aren't available. + (let ((inhibit-read-only t)) + (diff-sentinel + (call-process shell-file-name nil buf nil + shell-command-switch command)) + (if old-alt (delete-file old-alt)) + (if new-alt (delete-file new-alt))))) + buf))) + +(unless (fboundp 'diff-file-local-copy) + (defun diff-file-local-copy (file-or-buf) + (if (bufferp file-or-buf) + (with-current-buffer file-or-buf + (let ((tempfile (make-temp-file "buffer-content-"))) + (write-region nil nil tempfile nil 'nomessage) + tempfile)) + (file-local-copy file-or-buf)))) + + +;; `user-error' isn't defined in Emacs < 24.3 +(unless (fboundp 'user-error) + (defalias 'user-error 'error) + ;; prevent debugger being called on user errors + (add-to-list 'debug-ignored-errors "^No further undo information") + (add-to-list 'debug-ignored-errors "^No further redo information") + (add-to-list 'debug-ignored-errors "^No further redo information for region")) + + + + + +;;; ===================================================================== +;;; Global variables and customization options + +(defvar buffer-undo-tree nil + "Tree of undo entries in current buffer.") +(put 'buffer-undo-tree 'permanent-local t) +(make-variable-buffer-local 'buffer-undo-tree) + + +(defgroup undo-tree nil + "Tree undo/redo." + :group 'undo) + + +(defcustom undo-tree-limit 80000000 + "Value of `undo-limit' used in `undo-tree-mode'. + +If `undo-limit' is larger than `undo-tree-limit', the larger of +the two values will be used. + +See also `undo-tree-strong-limit' and `undo-tree-outer-limit'. + +Setting this to nil prevents `undo-tree-mode' ever discarding +undo history. (As far as possible. In principle, it is still +possible for Emacs to discard undo history behind +`undo-tree-mode's back.) USE THIS SETTING AT YOUR OWN RISK! Emacs +may crash if undo history exceeds Emacs' available memory. This +is particularly risky if `undo-tree-auto-save-history' is +enabled, as in that case undo history is preserved even between +Emacs sessions." + :group 'undo-tree + :type '(choice integer (const nil))) + + +(defcustom undo-tree-strong-limit 120000000 + "Value of `undo-strong-limit' used in `undo-tree-mode'. + +If `undo-strong-limit' is larger than `undo-tree-strong-limit' +the larger of the two values will be used." + :group 'undo-tree + :type 'integer) + + +(defcustom undo-tree-outer-limit 360000000 + "Value of `undo-outer-limit' used in `undo-tree-mode'. + +If `undo-outer-limit' is larger than `undo-tree-outer-limit' the +larger of the two values will be used." + :group 'undo-tree + :type 'integer) + + +(defcustom undo-tree-mode-lighter " Undo-Tree" + "Lighter displayed in mode line +when `undo-tree-mode' is enabled." + :group 'undo-tree + :type 'string) + + +(defcustom undo-tree-incompatible-major-modes '(term-mode) + "List of major-modes in which `undo-tree-mode' should not be enabled. +\(See `turn-on-undo-tree-mode'.\)" + :group 'undo-tree + :type '(repeat symbol)) + + +(defcustom undo-tree-enable-undo-in-region nil + "When non-nil, enable undo-in-region. + +When undo-in-region is enabled, undoing or redoing when the +region is active (in `transient-mark-mode') or with a prefix +argument (not in `transient-mark-mode') only undoes changes +within the current region." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-auto-save-history nil + "When non-nil, `undo-tree-mode' will save undo history to file +when a buffer is saved to file. + +It will automatically load undo history when a buffer is loaded +from file, if an undo save file exists. + +By default, undo-tree history is saved to a file called +\"..~undo-tree~\" in the same directory as the +file itself. To save under a different directory, customize +`undo-tree-history-directory-alist' (see the documentation for +that variable for details). + +WARNING! `undo-tree-auto-save-history' will not work properly in +Emacs versions prior to 24.3, so it cannot be enabled via +the customization interface in versions earlier than that one. To +ignore this warning and enable it regardless, set +`undo-tree-auto-save-history' to a non-nil value outside of +customize." + :group 'undo-tree + :type (if (version-list-< (version-to-list emacs-version) '(24 3)) + '(choice (const :tag "" nil)) + 'boolean)) + + +(defcustom undo-tree-history-directory-alist nil + "Alist of filename patterns and undo history directory names. +Each element looks like (REGEXP . DIRECTORY). Undo history for +files with names matching REGEXP will be saved in DIRECTORY. +DIRECTORY may be relative or absolute. If it is absolute, so +that all matching files are backed up into the same directory, +the file names in this directory will be the full name of the +file backed up with all directory separators changed to `!' to +prevent clashes. This will not work correctly if your filesystem +truncates the resulting name. + +For the common case of all backups going into one directory, the +alist should contain a single element pairing \".\" with the +appropriate directory name. + +If this variable is nil, or it fails to match a filename, the +backup is made in the original file's directory. + +On MS-DOS filesystems without long names this variable is always +ignored." + :group 'undo-tree + :type '(repeat (cons (regexp :tag "Regexp matching filename") + (directory :tag "Undo history directory name")))) + + + +(defcustom undo-tree-visualizer-relative-timestamps t + "When non-nil, display times relative to current time +when displaying time stamps in visualizer. + +Otherwise, display absolute times." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-timestamps nil + "When non-nil, display time-stamps by default +in undo-tree visualizer. + +\\You can always toggle time-stamps on and off \ +using \\[undo-tree-visualizer-toggle-timestamps], regardless of the +setting of this variable." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-diff nil + "When non-nil, display diff by default in undo-tree visualizer. + +\\You can always toggle the diff display \ +using \\[undo-tree-visualizer-toggle-diff], regardless of the +setting of this variable." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-lazy-drawing 100 + "When non-nil, use lazy undo-tree drawing in visualizer. + +Setting this to a number causes the visualizer to switch to lazy +drawing when the number of nodes in the tree is larger than this +value. + +Lazy drawing means that only the visible portion of the tree will +be drawn initially, and the tree will be extended later as +needed. For the most part, the only visible effect of this is to +significantly speed up displaying the visualizer for very large +trees. + +There is one potential negative effect of lazy drawing. Other +branches of the tree will only be drawn once the node from which +they branch off becomes visible. So it can happen that certain +portions of the tree that would be shown with lazy drawing +disabled, will not be drawn immediately when it is +enabled. However, this effect is quite rare in practice." + :group 'undo-tree + :type '(choice (const :tag "never" nil) + (const :tag "always" t) + (integer :tag "> size"))) + + +(defvar undo-tree-pre-save-element-functions '() + "Special hook to modify undo-tree elements prior to saving. +Each function on this hook is called in turn on each undo element +in the tree by `undo-tree-save-history' prior to writing the undo +history to file. It should return either nil, which removes that +undo element from the saved history, or a replacement element to +use instead (which should be identical to the original element if +that element should be saved unchanged).") + + +(defvar undo-tree-post-load-element-functions '() + "Special hook to modify undo-tree undo elements after loading. +Each function on this hook is called in turn on each undo element +in the tree by `undo-tree-load-history' after loading the undo +history from file. It should return either nil, which removes that +undo element from the loaded history, or a replacement element to +use instead (which should be identical to the original element if +that element should be loaded unchanged).") + + +(defface undo-tree-visualizer-default-face + '((((class color)) :foreground "gray")) + "Face used to draw undo-tree in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-current-face + '((((class color)) :foreground "red")) + "Face used to highlight current undo-tree node in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-active-branch-face + '((((class color) (background dark)) + (:foreground "white" :weight bold)) + (((class color) (background light)) + (:foreground "black" :weight bold))) + "Face used to highlight active undo-tree branch in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-register-face + '((((class color)) :foreground "yellow")) + "Face used to highlight undo-tree nodes saved to a register +in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-unmodified-face + '((((class color)) :foreground "cyan")) + "Face used to highlight nodes corresponding to unmodified buffers +in visualizer." + :group 'undo-tree) + + +(defvar undo-tree-visualizer-parent-buffer nil + "Parent buffer in visualizer.") +(put 'undo-tree-visualizer-parent-buffer 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer) + +;; stores modification time of parent buffer's file, if any +(defvar undo-tree-visualizer-parent-mtime nil) +(put 'undo-tree-visualizer-parent-mtime 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-parent-mtime) + +;; stores current horizontal spacing needed for drawing undo-tree +(defvar undo-tree-visualizer-spacing nil) +(put 'undo-tree-visualizer-spacing 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-spacing) + +;; calculate horizontal spacing required for drawing tree with current +;; settings +(defsubst undo-tree-visualizer-calculate-spacing () + (if undo-tree-visualizer-timestamps + (if undo-tree-visualizer-relative-timestamps 9 13) + 3)) + +;; holds node that was current when visualizer was invoked +(defvar undo-tree-visualizer-initial-node nil) +(put 'undo-tree-visualizer-initial-node 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-initial-node) + +;; holds currently selected node in visualizer selection mode +(defvar undo-tree-visualizer-selected-node nil) +(put 'undo-tree-visualizer-selected-node 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-selected) + +;; used to store nodes at edge of currently drawn portion of tree +(defvar undo-tree-visualizer-needs-extending-down nil) +(put 'undo-tree-visualizer-needs-extending-down 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-down) +(defvar undo-tree-visualizer-needs-extending-up nil) +(put 'undo-tree-visualizer-needs-extending-up 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-up) + +;; dynamically bound to t when undoing from visualizer, to inhibit +;; `undo-tree-kill-visualizer' hook function in parent buffer +(defvar undo-tree-inhibit-kill-visualizer nil) + +;; can be let-bound to a face name, used in drawing functions +(defvar undo-tree-insert-face nil) + +;; visualizer buffer names +(defconst undo-tree-visualizer-buffer-name " *undo-tree*") +(defconst undo-tree-diff-buffer-name "*undo-tree Diff*") + + + + +;;; ================================================================= +;;; Default keymaps + +(defvar undo-tree-map nil + "Keymap used in undo-tree-mode.") + +(unless undo-tree-map + (let ((map (make-sparse-keymap))) + ;; remap `undo' and `undo-only' to `undo-tree-undo' + (define-key map [remap undo] 'undo-tree-undo) + (define-key map [remap undo-only] 'undo-tree-undo) + ;; bind standard undo bindings (since these match redo counterparts) + (define-key map (kbd "C-/") 'undo-tree-undo) + (define-key map "\C-_" 'undo-tree-undo) + ;; redo doesn't exist normally, so define our own keybindings + (define-key map (kbd "C-?") 'undo-tree-redo) + (define-key map (kbd "M-_") 'undo-tree-redo) + ;; just in case something has defined `redo'... + (define-key map [remap redo] 'undo-tree-redo) + ;; we use "C-x u" for the undo-tree visualizer + (define-key map (kbd "\C-x u") 'undo-tree-visualize) + ;; bind register commands + (define-key map (kbd "C-x r u") 'undo-tree-save-state-to-register) + (define-key map (kbd "C-x r U") 'undo-tree-restore-state-from-register) + ;; set keymap + (setq undo-tree-map map))) + + +(defvar undo-tree-visualizer-mode-map nil + "Keymap used in undo-tree visualizer.") + +(unless undo-tree-visualizer-mode-map + (let ((map (make-sparse-keymap))) + ;; vertical motion keys undo/redo + (define-key map [remap previous-line] 'undo-tree-visualize-undo) + (define-key map [remap next-line] 'undo-tree-visualize-redo) + (define-key map [up] 'undo-tree-visualize-undo) + (define-key map "p" 'undo-tree-visualize-undo) + (define-key map "\C-p" 'undo-tree-visualize-undo) + (define-key map [down] 'undo-tree-visualize-redo) + (define-key map "n" 'undo-tree-visualize-redo) + (define-key map "\C-n" 'undo-tree-visualize-redo) + ;; horizontal motion keys switch branch + (define-key map [remap forward-char] + 'undo-tree-visualize-switch-branch-right) + (define-key map [remap backward-char] + 'undo-tree-visualize-switch-branch-left) + (define-key map [right] 'undo-tree-visualize-switch-branch-right) + (define-key map "f" 'undo-tree-visualize-switch-branch-right) + (define-key map "\C-f" 'undo-tree-visualize-switch-branch-right) + (define-key map [left] 'undo-tree-visualize-switch-branch-left) + (define-key map "b" 'undo-tree-visualize-switch-branch-left) + (define-key map "\C-b" 'undo-tree-visualize-switch-branch-left) + ;; paragraph motion keys undo/redo to significant points in tree + (define-key map [remap backward-paragraph] 'undo-tree-visualize-undo-to-x) + (define-key map [remap forward-paragraph] 'undo-tree-visualize-redo-to-x) + (define-key map "\M-{" 'undo-tree-visualize-undo-to-x) + (define-key map "\M-}" 'undo-tree-visualize-redo-to-x) + (define-key map [C-up] 'undo-tree-visualize-undo-to-x) + (define-key map [C-down] 'undo-tree-visualize-redo-to-x) + ;; mouse sets buffer state to node at click + (define-key map [mouse-1] 'undo-tree-visualizer-mouse-set) + ;; toggle timestamps + (define-key map "t" 'undo-tree-visualizer-toggle-timestamps) + ;; toggle diff + (define-key map "d" 'undo-tree-visualizer-toggle-diff) + ;; toggle selection mode + (define-key map "s" 'undo-tree-visualizer-selection-mode) + ;; horizontal scrolling may be needed if the tree is very wide + (define-key map "," 'undo-tree-visualizer-scroll-left) + (define-key map "." 'undo-tree-visualizer-scroll-right) + (define-key map "<" 'undo-tree-visualizer-scroll-left) + (define-key map ">" 'undo-tree-visualizer-scroll-right) + ;; vertical scrolling may be needed if the tree is very tall + (define-key map [next] 'undo-tree-visualizer-scroll-up) + (define-key map [prior] 'undo-tree-visualizer-scroll-down) + ;; quit/abort visualizer + (define-key map "q" 'undo-tree-visualizer-quit) + (define-key map "\C-q" 'undo-tree-visualizer-abort) + ;; set keymap + (setq undo-tree-visualizer-mode-map map))) + + +(defvar undo-tree-visualizer-selection-mode-map nil + "Keymap used in undo-tree visualizer selection mode.") + +(unless undo-tree-visualizer-selection-mode-map + (let ((map (make-sparse-keymap))) + ;; vertical motion keys move up and down tree + (define-key map [remap previous-line] + 'undo-tree-visualizer-select-previous) + (define-key map [remap next-line] + 'undo-tree-visualizer-select-next) + (define-key map [up] 'undo-tree-visualizer-select-previous) + (define-key map "p" 'undo-tree-visualizer-select-previous) + (define-key map "\C-p" 'undo-tree-visualizer-select-previous) + (define-key map [down] 'undo-tree-visualizer-select-next) + (define-key map "n" 'undo-tree-visualizer-select-next) + (define-key map "\C-n" 'undo-tree-visualizer-select-next) + ;; vertical scroll keys move up and down quickly + (define-key map [next] + (lambda () (interactive) (undo-tree-visualizer-select-next 10))) + (define-key map [prior] + (lambda () (interactive) (undo-tree-visualizer-select-previous 10))) + ;; horizontal motion keys move to left and right siblings + (define-key map [remap forward-char] 'undo-tree-visualizer-select-right) + (define-key map [remap backward-char] 'undo-tree-visualizer-select-left) + (define-key map [right] 'undo-tree-visualizer-select-right) + (define-key map "f" 'undo-tree-visualizer-select-right) + (define-key map "\C-f" 'undo-tree-visualizer-select-right) + (define-key map [left] 'undo-tree-visualizer-select-left) + (define-key map "b" 'undo-tree-visualizer-select-left) + (define-key map "\C-b" 'undo-tree-visualizer-select-left) + ;; horizontal scroll keys move left or right quickly + (define-key map "," + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key map "." + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + (define-key map "<" + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key map ">" + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + ;; sets buffer state to node at point + (define-key map "\r" 'undo-tree-visualizer-set) + ;; mouse selects node at click + (define-key map [mouse-1] 'undo-tree-visualizer-mouse-select) + ;; toggle diff + (define-key map "d" 'undo-tree-visualizer-selection-toggle-diff) + ;; set keymap + (setq undo-tree-visualizer-selection-mode-map map))) + + + + +;;; ===================================================================== +;;; Undo-tree data structure + +(cl-defstruct + (undo-tree + :named + (:constructor nil) + (:constructor make-undo-tree + (&aux + (root (undo-tree-make-node nil nil)) + (current root) + (size 0) + (count 0) + (object-pool (make-hash-table :test 'eq :weakness 'value)))) + (:copier nil)) + root current size count object-pool) + +(defun undo-tree-copy (tree) + ;; Return a copy of undo-tree TREE. + (unwind-protect + (let ((new (make-undo-tree))) + (undo-tree-decircle tree) + (let ((max-lisp-eval-depth (* 100 (undo-tree-count tree))) + (max-specpdl-size (* 100 (undo-tree-count tree)))) + (setf (undo-tree-root new) + (undo-tree-node-copy (undo-tree-root tree) + new (undo-tree-current tree)))) + (setf (undo-tree-size new) + (undo-tree-size tree)) + (setf (undo-tree-count new) + (undo-tree-count tree)) + (setf (undo-tree-object-pool new) + (copy-hash-table (undo-tree-object-pool tree))) + (undo-tree-recircle new) + new) + (undo-tree-recircle tree))) + + +(cl-defstruct + (undo-tree-node + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-node + (previous undo + &optional redo + &aux + (timestamp (current-time)) + (branch 0))) + (:constructor undo-tree-make-node-backwards + (next-node undo + &optional redo + &aux + (next (list next-node)) + (timestamp (current-time)) + (branch 0))) + (:constructor undo-tree-make-empty-node ()) + (:copier nil)) + previous next undo redo timestamp branch meta-data) + + +(defmacro undo-tree-node-p (n) + (let ((len (length (undo-tree-make-node nil nil)))) + `(and (vectorp ,n) (= (length ,n) ,len)))) + +(defun undo-tree-node-copy (node &optional tree current) + ;; Return a copy of undo-tree NODE, sans previous link or meta-data. + ;; If TREE and CURRENT are supplied, set (undo-tree-current TREE) to the + ;; copy of CURRENT node, if found. + (let* ((new (undo-tree-make-empty-node)) + (stack (list (cons node new))) + n) + (while (setq n (pop stack)) + (setf (undo-tree-node-undo (cdr n)) + (copy-tree (undo-tree-node-undo (car n)) 'copy-vectors)) + (setf (undo-tree-node-redo (cdr n)) + (copy-tree (undo-tree-node-redo (car n)) 'copy-vectors)) + (setf (undo-tree-node-timestamp (cdr n)) + (copy-sequence (undo-tree-node-timestamp (car n)))) + (setf (undo-tree-node-branch (cdr n)) + (undo-tree-node-branch (car n))) + (setf (undo-tree-node-next (cdr n)) + (mapcar (lambda (_) (undo-tree-make-empty-node)) + (make-list (length (undo-tree-node-next (car n))) nil))) + ;; set (undo-tree-current TREE) to copy if we've found CURRENT + (when (and tree (eq (car n) current)) + (setf (undo-tree-current tree) (cdr n))) + ;; recursively copy next nodes + (let ((next0 (undo-tree-node-next (car n))) + (next1 (undo-tree-node-next (cdr n)))) + (while (and next0 next1) + (push (cons (pop next0) (pop next1)) stack)))) + new)) + + +(cl-defstruct + (undo-tree-region-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-region-data + (&optional undo-beginning undo-end + redo-beginning redo-end)) + (:constructor undo-tree-make-undo-region-data + (undo-beginning undo-end)) + (:constructor undo-tree-make-redo-region-data + (redo-beginning redo-end)) + (:copier nil)) + undo-beginning undo-end redo-beginning redo-end) + + +(defmacro undo-tree-region-data-p (r) + (let ((len (length (undo-tree-make-region-data)))) + `(and (vectorp ,r) (= (length ,r) ,len)))) + +(defmacro undo-tree-node-clear-region-data (node) + `(setf (undo-tree-node-meta-data ,node) + (delq nil + (delq :region + (plist-put (undo-tree-node-meta-data ,node) + :region nil))))) + + +(defmacro undo-tree-node-undo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-beginning r)))) + +(defmacro undo-tree-node-undo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-end r)))) + +(defmacro undo-tree-node-redo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-beginning r)))) + +(defmacro undo-tree-node-redo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-end r)))) + + +(gv-define-setter undo-tree-node-undo-beginning (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-undo-beginning r) ,val))) + +(gv-define-setter undo-tree-node-undo-end (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-undo-end r) ,val))) + +(gv-define-setter undo-tree-node-redo-beginning (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-redo-beginning r) ,val))) + +(gv-define-setter undo-tree-node-redo-end (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-redo-end r) ,val))) + + + +(cl-defstruct + (undo-tree-visualizer-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-visualizer-data + (&optional lwidth cwidth rwidth marker)) + (:copier nil)) + lwidth cwidth rwidth marker) + + +(defmacro undo-tree-visualizer-data-p (v) + (let ((len (length (undo-tree-make-visualizer-data)))) + `(and (vectorp ,v) (= (length ,v) ,len)))) + +(defun undo-tree-node-clear-visualizer-data (node) + (let ((plist (undo-tree-node-meta-data node))) + (if (eq (car plist) :visualizer) + (setf (undo-tree-node-meta-data node) (nthcdr 2 plist)) + (while (and plist (not (eq (cadr plist) :visualizer))) + (setq plist (cdr plist))) + (if plist (setcdr plist (nthcdr 3 plist)))))) + +(defmacro undo-tree-node-lwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-lwidth v)))) + +(defmacro undo-tree-node-cwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-cwidth v)))) + +(defmacro undo-tree-node-rwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-rwidth v)))) + +(defmacro undo-tree-node-marker (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-marker v)))) + + +(gv-define-setter undo-tree-node-lwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-lwidth v) ,val))) + +(gv-define-setter undo-tree-node-cwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-cwidth v) ,val))) + +(gv-define-setter undo-tree-node-rwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-rwidth v) ,val))) + +(gv-define-setter undo-tree-node-marker (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-marker v) ,val))) + + + +(cl-defstruct + (undo-tree-register-data + (:type vector) + (:constructor nil) + (:constructor undo-tree-make-register-data (buffer node))) + buffer node) + +(defun undo-tree-register-data-p (data) + (and (vectorp data) + (= (length data) 2) + (undo-tree-node-p (undo-tree-register-data-node data)))) + +(defun undo-tree-register-data-print-func (data) + (princ (format "an undo-tree state for buffer %s" + (undo-tree-register-data-buffer data)))) + +(defmacro undo-tree-node-register (node) + `(plist-get (undo-tree-node-meta-data ,node) :register)) + +(gv-define-setter undo-tree-node-register (val node) + `(setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :register ,val))) + + + + +;;; ===================================================================== +;;; Basic undo-tree data structure functions + +(defun undo-tree-grow (undo) + "Add an UNDO node to current branch of `buffer-undo-tree'." + (let* ((current (undo-tree-current buffer-undo-tree)) + (new (undo-tree-make-node current undo))) + (push new (undo-tree-node-next current)) + (setf (undo-tree-current buffer-undo-tree) new))) + + +(defun undo-tree-grow-backwards (node undo &optional redo) + "Add new node *above* undo-tree NODE, and return new node. +Note that this will overwrite NODE's \"previous\" link, so should +only be used on a detached NODE, never on nodes that are already +part of `buffer-undo-tree'." + (let ((new (undo-tree-make-node-backwards node undo redo))) + (setf (undo-tree-node-previous node) new) + new)) + + +(defun undo-tree-splice-node (node splice) + "Splice NODE into undo tree, below node SPLICE. +Note that this will overwrite NODE's \"next\" and \"previous\" +links, so should only be used on a detached NODE, never on nodes +that are already part of `buffer-undo-tree'." + (setf (undo-tree-node-next node) (undo-tree-node-next splice) + (undo-tree-node-branch node) (undo-tree-node-branch splice) + (undo-tree-node-previous node) splice + (undo-tree-node-next splice) (list node) + (undo-tree-node-branch splice) 0) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) node))) + + +(defun undo-tree-snip-node (node) + "Snip NODE out of undo tree." + (let* ((parent (undo-tree-node-previous node)) + position p) + ;; if NODE is only child, replace parent's next links with NODE's + (if (= (length (undo-tree-node-next parent)) 0) + (setf (undo-tree-node-next parent) (undo-tree-node-next node) + (undo-tree-node-branch parent) (undo-tree-node-branch node)) + ;; otherwise... + (setq position (undo-tree-position node (undo-tree-node-next parent))) + (cond + ;; if active branch used do go via NODE, set parent's branch to active + ;; branch of NODE + ((= (undo-tree-node-branch parent) position) + (setf (undo-tree-node-branch parent) + (+ position (undo-tree-node-branch node)))) + ;; if active branch didn't go via NODE, update parent's branch to point + ;; to same node as before + ((> (undo-tree-node-branch parent) position) + (cl-incf (undo-tree-node-branch parent) + (1- (length (undo-tree-node-next node)))))) + ;; replace NODE in parent's next list with NODE's entire next list + (if (= position 0) + (setf (undo-tree-node-next parent) + (nconc (undo-tree-node-next node) + (cdr (undo-tree-node-next parent)))) + (setq p (nthcdr (1- position) (undo-tree-node-next parent))) + (setcdr p (nconc (undo-tree-node-next node) (cddr p))))) + ;; update previous links of NODE's children + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) parent)))) + + +(defun undo-tree-mapc (--undo-tree-mapc-function-- node) + ;; Apply FUNCTION to NODE and to each node below it. + (let ((stack (list node)) + n) + (while (setq n (pop stack)) + (funcall --undo-tree-mapc-function-- n) + (setq stack (append (undo-tree-node-next n) stack))))) + + +(defmacro undo-tree-num-branches () + "Return number of branches at current undo tree node." + '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree)))) + + +(defun undo-tree-position (node list) + "Find the first occurrence of NODE in LIST. +Return the index of the matching item, or nil of not found. +Comparison is done with `eq'." + (let ((i 0)) + (catch 'found + (while (progn + (when (eq node (car list)) (throw 'found i)) + (cl-incf i) + (setq list (cdr list)))) + nil))) + + +(defvar *undo-tree-id-counter* 0) +(make-variable-buffer-local '*undo-tree-id-counter*) + +(defmacro undo-tree-generate-id () + ;; Generate a new, unique id (uninterned symbol). + ;; The name is made by appending a number to "undo-tree-id". + ;; (Copied from CL package `gensym'.) + `(let ((num (prog1 *undo-tree-id-counter* + (cl-incf *undo-tree-id-counter*)))) + (make-symbol (format "undo-tree-id%d" num)))) + + +(defun undo-tree-decircle (undo-tree) + ;; Nullify PREVIOUS links of UNDO-TREE nodes, to make UNDO-TREE data + ;; structure non-circular. + (undo-tree-mapc + (lambda (node) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) nil))) + (undo-tree-root undo-tree))) + + +(defun undo-tree-recircle (undo-tree) + ;; Recreate PREVIOUS links of UNDO-TREE nodes, to restore circular UNDO-TREE + ;; data structure. + (undo-tree-mapc + (lambda (node) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) node))) + (undo-tree-root undo-tree))) + + + + +;;; ===================================================================== +;;; Undo list and undo changeset utility functions + +(defmacro undo-list-marker-elt-p (elt) + `(markerp (car-safe ,elt))) + +(defmacro undo-list-GCd-marker-elt-p (elt) + ;; Return t if ELT is a marker element whose marker has been moved to the + ;; object-pool, so may potentially have been garbage-collected. + ;; Note: Valid marker undo elements should be uniquely identified as cons + ;; cells with a symbol in the car (replacing the marker), and a number in + ;; the cdr. However, to guard against future changes to undo element + ;; formats, we perform an additional redundant check on the symbol name. + `(and (car-safe ,elt) + (symbolp (car ,elt)) + (let ((str (symbol-name (car ,elt)))) + (and (> (length str) 12) + (string= (substring str 0 12) "undo-tree-id"))) + (numberp (cdr-safe ,elt)))) + + +(defun undo-tree-move-GC-elts-to-pool (elt) + ;; Move elements that can be garbage-collected into `buffer-undo-tree' + ;; object pool, substituting a unique id that can be used to retrieve them + ;; later. (Only markers require this treatment currently.) + (when (undo-list-marker-elt-p elt) + (let ((id (undo-tree-generate-id))) + (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree)) + (setcar elt id)))) + + +(defun undo-tree-restore-GC-elts-from-pool (elt) + ;; Replace object id's in ELT with corresponding objects from + ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if + ;; any object in ELT has been garbage-collected. + (if (undo-list-GCd-marker-elt-p elt) + (when (setcar elt (gethash (car elt) + (undo-tree-object-pool buffer-undo-tree))) + elt) + elt)) + + +(defun undo-list-clean-GCd-elts (undo-list) + ;; Remove object id's from UNDO-LIST that refer to elements that have been + ;; garbage-collected. UNDO-LIST is modified by side-effect. + (while (undo-list-GCd-marker-elt-p (car undo-list)) + (unless (gethash (caar undo-list) + (undo-tree-object-pool buffer-undo-tree)) + (setq undo-list (cdr undo-list)))) + (let ((p undo-list)) + (while (cdr p) + (when (and (undo-list-GCd-marker-elt-p (cadr p)) + (null (gethash (car (cadr p)) + (undo-tree-object-pool buffer-undo-tree)))) + (setcdr p (cddr p))) + (setq p (cdr p)))) + undo-list) + + +(defun undo-list-found-canary-p (undo-list) + (or (eq (car undo-list) 'undo-tree-canary) + (and (null (car undo-list)) + (eq (cadr undo-list) 'undo-tree-canary)))) + + +(defmacro undo-list-pop-changeset (undo-list &optional discard-pos) + ;; Pop changeset from `undo-list'. If DISCARD-POS is non-nil, discard + ;; any position entries from changeset. + `(when (and ,undo-list (not (undo-list-found-canary-p ,undo-list))) + (let (changeset) + ;; discard initial undo boundary(ies) + (while (null (car ,undo-list)) (setq ,undo-list (cdr ,undo-list))) + ;; pop elements up to next undo boundary, discarding position entries + ;; if DISCARD-POS is non-nil + (while (null changeset) + (while (and ,undo-list (car ,undo-list) + (not (undo-list-found-canary-p ,undo-list))) + (if (and ,discard-pos (integerp (car ,undo-list))) + (setq ,undo-list (cdr ,undo-list)) + (push (pop ,undo-list) changeset) + (undo-tree-move-GC-elts-to-pool (car changeset))))) + (nreverse changeset)))) + + +(defun undo-tree-copy-list (undo-list) + ;; Return a deep copy of first changeset in `undo-list'. Object id's are + ;; replaced by corresponding objects from `buffer-undo-tree' object-pool. + (let (copy p) + ;; if first element contains an object id, replace it with object from + ;; pool, discarding element entirely if it's been GC'd + (while (and undo-list (null copy)) + (setq copy + (undo-tree-restore-GC-elts-from-pool (pop undo-list)))) + (when copy + (setq copy (list copy) + p copy) + ;; copy remaining elements, replacing object id's with objects from + ;; pool, or discarding them entirely if they've been GC'd + (while undo-list + (when (setcdr p (undo-tree-restore-GC-elts-from-pool + (undo-copy-list-1 (pop undo-list)))) + (setcdr p (list (cdr p))) + (setq p (cdr p)))) + copy))) + + +(defvar undo-tree-gc-flag nil) + +(defun undo-tree-post-gc () + (setq undo-tree-gc-flag t)) + + +(defun undo-list-transfer-to-tree () + ;; Transfer entries accumulated in `undo-list' to `buffer-undo-tree'. + + ;; `undo-list-transfer-to-tree' should never be called when undo is disabled + ;; (i.e. `buffer-undo-tree' is t) + (cl-assert (not (eq buffer-undo-tree t))) + + ;; if `buffer-undo-tree' is empty, create initial undo-tree + (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree))) + + ;; garbage-collect then repeatedly try to deep-copy `buffer-undo-list' until + ;; we succeed without GC running, in an attempt to mitigate race conditions + ;; with garbage collector corrupting undo history (is this even a thing?!) + (unless (or (null buffer-undo-list) + (undo-list-found-canary-p buffer-undo-list)) + (garbage-collect)) + (let (undo-list changeset) + (setq undo-tree-gc-flag t) + (while undo-tree-gc-flag + (setq undo-tree-gc-flag nil + undo-list (copy-tree buffer-undo-list))) + (setq buffer-undo-list '(nil undo-tree-canary)) + + ;; create new node from first changeset in `undo-list', save old + ;; `buffer-undo-tree' current node, and make new node the current node + (when (setq changeset (undo-list-pop-changeset undo-list)) + (let* ((node (undo-tree-make-node nil changeset)) + (splice (undo-tree-current buffer-undo-tree)) + (size (undo-list-byte-size (undo-tree-node-undo node))) + (count 1)) + (setf (undo-tree-current buffer-undo-tree) node) + ;; grow tree fragment backwards using `undo-list' changesets + (while (setq changeset (undo-list-pop-changeset undo-list)) + (setq node (undo-tree-grow-backwards node changeset)) + (cl-incf size (undo-list-byte-size (undo-tree-node-undo node))) + (cl-incf count)) + + ;; if no undo history has been discarded from `undo-list' since last + ;; transfer, splice new tree fragment onto end of old + ;; `buffer-undo-tree' current node + (if (undo-list-found-canary-p undo-list) + (progn + (setf (undo-tree-node-previous node) splice) + (push node (undo-tree-node-next splice)) + (setf (undo-tree-node-branch splice) 0) + (cl-incf (undo-tree-size buffer-undo-tree) size) + (cl-incf (undo-tree-count buffer-undo-tree) count)) + + ;; if undo history has been discarded, replace entire + ;; `buffer-undo-tree' with new tree fragment + (unless (= (undo-tree-size buffer-undo-tree) 0) + (message "Undo history discarded by Emacs (see `undo-limit') - rebuilding undo-tree")) + (setq node (undo-tree-grow-backwards node nil)) + (setf (undo-tree-root buffer-undo-tree) node) + (setf (undo-tree-size buffer-undo-tree) size) + (setf (undo-tree-count buffer-undo-tree) count) + (setq undo-list '(nil undo-tree-canary)))))) + + ;; discard undo history if necessary + (undo-tree-discard-history)) + + +(defun undo-list-byte-size (undo-list) + ;; Return size (in bytes) of UNDO-LIST + (let ((size 0)) + (dolist (elt undo-list) + (cl-incf size 8) ; cons cells use up 8 bytes + (when (stringp (car-safe elt)) + (cl-incf size (string-bytes (car elt))))) + size)) + + + +(defun undo-list-rebuild-from-tree () + "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'." + (unless (eq buffer-undo-list t) + (undo-list-transfer-to-tree) + (setq buffer-undo-list nil) + (when buffer-undo-tree + (let ((stack (list (list (undo-tree-root buffer-undo-tree))))) + (push (sort (mapcar 'identity (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack) + ;; Traverse tree in depth-and-oldest-first order, but add undo records + ;; on the way down, and redo records on the way up. + (while (or (car stack) + (not (eq (car (nth 1 stack)) + (undo-tree-current buffer-undo-tree)))) + (if (car stack) + (progn + (setq buffer-undo-list + (append (undo-tree-node-undo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (push (sort (mapcar 'identity + (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack)) + (pop stack) + (setq buffer-undo-list + (append (undo-tree-node-redo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (pop (car stack)))))))) + + + + +;;; ===================================================================== +;;; History discarding utility functions + +(defun undo-tree-oldest-leaf (node) + ;; Return oldest leaf node below NODE. + (while (undo-tree-node-next node) + (setq node + (car (sort (mapcar 'identity (undo-tree-node-next node)) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b))))))) + node) + + +(defun undo-tree-discard-node (node) + ;; Discard NODE from `buffer-undo-tree', and return next in line for + ;; discarding. + + ;; don't discard current node + (unless (eq node (undo-tree-current buffer-undo-tree)) + + ;; discarding root node... + (if (eq node (undo-tree-root buffer-undo-tree)) + (cond + ;; should always discard branches before root + ((> (length (undo-tree-node-next node)) 1) + (error "Trying to discard undo-tree root which still\ + has multiple branches")) + ;; don't discard root if current node is only child + ((eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree)) + nil) + ;; discard root + (t + ;; clear any register referring to root + (let ((r (undo-tree-node-register node))) + (when (and r (eq (get-register r) node)) + (set-register r nil))) + ;; make child of root into new root + (setq node (setf (undo-tree-root buffer-undo-tree) + (car (undo-tree-node-next node)))) + ;; update undo-tree size + (cl-decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + (cl-decf (undo-tree-count buffer-undo-tree)) + ;; discard new root's undo data and PREVIOUS link + (setf (undo-tree-node-undo node) nil + (undo-tree-node-redo node) nil + (undo-tree-node-previous node) nil) + ;; if new root has branches, or new root is current node, next node + ;; to discard is oldest leaf, otherwise it's new root + (if (or (> (length (undo-tree-node-next node)) 1) + (eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree))) + (undo-tree-oldest-leaf node) + node))) + + ;; discarding leaf node... + (let* ((parent (undo-tree-node-previous node)) + (current (nth (undo-tree-node-branch parent) + (undo-tree-node-next parent)))) + ;; clear any register referring to the discarded node + (let ((r (undo-tree-node-register node))) + (when (and r (eq (get-register r) node)) + (set-register r nil))) + ;; update undo-tree size + (cl-decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + (cl-decf (undo-tree-count buffer-undo-tree)) + ;; discard leaf + (setf (undo-tree-node-next parent) + (delq node (undo-tree-node-next parent)) + (undo-tree-node-branch parent) + (undo-tree-position current (undo-tree-node-next parent))) + ;; if parent has branches, or parent is current node, next node to + ;; discard is oldest leaf, otherwise it's the parent itself + (if (or (eq parent (undo-tree-current buffer-undo-tree)) + (and (undo-tree-node-next parent) + (or (not (eq parent (undo-tree-root buffer-undo-tree))) + (> (length (undo-tree-node-next parent)) 1)))) + (undo-tree-oldest-leaf parent) + parent))))) + + + +(defun undo-tree-discard-history () + "Discard undo history until we're within memory usage limits +set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'." + + (when (> (undo-tree-size buffer-undo-tree) undo-limit) + ;; if there are no branches off root, first node to discard is root; + ;; otherwise it's leaf node at botom of oldest branch + (let ((node (if (> (length (undo-tree-node-next + (undo-tree-root buffer-undo-tree))) 1) + (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree)) + (undo-tree-root buffer-undo-tree))) + discarded) + + ;; discard nodes until memory use is within `undo-strong-limit' + (while (and node + (> (undo-tree-size buffer-undo-tree) undo-strong-limit)) + (setq node (undo-tree-discard-node node) + discarded t)) + + ;; discard nodes until next node to discard would bring memory use + ;; within `undo-limit' + (while (and node + ;; check first if last discard has brought us within + ;; `undo-limit', in case we can avoid more expensive + ;; `undo-strong-limit' calculation + ;; Note: this assumes undo-strong-limit > undo-limit; + ;; if not, effectively undo-strong-limit = undo-limit + (> (undo-tree-size buffer-undo-tree) undo-limit) + (> (- (undo-tree-size buffer-undo-tree) + ;; if next node to discard is root, the memory we + ;; free-up comes from discarding changesets from its + ;; only child... + (if (eq node (undo-tree-root buffer-undo-tree)) + (+ (undo-list-byte-size + (undo-tree-node-undo + (car (undo-tree-node-next node)))) + (undo-list-byte-size + (undo-tree-node-redo + (car (undo-tree-node-next node))))) + ;; ...otherwise, it comes from discarding changesets + ;; from along with the node itself + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node))) + )) + undo-limit)) + (setq node (undo-tree-discard-node node) + discarded t)) + + (when discarded + (message "Undo history discarded by undo-tree (see `undo-tree-limit')")) + + ;; if we're still over the `undo-outer-limit', discard entire history + (when (and undo-outer-limit + (> (undo-tree-size buffer-undo-tree) undo-outer-limit)) + ;; query first if `undo-ask-before-discard' is set + (if undo-ask-before-discard + (when (yes-or-no-p + (format + "Buffer `%s' undo info is %d bytes long; discard it? " + (buffer-name) (undo-tree-size buffer-undo-tree))) + (setq buffer-undo-tree nil)) + ;; otherwise, discard and display warning + (display-warning + '(undo discard-info) + (concat + (format "Buffer `%s' undo info was %d bytes long.\n" + (buffer-name) (undo-tree-size buffer-undo-tree)) + "The undo info was discarded because it exceeded\ + `undo-outer-limit'. + +This is normal if you executed a command that made a huge change +to the buffer. In that case, to prevent similar problems in the +future, set `undo-outer-limit' to a value that is large enough to +cover the maximum size of normal changes you expect a single +command to make, but not so large that it might exceed the +maximum memory allotted to Emacs. + +If you did not execute any such command, the situation is +probably due to a bug and you should report it. + +You can disable the popping up of this buffer by adding the entry +\(undo discard-info) to the user option `warning-suppress-types', +which is defined in the `warnings' library.\n") + :warning) + (setq buffer-undo-tree nil))) + + ;; if currently displaying the visualizer, redraw it + (when (and buffer-undo-tree + discarded + (or (eq major-mode 'undo-tree-visualizer-mode) + undo-tree-visualizer-parent-buffer + (get-buffer undo-tree-visualizer-buffer-name))) + (let ((undo-tree buffer-undo-tree)) + (with-current-buffer undo-tree-visualizer-buffer-name + (undo-tree-draw-tree undo-tree) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + ))) + + + + +;;; ===================================================================== +;;; Visualizer utility functions + +(defun undo-tree-compute-widths (node) + "Recursively compute widths for nodes below NODE." + (let ((stack (list node)) + res) + (while stack + ;; try to compute widths for node at top of stack + (if (undo-tree-node-p + (setq res (undo-tree-node-compute-widths (car stack)))) + ;; if computation fails, it returns a node whose widths still need + ;; computing, which we push onto the stack + (push res stack) + ;; otherwise, store widths and remove it from stack + (setf (undo-tree-node-lwidth (car stack)) (aref res 0) + (undo-tree-node-cwidth (car stack)) (aref res 1) + (undo-tree-node-rwidth (car stack)) (aref res 2)) + (pop stack))))) + + +(defun undo-tree-node-compute-widths (node) + ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths + ;; (in a vector) if successful. Otherwise, returns a node whose widths need + ;; calculating before NODE's can be calculated. + (let ((num-children (length (undo-tree-node-next node))) + (lwidth 0) (cwidth 0) (rwidth 0) p) + (catch 'need-widths + (cond + ;; leaf nodes have 0 width + ((= 0 num-children) + (setf cwidth 1 + (undo-tree-node-lwidth node) 0 + (undo-tree-node-cwidth node) 1 + (undo-tree-node-rwidth node) 0)) + + ;; odd number of children + ((= (mod num-children 2) 1) + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + ;; if child's widths haven't been computed, return that child + (throw 'need-widths (car p))) + (setq p (cdr p))) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (undo-tree-node-lwidth (car p))) + (throw 'need-widths (car p))) + ;; centre-width is inherited from middle child + (setf cwidth (undo-tree-node-cwidth (car p))) + ;; compute right-width + (cl-incf rwidth (undo-tree-node-rwidth (car p))) + (setq p (cdr p)) + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p)))) + + ;; even number of children + (t + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))) + ;; centre-width is 0 when number of children is even + (setq cwidth 0) + ;; compute right-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))))) + + ;; return left-, centre- and right-widths + (vector lwidth cwidth rwidth)))) + + +(defun undo-tree-clear-visualizer-data (tree) + ;; Clear visualizer data below NODE. + (undo-tree-mapc + (lambda (n) (undo-tree-node-clear-visualizer-data n)) + (undo-tree-root tree))) + + +(defun undo-tree-node-unmodified-p (node &optional mtime) + ;; Return non-nil if NODE corresponds to a buffer state that once upon a + ;; time was unmodified. If a file modification time MTIME is specified, + ;; return non-nil if the corresponding buffer state really is unmodified. + (let (changeset ntime) + (setq changeset + (or (undo-tree-node-redo node) + (and (setq changeset (car (undo-tree-node-next node))) + (undo-tree-node-undo changeset))) + ntime + (catch 'found + (dolist (elt changeset) + (when (and (consp elt) (eq (car elt) t) (consp (cdr elt)) + (throw 'found (cdr elt))))))) + (and ntime + (or (null mtime) + ;; high-precision timestamps + (if (listp (cdr ntime)) + (equal ntime mtime) + ;; old-style timestamps + (and (= (car ntime) (car mtime)) + (= (cdr ntime) (cadr mtime)))))))) + + + + +;;; ===================================================================== +;;; Undo-in-region utility functions + +;; `undo-elt-in-region' uses this as a dynamically-scoped variable +(defvar undo-adjusted-markers nil) + + +(defun undo-tree-pull-undo-in-region-branch (start end) + ;; Pull out entries from undo changesets to create a new undo-in-region + ;; branch, which undoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets, before rejoining the + ;; existing undo tree history. Repeated calls will, if appropriate, extend + ;; the current undo-in-region branch rather than creating a new one. + + ;; if we're just reverting the last redo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-redo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' results in + ;; errors when the code is byte-compiled, presumably because the + ;; Lisp reader generates a single cons, and that same cons gets used + ;; each call. + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-undo-in-region + (undo-tree-repeated-undo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice original-fragment original-splice original-current + got-visible-elt undo-list elt) + + ;; --- initialisation --- + (cond + ;; if this is a repeated undo in the same region, start pulling changes + ;; from NODE at which undo-in-region branch is attached, and detatch + ;; the branch, using it as initial FRAGMENT of branch being constructed + (repeated-undo-in-region + (setq original-current node + fragment (car (undo-tree-node-next node)) + splice node) + ;; undo up to node at which undo-in-region branch is attached + ;; (recognizable as first node with more than one branch) + (let ((mark-active nil)) + (while (= (length (undo-tree-node-next node)) 1) + (undo-tree-undo-1) + (setq fragment node + node (undo-tree-current buffer-undo-tree)))) + (when (eq splice node) (setq splice nil)) + ;; detatch undo-in-region branch + (setf (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node)) + (undo-tree-node-previous fragment) nil + original-fragment fragment + original-splice node)) + + ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (undo-tree-make-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (undo-tree-make-node + splice + (undo-copy-list (undo-tree-node-undo node)) + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment)) + splice nil + node (undo-tree-current buffer-undo-tree)))) + + + ;; --- pull undo-in-region elements into branch --- + ;; work backwards up tree, pulling out undo elements within region until + ;; we've got one that undoes a visible change (insertion or deletion) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-undo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node))) + elt (cadr undo-list)) + (if fragment + (progn + (setq fragment (undo-tree-grow-backwards fragment undo-list)) + (unless splice (setq splice fragment))) + (setq fragment (undo-tree-make-node nil undo-list)) + (setq splice fragment)) + + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously undone before + ;; kept element, as kept element will now be undone first + (undo-tree-adjust-elements-to-elt splice elt) + ;; move kept element to undo-in-region changeset, adjusting its + ;; buffer position as it will now be undone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list)))) + (setq r (cdr r)) + (setcdr undo-list (cddr undo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr undo-list (cddr undo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq undo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; undo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq undo-list (cdr undo-list)))) + + ;; process next element of current changeset + (setq elt (cadr undo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-undo fragment)) + (pop (undo-tree-node-undo fragment)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (when (eq splice fragment) (setq splice nil)) + (setq fragment (car (undo-tree-node-next fragment)))) + ;; process changeset from next node up the tree + (setq node (undo-tree-node-previous node)))) + + ;; pop dummy nil from front of `region-changeset' + (setq region-changeset (cdr region-changeset)) + + + ;; --- integrate branch into tree --- + ;; if no undo-in-region elements were found, restore undo tree + (if (null region-changeset) + (when original-current + (push original-fragment (undo-tree-node-next original-splice)) + (setf (undo-tree-node-branch original-splice) 0 + (undo-tree-node-previous original-fragment) original-splice) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) + original-current)) + (undo-tree-redo-1))) + nil) ; return nil to indicate failure + + ;; otherwise... + ;; need to undo up to node where new branch will be attached, to + ;; ensure redo entries are populated, and then redo back to where we + ;; started + (let ((mark-active nil) + (current (undo-tree-current buffer-undo-tree))) + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-undo-1)) + (while (not (eq (undo-tree-current buffer-undo-tree) current)) + (undo-tree-redo-1))) + + (cond + ;; if there's no remaining fragment, just create undo-in-region node + ;; and attach it to parent of last node from which elements were + ;; pulled + ((null fragment) + (setq fragment (undo-tree-make-node node region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if no splice point has been set, add undo-in-region node to top of + ;; fragment and attach it to parent of last node from which elements + ;; were pulled + ((null splice) + (setq fragment (undo-tree-grow-backwards fragment region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if fragment contains nodes, attach fragment to parent of last node + ;; from which elements were pulled, and splice in undo-in-region node + (t + (setf (undo-tree-node-previous fragment) node) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; if this is a repeated undo-in-region, then we've left the current + ;; node at the original splice-point; we need to set the current + ;; node to the equivalent node on the undo-in-region branch and redo + ;; back to where we started + (when repeated-undo-in-region + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous original-fragment)) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) splice)) + (undo-tree-redo-1 nil 'preserve-undo)))) + ;; splice new undo-in-region node into fragment + (setq node (undo-tree-make-node nil region-changeset)) + (undo-tree-splice-node node splice) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) node))) + + ;; update undo-tree size + (setq node (undo-tree-node-previous fragment)) + (while (progn + (and (setq node (car (undo-tree-node-next node))) + (not (eq node original-fragment)) + (cl-incf (undo-tree-count buffer-undo-tree)) + (cl-incf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node))))))) + t) ; indicate undo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-pull-redo-in-region-branch (start end) + ;; Pull out entries from redo changesets to create a new redo-in-region + ;; branch, which redoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets. Repeated calls will, + ;; if appropriate, extend the current redo-in-region branch rather than + ;; creating a new one. + + ;; if we're just reverting the last undo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-undo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre + ;; errors when the code is byte-compiled, where parts of the lists + ;; appear to survive across different calls to this function. An + ;; obscure byte-compiler bug, perhaps? + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-redo-in-region + (undo-tree-repeated-redo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice got-visible-elt redo-list elt) + + ;; --- inisitalisation --- + (cond + ;; if this is a repeated redo-in-region, detach fragment below current + ;; node + (repeated-redo-in-region + (when (setq fragment (car (undo-tree-node-next node))) + (setf (undo-tree-node-previous fragment) nil + (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node))))) + ;; if this is a new redo-in-region, initial fragment is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (undo-tree-make-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (undo-tree-make-node + splice nil + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment))))) + + + ;; --- pull redo-in-region elements into branch --- + ;; work down fragment, pulling out redo elements within region until + ;; we've got one that redoes a visible change (insertion or deletion) + (setq node fragment) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-redo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq redo-list (push nil (undo-tree-node-redo node)) + elt (cadr redo-list)) + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously redone before + ;; kept element, as kept element will now be redone first + (undo-tree-adjust-elements-to-elt fragment elt t) + ;; move kept element to redo-in-region changeset, adjusting its + ;; buffer position as it will now be redone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1))) + (setq r (cdr r)) + (setcdr redo-list (cddr redo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr redo-list (cddr redo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq redo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; redo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq redo-list (cdr redo-list)))) + + ;; process next element of current changeset + (setq elt (cadr redo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-redo node)) + (pop (undo-tree-node-undo node)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (if (eq fragment node) + (setq fragment (car (undo-tree-node-next fragment))) + (undo-tree-snip-node node))) + ;; process changeset from next node in fragment + (setq node (car (undo-tree-node-next node))))) + + ;; pop dummy nil from front of `region-changeset' + (setq region-changeset (cdr region-changeset)) + + + ;; --- integrate branch into tree --- + (setq node (undo-tree-current buffer-undo-tree)) + ;; if no redo-in-region elements were found, restore undo tree + (if (null (car region-changeset)) + (when (and repeated-redo-in-region fragment) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + nil) ; return nil to indicate failure + + ;; otherwise, add redo-in-region node to top of fragment, and attach + ;; it below current node + (setq fragment + (if fragment + (undo-tree-grow-backwards fragment nil region-changeset) + (undo-tree-make-node nil nil region-changeset))) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; update undo-tree size + (unless repeated-redo-in-region + (setq node fragment) + (while (and (setq node (car (undo-tree-node-next node))) + (cl-incf (undo-tree-count buffer-undo-tree)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size + (undo-tree-node-redo node)))))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo fragment))) + t) ; indicate redo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below) + "Adjust buffer positions of undo elements, starting at NODE's +and going up the tree (or down the active branch if BELOW is +non-nil) and through the nodes' undo elements until we reach +UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset +of either NODE itself or some node above it in the tree." + (let ((delta (list (undo-delta undo-elt))) + (undo-list (undo-tree-node-undo node))) + ;; adjust elements until we reach UNDO-ELT + (while (and (car undo-list) + (not (eq (car undo-list) undo-elt))) + (setcar undo-list + (undo-tree-apply-deltas (car undo-list) delta -1)) + ;; move to next undo element in list, or to next node if we've run out + ;; of elements + (unless (car (setq undo-list (cdr undo-list))) + (if below + (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (setq node (undo-tree-node-previous node))) + (setq undo-list (undo-tree-node-undo node)))))) + + + +(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn) + ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN + ;; (only useful value for SGN is -1). + (let (position offset) + (dolist (delta deltas) + (setq position (car delta) + offset (* (cdr delta) (or sgn 1))) + (cond + ;; POSITION + ((integerp undo-elt) + (when (>= undo-elt position) + (setq undo-elt (- undo-elt offset)))) + ;; nil (or any other atom) + ((atom undo-elt)) + ;; (TEXT . POSITION) + ((stringp (car undo-elt)) + (let ((text-pos (abs (cdr undo-elt))) + (point-at-end (< (cdr undo-elt) 0))) + (if (>= text-pos position) + (setcdr undo-elt (* (if point-at-end -1 1) + (- text-pos offset)))))) + ;; (BEGIN . END) + ((integerp (car undo-elt)) + (when (>= (car undo-elt) position) + (setcar undo-elt (- (car undo-elt) offset)) + (setcdr undo-elt (- (cdr undo-elt) offset)))) + ;; (nil PROPERTY VALUE BEG . END) + ((null (car undo-elt)) + (let ((tail (nthcdr 3 undo-elt))) + (when (>= (car tail) position) + (setcar tail (- (car tail) offset)) + (setcdr tail (- (cdr tail) offset))))) + )) + undo-elt)) + + + +(defun undo-tree-repeated-undo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))) + (eq (undo-tree-node-undo-beginning node) start) + (eq (undo-tree-node-undo-end node) end)))) + + +(defun undo-tree-repeated-redo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (eq (undo-tree-node-redo-beginning node) start) + (eq (undo-tree-node-redo-end node) end)))) + + +;; Return non-nil if undo-in-region between START and END is simply +;; reverting the last redo-in-region +(defalias 'undo-tree-reverting-undo-in-region-p + 'undo-tree-repeated-undo-in-region-p) + + +;; Return non-nil if redo-in-region between START and END is simply +;; reverting the last undo-in-region +(defalias 'undo-tree-reverting-redo-in-region-p + 'undo-tree-repeated-redo-in-region-p) + + + + +;;; ===================================================================== +;;; Undo-tree commands + +(defvar undo-tree-timer nil) + +;;;###autoload +(define-minor-mode undo-tree-mode + "Toggle undo-tree mode. +With no argument, this command toggles the mode. +A positive prefix argument turns the mode on. +A negative prefix argument turns it off. + +Undo-tree-mode replaces Emacs' standard undo feature with a more +powerful yet easier to use version, that treats the undo history +as what it is: a tree. + +The following keys are available in `undo-tree-mode': + + \\{undo-tree-map} + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-mode-map}" + + :init-value nil ; init value + :lighter undo-tree-mode-lighter ; lighter + :keymap undo-tree-map ; keymap + + (cond + (undo-tree-mode ; enabling `undo-tree-mode' + (set (make-local-variable 'undo-limit) + (if undo-tree-limit + (max undo-limit undo-tree-limit) + most-positive-fixnum)) + (set (make-local-variable 'undo-strong-limit) + (if undo-tree-limit + (max undo-strong-limit undo-tree-strong-limit) + most-positive-fixnum)) + (set (make-local-variable 'undo-outer-limit) ; null `undo-outer-limit' means no limit + (when (and undo-tree-limit undo-outer-limit undo-outer-limit) + (max undo-outer-limit undo-tree-outer-limit))) + (when (null undo-tree-limit) + (setq undo-tree-timer + (run-with-idle-timer 5 'repeat #'undo-list-transfer-to-tree))) + (add-hook 'post-gc-hook #'undo-tree-post-gc nil)) + + (t ; disabling `undo-tree-mode' + ;; rebuild `buffer-undo-list' from tree so Emacs undo can work + (undo-list-rebuild-from-tree) + (setq buffer-undo-tree nil) + (remove-hook 'post-gc-hook #'undo-tree-post-gc 'local) + (when (timerp undo-tree-timer) (cancel-timer undo-tree-timer)) + (kill-local-variable 'undo-limit) + (kill-local-variable 'undo-strong-limit) + (kill-local-variable 'undo-outer-limit)))) + + +(defun turn-on-undo-tree-mode (&optional print-message) + "Enable `undo-tree-mode' in the current buffer, when appropriate. +Some major modes implement their own undo system, which should +not normally be overridden by `undo-tree-mode'. This command does +not enable `undo-tree-mode' in such buffers. If you want to force +`undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1) +instead. + +The heuristic used to detect major modes in which +`undo-tree-mode' should not be used is to check whether either +the `undo' command has been remapped, or the default undo +keybindings (C-/ and C-_) have been overridden somewhere other +than in the global map. In addition, `undo-tree-mode' will not be +enabled if the buffer's `major-mode' appears in +`undo-tree-incompatible-major-modes'." + (interactive "p") + (if (or (key-binding [remap undo]) + (undo-tree-overridden-undo-bindings-p) + (memq major-mode undo-tree-incompatible-major-modes)) + (when print-message + (message "Buffer does not support undo-tree-mode;\ + undo-tree-mode NOT enabled")) + (undo-tree-mode 1))) + + +(defun undo-tree-overridden-undo-bindings-p () + "Returns t if default undo bindings are overridden, nil otherwise. +Checks if either of the default undo key bindings (\"C-/\" or +\"C-_\") are overridden in the current buffer by any keymap other +than the global one. (So global redefinitions of the default undo +key bindings do not count.)" + (let ((binding1 (lookup-key (current-global-map) [?\C-/])) + (binding2 (lookup-key (current-global-map) [?\C-_]))) + (global-set-key [?\C-/] 'undo) + (global-set-key [?\C-_] 'undo) + (unwind-protect + (or (and (key-binding [?\C-/]) + (not (eq (key-binding [?\C-/]) 'undo))) + (and (key-binding [?\C-_]) + (not (eq (key-binding [?\C-_]) 'undo)))) + (global-set-key [?\C-/] binding1) + (global-set-key [?\C-_] binding2)))) + + +;;;###autoload +(define-globalized-minor-mode global-undo-tree-mode + undo-tree-mode turn-on-undo-tree-mode) + + + +(defun undo-tree-undo (&optional arg) + "Undo changes. +Repeat this command to undo more changes. +A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only undo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits undo to +changes within the current region." + (interactive "*P") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-tree-undo-1 arg) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))) + + +(defun undo-tree-undo-1 (&optional arg preserve-redo preserve-timestamps) + ;; Internal undo function. An active mark in `transient-mark-mode', or + ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-REDO + ;; causes the existing redo record to be preserved, rather than replacing it + ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS + ;; disables updating of timestamps in visited undo-tree nodes. (This latter + ;; should *only* be used when temporarily visiting another undo state and + ;; immediately returning to the original state afterwards. Otherwise, it + ;; could cause history-discarding errors.) + (let ((undo-in-progress t) + (undo-in-region (and undo-tree-enable-undo-in-region + (or (region-active-p) + (and arg (not (numberp arg)))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (_ (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at top of undo tree + (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) + (user-error "No further undo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and undo-in-region + (not (undo-tree-pull-undo-in-region-branch + (region-beginning) (region-end)))) + (user-error "No further undo information for region")) + + ;; remove any GC'd elements from node's undo list + (setq current (undo-tree-current buffer-undo-tree)) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + ;; undo one record from undo tree + (when undo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current))) + (undo-boundary) + + ;; if preserving old redo record, discard new redo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-redo + (progn + (undo-list-pop-changeset buffer-undo-list) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + ;; otherwise, record redo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's redo record, replacing + ;; existing entry if one already exists + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-pop-changeset buffer-undo-list 'discard-pos)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + + ;; rewind current node and update timestamp + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous (undo-tree-current buffer-undo-tree))) + (unless preserve-timestamps + (setf (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree)) + (current-time))) + + ;; if undoing-in-region, record current node, region and direction so we + ;; can tell if undo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode'; if not, erase any leftover data + (if (not undo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + ;; note: we deliberately want to store the region information in the + ;; node *below* the now current one + (setf (undo-tree-node-undo-beginning current) (region-beginning) + (undo-tree-node-undo-end current) (region-end)) + (set-marker pos nil))) + + ;; undo deactivates mark unless undoing-in-region + (setq deactivate-mark (not undo-in-region)))) + + + +(defun undo-tree-redo (&optional arg) + "Redo changes. A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only redo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits redo to +changes within the current region." + (interactive "*P") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-tree-redo-1 arg) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))) + + +(defun undo-tree-redo-1 (&optional arg preserve-undo preserve-timestamps) + ;; Internal redo function. An active mark in `transient-mark-mode', or + ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-UNDO + ;; causes the existing redo record to be preserved, rather than replacing it + ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS + ;; disables updating of timestamps in visited undo-tree nodes. (This latter + ;; should *only* be used when temporarily visiting another undo state and + ;; immediately returning to the original state afterwards. Otherwise, it + ;; could cause history-discarding errors.) + (let ((undo-in-progress t) + (redo-in-region (and undo-tree-enable-undo-in-region + (or (region-active-p) + (and arg (not (numberp arg)))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (_ (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at bottom of undo tree + (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree))) + (user-error "No further redo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and redo-in-region + (not (undo-tree-pull-redo-in-region-branch + (region-beginning) (region-end)))) + (user-error "No further redo information for region")) + + ;; get next node (but DON'T advance current node in tree yet, in case + ;; redoing fails) + (setq current (undo-tree-current buffer-undo-tree) + current (nth (undo-tree-node-branch current) + (undo-tree-node-next current))) + ;; remove any GC'd elements from node's redo list + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + ;; redo one record from undo tree + (when redo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current))) + (undo-boundary) + ;; advance current node in tree + (setf (undo-tree-current buffer-undo-tree) current) + + ;; if preserving old undo record, discard new undo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-undo + (progn + (undo-list-pop-changeset buffer-undo-list) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + ;; otherwise, record undo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's undo record, replacing + ;; existing entry if one already exists + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-pop-changeset buffer-undo-list 'discard-pos)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + + ;; update timestamp + (unless preserve-timestamps + (setf (undo-tree-node-timestamp current) (current-time))) + + ;; if redoing-in-region, record current node, region and direction so we + ;; can tell if redo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode' + (if (not redo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + (setf (undo-tree-node-redo-beginning current) (region-beginning) + (undo-tree-node-redo-end current) (region-end)) + (set-marker pos nil))) + + ;; redo deactivates the mark unless redoing-in-region + (setq deactivate-mark (not redo-in-region)))) + + + +(defun undo-tree-switch-branch (branch) + "Switch to a different BRANCH of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo'." + (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg)) + (and (not (eq buffer-undo-list t)) + (undo-list-transfer-to-tree) + (let ((b (undo-tree-node-branch + (undo-tree-current + buffer-undo-tree)))) + (cond + ;; switch to other branch if only 2 + ((= (undo-tree-num-branches) 2) (- 1 b)) + ;; prompt if more than 2 + ((> (undo-tree-num-branches) 2) + (read-number + (format "Branch (0-%d, on %d): " + (1- (undo-tree-num-branches)) b))) + )))))) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; sanity check branch number + (when (<= (undo-tree-num-branches) 1) + (user-error "Not at undo branch point")) + (when (or (< branch 0) (> branch (1- (undo-tree-num-branches)))) + (user-error "Invalid branch number")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; switch branch + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + branch) + (message "Switched to branch %d" branch)) + + +(defun undo-tree-set (node &optional preserve-timestamps) + ;; Set buffer to state corresponding to NODE. Returns intersection point + ;; between path back from current node and path back from selected NODE. + ;; Non-nil PRESERVE-TIMESTAMPS disables updating of timestamps in visited + ;; undo-tree nodes. (This should *only* be used when temporarily visiting + ;; another undo state and immediately returning to the original state + ;; afterwards. Otherwise, it could cause history-discarding errors.) + (let ((path (make-hash-table :test 'eq)) + (n node)) + (puthash (undo-tree-root buffer-undo-tree) t path) + ;; build list of nodes leading back from selected node to root, updating + ;; branches as we go to point down to selected node + (while (progn + (puthash n t path) + (when (undo-tree-node-previous n) + (setf (undo-tree-node-branch (undo-tree-node-previous n)) + (undo-tree-position + n (undo-tree-node-next (undo-tree-node-previous n)))) + (setq n (undo-tree-node-previous n))))) + ;; work backwards from current node until we intersect path back from + ;; selected node + (setq n (undo-tree-current buffer-undo-tree)) + (while (not (gethash n path)) + (setq n (undo-tree-node-previous n))) + ;; ascend tree until intersection node + (while (not (eq (undo-tree-current buffer-undo-tree) n)) + (undo-tree-undo-1 nil nil preserve-timestamps)) + ;; descend tree until selected node + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-redo-1 nil nil preserve-timestamps)) + n)) ; return intersection node + + + +(defun undo-tree-save-state-to-register (register) + "Store current undo-tree state to REGISTER. +The saved state can be restored using +`undo-tree-restore-state-from-register'. +Argument is a character, naming the register." + (interactive "cUndo-tree state to register: ") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; save current node to REGISTER + (set-register + register (registerv-make + (undo-tree-make-register-data + (current-buffer) (undo-tree-current buffer-undo-tree)) + :print-func 'undo-tree-register-data-print-func)) + ;; record REGISTER in current node, for visualizer + (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree)) + register)) + + + +(defun undo-tree-restore-state-from-register (register) + "Restore undo-tree state from REGISTER. +The state must be saved using `undo-tree-save-state-to-register'. +Argument is a character, naming the register." + (interactive "*cRestore undo-tree state from register: ") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer, or if register doesn't contain + ;; an undo-tree node + (let ((data (registerv-data (get-register register)))) + (cond + ((eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ((not (undo-tree-register-data-p data)) + (user-error "Register doesn't contain undo-tree state")) + ((not (eq (current-buffer) (undo-tree-register-data-buffer data))) + (user-error "Register contains undo-tree state for a different buffer"))) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; restore buffer state corresponding to saved node + (undo-tree-set (undo-tree-register-data-node data)))) + + + + +;;; ===================================================================== +;;; Undo-tree menu bar + +(defvar undo-tree-old-undo-menu-item nil) + +(defun undo-tree-update-menu-bar () + "Update `undo-tree-mode' Edit menu items." + (if undo-tree-mode + (progn + ;; save old undo menu item, and install undo/redo menu items + (setq undo-tree-old-undo-menu-item + (cdr (assq 'undo (lookup-key global-map [menu-bar edit])))) + (define-key (lookup-key global-map [menu-bar edit]) + [undo] '(menu-item "Undo" undo-tree-undo + :enable (and undo-tree-mode + (not buffer-read-only) + (not (eq t buffer-undo-list)) + (not (eq nil buffer-undo-tree)) + (undo-tree-node-previous + (undo-tree-current buffer-undo-tree))) + :help "Undo last operation")) + (define-key-after (lookup-key global-map [menu-bar edit]) + [redo] '(menu-item "Redo" undo-tree-redo + :enable (and undo-tree-mode + (not buffer-read-only) + (not (eq t buffer-undo-list)) + (not (eq nil buffer-undo-tree)) + (undo-tree-node-next + (undo-tree-current buffer-undo-tree))) + :help "Redo last operation") + 'undo)) + ;; uninstall undo/redo menu items + (define-key (lookup-key global-map [menu-bar edit]) + [undo] undo-tree-old-undo-menu-item) + (define-key (lookup-key global-map [menu-bar edit]) + [redo] nil))) + +(add-hook 'menu-bar-update-hook 'undo-tree-update-menu-bar) + + + + +;;; ===================================================================== +;;; Persistent storage commands + +(defun undo-tree-make-history-save-file-name (file) + "Create the undo history file name for FILE. +Normally this is the file's name with \".\" prepended and +\".~undo-tree~\" appended. + +A match for FILE is sought in `undo-tree-history-directory-alist' +\(see the documentation of that variable for details\). If the +directory for the backup doesn't exist, it is created." + (let* ((backup-directory-alist undo-tree-history-directory-alist) + (name (make-backup-file-name-1 file))) + (concat (file-name-directory name) "." (file-name-nondirectory name) + ".~undo-tree~"))) + + +(defun undo-tree-save-history (&optional filename overwrite) + "Store undo-tree history to file. + +If optional argument FILENAME is omitted, default save file is +\"..~undo-tree\" if buffer is visiting a file. +Otherwise, prompt for one. + +If OVERWRITE is non-nil, any existing file will be overwritten +without asking for confirmation." + (interactive) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-list-transfer-to-tree) + (when (and buffer-undo-tree (not (eq buffer-undo-tree t))) + (undo-tree-kill-visualizer) + ;; should be cleared already by killing the visualizer, but writes + ;; unreasable data if not for some reason, so just in case... + (undo-tree-clear-visualizer-data buffer-undo-tree) + (let ((buff (current-buffer)) + tree) + ;; get filename + (unless filename + (setq filename + (if buffer-file-name + (undo-tree-make-history-save-file-name buffer-file-name) + (expand-file-name (read-file-name "File to save in: ") nil)))) + (when (or (not (file-exists-p filename)) + overwrite + (yes-or-no-p (format "Overwrite \"%s\"? " filename))) + ;; transform undo-tree into non-circular structure, and make tmp copy + (setq tree (undo-tree-copy buffer-undo-tree)) + (undo-tree-decircle tree) + ;; discard undo-tree object pool before saving + (setf (undo-tree-object-pool tree) nil) + ;; run pre-save transformer functions + (when undo-tree-pre-save-element-functions + (undo-tree-mapc + (lambda (node) + (let ((changeset (undo-tree-node-undo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-undo node) changeset)) + (let ((changeset (undo-tree-node-redo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-redo node) changeset))) + (undo-tree-root tree))) + ;; print undo-tree to file + ;; NOTE: We use `with-temp-buffer' instead of `with-temp-file' to + ;; allow `auto-compression-mode' to take effect, in case user + ;; has overridden or advised the default + ;; `undo-tree-make-history-save-file-name' to add a compressed + ;; file extension. + (with-auto-compression-mode + (with-temp-buffer + (prin1 (sha1 buff) (current-buffer)) + (terpri (current-buffer)) + (let ((print-circle t)) (prin1 tree (current-buffer))) + (write-region nil nil filename))))))) + + + +(defun undo-tree-load-history (&optional filename noerror) + "Load undo-tree history from file, for the current buffer. + +If optional argument FILENAME is null, default load file is +\"..~undo-tree\" if buffer is visiting a file. +Otherwise, prompt for one. + +If optional argument NOERROR is non-nil, return nil instead of +signaling an error if file is not found. + +Note this will overwrite any existing undo history." + (interactive) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; get filename + (unless filename + (setq filename + (if buffer-file-name + (undo-tree-make-history-save-file-name buffer-file-name) + (expand-file-name (read-file-name "File to load from: ") nil)))) + + ;; attempt to read undo-tree from FILENAME + (catch 'load-error + (unless (file-exists-p filename) + (if noerror + (throw 'load-error nil) + (error "File \"%s\" does not exist; could not load undo-tree history" + filename))) + (let (buff hash tree) + (setq buff (current-buffer)) + (with-auto-compression-mode + (with-temp-buffer + (insert-file-contents filename) + (goto-char (point-min)) + (condition-case nil + (setq hash (read (current-buffer))) + (error + (kill-buffer nil) + (funcall (if noerror #'message #'user-error) + "Error reading undo-tree history from \"%s\"" filename) + (throw 'load-error nil))) + (unless (string= (sha1 buff) hash) + (kill-buffer nil) + (funcall (if noerror 'message 'user-error) + "Buffer has been modified; could not load undo-tree history") + (throw 'load-error nil)) + (condition-case nil + (setq tree (read (current-buffer))) + (error + (kill-buffer nil) + (funcall (if noerror #'message #'error) + "Error reading undo-tree history from \"%s\"" filename) + (throw 'load-error nil))) + (kill-buffer nil))) + ;; run post-load transformer functions + (when undo-tree-post-load-element-functions + (undo-tree-mapc + (lambda (node) + (let ((changeset (undo-tree-node-undo node))) + (run-hook-wrapped + 'undo-tree-post-load-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-undo node) changeset)) + (let ((changeset (undo-tree-node-redo node))) + (run-hook-wrapped + 'undo-tree-post-load-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-redo node) changeset))) + (undo-tree-root tree))) ;; initialise empty undo-tree object pool + (setf (undo-tree-object-pool tree) + (make-hash-table :test 'eq :weakness 'value)) + ;; restore circular undo-tree data structure + (undo-tree-recircle tree) + ;; create undo-tree object pool + (setf (undo-tree-object-pool tree) + (make-hash-table :test 'eq :weakness 'value)) + (setq buffer-undo-tree tree + buffer-undo-list '(nil undo-tree-canary))))) + + + +;; Versions of save/load functions for use in hooks +(defun undo-tree-save-history-from-hook () + (when (and undo-tree-mode undo-tree-auto-save-history + (not (eq buffer-undo-list t)) + buffer-file-name + (file-writable-p + (undo-tree-make-history-save-file-name buffer-file-name))) + (undo-tree-save-history nil 'overwrite) nil)) + +(define-obsolete-function-alias + 'undo-tree-save-history-hook 'undo-tree-save-history-from-hook + "`undo-tree-save-history-hook' is obsolete since undo-tree + version 0.6.6. Use `undo-tree-save-history-from-hook' instead.") + + +(defun undo-tree-load-history-from-hook () + (when (and undo-tree-mode undo-tree-auto-save-history + (not (eq buffer-undo-list t)) + (not revert-buffer-in-progress-p)) + (undo-tree-load-history nil 'noerror))) + +(define-obsolete-function-alias + 'undo-tree-load-history-hook 'undo-tree-load-history-from-hook + "`undo-tree-load-history-hook' is obsolete since undo-tree + version 0.6.6. Use `undo-tree-load-history-from-hook' instead.") + + +;; install history-auto-save hooks +(add-hook 'write-file-functions #'undo-tree-save-history-from-hook) +(add-hook 'kill-buffer-hook #'undo-tree-save-history-from-hook) +(add-hook 'find-file-hook #'undo-tree-load-history-from-hook) + + + + +;;; ===================================================================== +;;; Visualizer drawing functions + +(defun undo-tree-visualize () + "Visualize the current buffer's undo tree." + (interactive "*") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + (deactivate-mark) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; add hook to kill visualizer buffer if original buffer is changed + (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t) + ;; prepare *undo-tree* buffer, then draw tree in it + (let ((undo-tree buffer-undo-tree) + (buff (current-buffer)) + (display-buffer-mark-dedicated 'soft)) + (switch-to-buffer-other-window + (get-buffer-create undo-tree-visualizer-buffer-name)) + (setq undo-tree-visualizer-parent-buffer buff) + (setq undo-tree-visualizer-parent-mtime + (and (buffer-file-name buff) + (nth 5 (file-attributes (buffer-file-name buff))))) + (setq undo-tree-visualizer-initial-node (undo-tree-current undo-tree)) + (setq undo-tree-visualizer-spacing + (undo-tree-visualizer-calculate-spacing)) + (make-local-variable 'undo-tree-visualizer-timestamps) + (make-local-variable 'undo-tree-visualizer-diff) + (setq buffer-undo-tree undo-tree) + (undo-tree-visualizer-mode) + ;; FIXME; don't know why `undo-tree-visualizer-mode' clears this + (setq buffer-undo-tree undo-tree) + (set (make-local-variable 'undo-tree-visualizer-lazy-drawing) + (or (eq undo-tree-visualizer-lazy-drawing t) + (and (numberp undo-tree-visualizer-lazy-drawing) + (>= (undo-tree-count undo-tree) + undo-tree-visualizer-lazy-drawing)))) + (when undo-tree-visualizer-diff (undo-tree-visualizer-show-diff)) + (let ((inhibit-read-only t)) (undo-tree-draw-tree undo-tree)))) + + +(defun undo-tree-kill-visualizer (&rest _dummy) + ;; Kill visualizer. Added to `before-change-functions' hook of original + ;; buffer when visualizer is invoked. + (unless (or undo-tree-inhibit-kill-visualizer + (null (get-buffer undo-tree-visualizer-buffer-name))) + (with-current-buffer undo-tree-visualizer-buffer-name + (undo-tree-visualizer-quit)))) + + + +(defun undo-tree-draw-tree (undo-tree) + ;; Draw undo-tree in current buffer starting from NODE (or root if nil). + (let ((inhibit-read-only t) + (node (if undo-tree-visualizer-lazy-drawing + (undo-tree-current undo-tree) + (undo-tree-root undo-tree)))) + (erase-buffer) + (setq undo-tree-visualizer-needs-extending-down nil + undo-tree-visualizer-needs-extending-up nil) + (undo-tree-clear-visualizer-data undo-tree) + (undo-tree-compute-widths node) + ;; lazy drawing starts vertically centred and displaced horizontally to + ;; the left (window-width/4), since trees will typically grow right + (if undo-tree-visualizer-lazy-drawing + (progn + (undo-tree-move-down (/ (window-height) 2)) + (undo-tree-move-forward (max 2 (/ (window-width) 4)))) ; left margin + ;; non-lazy drawing starts in centre at top of buffer + (undo-tree-move-down 1) ; top margin + (undo-tree-move-forward + (max (/ (window-width) 2) + (+ (undo-tree-node-char-lwidth node) + ;; add space for left part of left-most time-stamp + (if undo-tree-visualizer-timestamps + (/ (- undo-tree-visualizer-spacing 4) 2) + 0) + 2)))) ; left margin + ;; link starting node to its representation in visualizer + (setf (undo-tree-node-marker node) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker node) nil) + (move-marker (undo-tree-node-marker node) (point)) + ;; draw undo-tree + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) + node-list) + (if (not undo-tree-visualizer-lazy-drawing) + (undo-tree-extend-down node t) + (undo-tree-extend-down node) + (undo-tree-extend-up node) + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (while node-list (undo-tree-extend-down (pop node-list))))) + ;; highlight active branch + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch + (or undo-tree-visualizer-needs-extending-up + (undo-tree-root undo-tree)))) + ;; highlight current node + (undo-tree-draw-node (undo-tree-current undo-tree) 'current))) + + +(defun undo-tree-extend-down (node &optional bottom) + ;; Extend tree downwards starting from NODE and point. If BOTTOM is t, + ;; extend all the way down to the leaves. If BOTTOM is a node, extend down + ;; as far as that node. If BOTTOM is an integer, extend down as far as that + ;; line. Otherwise, only extend visible portion of tree. NODE is assumed to + ;; already have a node marker. Returns non-nil if anything was actually + ;; extended. + (let ((extended nil) + (cur-stack (list node)) + next-stack) + ;; don't bother extending if BOTTOM specifies an already-drawn node + (unless (and (undo-tree-node-p bottom) (undo-tree-node-marker bottom)) + ;; draw nodes layer by layer + (while (or cur-stack + (prog1 (setq cur-stack next-stack) + (setq next-stack nil))) + (setq node (pop cur-stack)) + ;; if node is within range being drawn... + (if (or (eq bottom t) + (and (undo-tree-node-p bottom) + (not (eq (undo-tree-node-previous node) bottom))) + (and (integerp bottom) + (>= bottom (line-number-at-pos + (undo-tree-node-marker node)))) + (and (null bottom) + (pos-visible-in-window-p (undo-tree-node-marker node) + nil t))) + ;; ...draw one layer of node's subtree (if not already drawn) + (progn + (unless (and (undo-tree-node-next node) + (undo-tree-node-marker + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (goto-char (undo-tree-node-marker node)) + (undo-tree-draw-subtree node) + (setq extended t)) + (setq next-stack + (append (undo-tree-node-next node) next-stack))) + ;; ...otherwise, postpone drawing until later + (push node undo-tree-visualizer-needs-extending-down)))) + extended)) + + +(defun undo-tree-extend-up (node &optional top) + ;; Extend tree upwards starting from NODE. If TOP is t, extend all the way + ;; to root. If TOP is a node, extend up as far as that node. If TOP is an + ;; integer, extend up as far as that line. Otherwise, only extend visible + ;; portion of tree. NODE is assumed to already have a node marker. Returns + ;; non-nil if anything was actually extended. + (let ((extended nil) parent) + ;; don't bother extending if TOP specifies an already-drawn node + (unless (and (undo-tree-node-p top) (undo-tree-node-marker top)) + (while node + (setq parent (undo-tree-node-previous node)) + ;; if we haven't reached root... + (if parent + ;; ...and node is within range being drawn... + (if (or (eq top t) + (and (undo-tree-node-p top) (not (eq node top))) + (and (integerp top) + (< top (line-number-at-pos + (undo-tree-node-marker node)))) + (and (null top) + ;; NOTE: we check point in case window-start is outdated + (< (min (line-number-at-pos (point)) + (line-number-at-pos (window-start))) + (line-number-at-pos + (undo-tree-node-marker node))))) + ;; ...and it hasn't already been drawn + (when (not (undo-tree-node-marker parent)) + ;; link parent node to its representation in visualizer + (undo-tree-compute-widths parent) + (undo-tree-move-to-parent node) + (setf (undo-tree-node-marker parent) (make-marker)) + (set-marker-insertion-type + (undo-tree-node-marker parent) nil) + (move-marker (undo-tree-node-marker parent) (point)) + ;; draw subtree beneath parent + (setq undo-tree-visualizer-needs-extending-down + (nconc (delq node (undo-tree-draw-subtree parent)) + undo-tree-visualizer-needs-extending-down)) + (setq extended t)) + ;; ...otherwise, postpone drawing for later and exit + (setq undo-tree-visualizer-needs-extending-up (when parent node) + parent nil)) + + ;; if we've reached root, stop extending and add top margin + (setq undo-tree-visualizer-needs-extending-up nil) + (goto-char (undo-tree-node-marker node)) + (undo-tree-move-up 1) ; top margin + (delete-region (point-min) (line-beginning-position))) + ;; next iteration + (setq node parent))) + extended)) + + +(defun undo-tree-expand-down (from &optional to) + ;; Expand tree downwards. FROM is the node to start expanding from. Stop + ;; expanding at TO if specified. Otherwise, just expand visible portion of + ;; tree and highlight active branch from FROM. + (when undo-tree-visualizer-needs-extending-down + (let ((inhibit-read-only t) + node-list extended) + ;; extend down as far as TO node + (when to + (setq extended (undo-tree-extend-down from to)) + (goto-char (undo-tree-node-marker to)) + (redisplay t)) ; force redisplay to scroll buffer if necessary + ;; extend visible portion of tree downwards + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (when node-list + (dolist (n node-list) + (when (undo-tree-extend-down n) (setq extended t))) + ;; highlight active branch in newly-extended-down portion, if any + (when extended + (let ((undo-tree-insert-face + 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch from))))))) + + +(defun undo-tree-expand-up (from &optional to) + ;; Expand tree upwards. FROM is the node to start expanding from, TO is the + ;; node to stop expanding at. If TO node isn't specified, just expand visible + ;; portion of tree and highlight active branch down to FROM. + (when undo-tree-visualizer-needs-extending-up + (let ((inhibit-read-only t) + extended node-list) + ;; extend up as far as TO node + (when to + (setq extended (undo-tree-extend-up from to)) + (goto-char (undo-tree-node-marker to)) + ;; simulate auto-scrolling if close to top of buffer + (when (<= (line-number-at-pos (point)) scroll-margin) + (undo-tree-move-up (if (= scroll-conservatively 0) + (/ (window-height) 2) 3)) + (when (undo-tree-extend-up to) (setq extended t)) + (goto-char (undo-tree-node-marker to)) + (unless (= scroll-conservatively 0) (recenter scroll-margin)))) + ;; extend visible portion of tree upwards + (and undo-tree-visualizer-needs-extending-up + (undo-tree-extend-up undo-tree-visualizer-needs-extending-up) + (setq extended t)) + ;; extend visible portion of tree downwards + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (dolist (n node-list) (undo-tree-extend-down n)) + ;; highlight active branch in newly-extended-up portion, if any + (when extended + (let ((undo-tree-insert-face + 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch + (or undo-tree-visualizer-needs-extending-up + (undo-tree-root buffer-undo-tree)) + from)))))) + + + +(defun undo-tree-highlight-active-branch (node &optional end) + ;; Draw highlighted active branch below NODE in current buffer. Stop + ;; highlighting at END node if specified. + (let ((stack (list node))) + ;; draw active branch + (while stack + (setq node (pop stack)) + (unless (or (eq node end) + (memq node undo-tree-visualizer-needs-extending-down)) + (goto-char (undo-tree-node-marker node)) + (setq node (undo-tree-draw-subtree node 'active) + stack (nconc stack node)))))) + + +(defun undo-tree-draw-node (node &optional current) + ;; Draw symbol representing NODE in visualizer. If CURRENT is non-nil, node + ;; is current node. + (goto-char (undo-tree-node-marker node)) + (when undo-tree-visualizer-timestamps + (undo-tree-move-backward (/ undo-tree-visualizer-spacing 2))) + + (let* ((undo-tree-insert-face (and undo-tree-insert-face + (or (and (consp undo-tree-insert-face) + undo-tree-insert-face) + (list undo-tree-insert-face)))) + (register (undo-tree-node-register node)) + (unmodified (if undo-tree-visualizer-parent-mtime + (undo-tree-node-unmodified-p + node undo-tree-visualizer-parent-mtime) + (undo-tree-node-unmodified-p node))) + node-string) + ;; check node's register (if any) still stores appropriate undo-tree state + (unless (and register + (undo-tree-register-data-p + (registerv-data (get-register register))) + (eq node (undo-tree-register-data-node + (registerv-data (get-register register))))) + (setq register nil)) + ;; represent node by different symbols, depending on whether it's the + ;; current node, is saved in a register, or corresponds to an unmodified + ;; buffer + (setq node-string + (cond + (undo-tree-visualizer-timestamps + (undo-tree-timestamp-to-string + (undo-tree-node-timestamp node) + undo-tree-visualizer-relative-timestamps + current register)) + (register (char-to-string register)) + (unmodified "s") + (current "x") + (t "o")) + undo-tree-insert-face + (nconc + (cond + (current '(undo-tree-visualizer-current-face)) + (unmodified '(undo-tree-visualizer-unmodified-face)) + (register '(undo-tree-visualizer-register-face))) + undo-tree-insert-face)) + ;; draw node and link it to its representation in visualizer + (undo-tree-insert node-string) + (undo-tree-move-backward (if undo-tree-visualizer-timestamps + (1+ (/ undo-tree-visualizer-spacing 2)) + 1)) + (move-marker (undo-tree-node-marker node) (point)) + (put-text-property (point) (1+ (point)) 'undo-tree-node node))) + + +(defun undo-tree-draw-subtree (node &optional active-branch) + ;; Draw subtree rooted at NODE. The subtree will start from point. + ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. Returns + ;; list of nodes below NODE. + (let ((num-children (length (undo-tree-node-next node))) + node-list pos trunk-pos n) + ;; draw node itself + (undo-tree-draw-node node) + + (cond + ;; if we're at a leaf node, we're done + ((= num-children 0)) + + ;; if node has only one child, draw it (not strictly necessary to deal + ;; with this case separately, but as it's by far the most common case + ;; this makes the code clearer and more efficient) + ((= num-children 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (setq n (car (undo-tree-node-next node))) + ;; link next node to its representation in visualizer + (unless (markerp (undo-tree-node-marker n)) + (setf (undo-tree-node-marker n) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker n) nil)) + (move-marker (undo-tree-node-marker n) (point)) + ;; add next node to list of nodes to draw next + (push n node-list)) + + ;; if node has multiple children, draw branches + (t + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (move-marker (setq trunk-pos (make-marker)) (point)) + ;; left subtrees + (undo-tree-move-backward + (- (undo-tree-node-char-lwidth node) + (undo-tree-node-char-lwidth + (car (undo-tree-node-next node))))) + (move-marker (setq pos (make-marker)) (point)) + (setq n (cons nil (undo-tree-node-next node))) + (dotimes (_ (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-forward 2) + (undo-tree-insert ?_ (- trunk-pos pos 2)) + (goto-char pos) + (undo-tree-move-forward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?/) + (undo-tree-move-backward 2) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (undo-tree-node-char-lwidth (cadr n)) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point))) + ;; middle subtree (only when number of children is odd) + (when (= (mod num-children 2) 1) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point))) + ;; right subtrees + (move-marker trunk-pos (1+ trunk-pos)) + (dotimes (_ (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (goto-char trunk-pos) + (undo-tree-insert ?_ (- pos trunk-pos 1)) + (goto-char pos) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?\\) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (when (cdr n) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point)))) + )) + ;; return list of nodes to draw next + (nreverse node-list))) + + +(defun undo-tree-node-char-lwidth (node) + ;; Return left-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-node-char-rwidth (node) + ;; Return right-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-insert (str &optional arg) + ;; Insert character or string STR ARG times, overwriting, and using + ;; `undo-tree-insert-face'. + (unless arg (setq arg 1)) + (when (characterp str) + (setq str (make-string arg str)) + (setq arg 1)) + (dotimes (_ arg) (insert str)) + (setq arg (* arg (length str))) + (undo-tree-move-forward arg) + ;; make sure mark isn't active, otherwise `backward-delete-char' might + ;; delete region instead of single char if transient-mark-mode is enabled + (setq mark-active nil) + (backward-delete-char arg) + (when undo-tree-insert-face + (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face))) + + +(defun undo-tree-move-down (&optional arg) + ;; Move down, extending buffer if necessary. + (let ((row (line-number-at-pos)) + (col (current-column)) + line) + (unless arg (setq arg 1)) + (forward-line arg) + (setq line (line-number-at-pos)) + ;; if buffer doesn't have enough lines, add some + (when (/= line (+ row arg)) + (cond + ((< arg 0) + (insert (make-string (- line row arg) ?\n)) + (forward-line (+ arg (- row line)))) + (t (insert (make-string (- arg (- line row)) ?\n))))) + (undo-tree-move-forward col))) + + +(defun undo-tree-move-up (&optional arg) + ;; Move up, extending buffer if necessary. + (unless arg (setq arg 1)) + (undo-tree-move-down (- arg))) + + +(defun undo-tree-move-forward (&optional arg) + ;; Move forward, extending buffer if necessary. + (unless arg (setq arg 1)) + (let (n) + (cond + ((>= arg 0) + (setq n (- (line-end-position) (point))) + (if (> n arg) + (forward-char arg) + (end-of-line) + (insert (make-string (- arg n) ? )))) + ((< arg 0) + (setq arg (- arg)) + (setq n (- (point) (line-beginning-position))) + (when (< (- n 2) arg) ; -2 to create left-margin + ;; no space left - shift entire buffer contents right! + (let ((pos (move-marker (make-marker) (point)))) + (set-marker-insertion-type pos t) + (goto-char (point-min)) + (while (not (eobp)) + (insert-before-markers (make-string (- arg -2 n) ? )) + (forward-line 1)) + (goto-char pos))) + (backward-char arg))))) + + +(defun undo-tree-move-backward (&optional arg) + ;; Move backward, extending buffer if necessary. + (unless arg (setq arg 1)) + (undo-tree-move-forward (- arg))) + + +(defun undo-tree-move-to-parent (node) + ;; Move to position of parent of NODE, extending buffer if necessary. + (let* ((parent (undo-tree-node-previous node)) + (n (undo-tree-node-next parent)) + (l (length n)) p) + (goto-char (undo-tree-node-marker node)) + (unless (= l 1) + ;; move horizontally + (setq p (undo-tree-position node n)) + (cond + ;; node in centre subtree: no horizontal movement + ((and (= (mod l 2) 1) (= p (/ l 2)))) + ;; node in left subtree: move right + ((< p (/ l 2)) + (setq n (nthcdr p n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)) + (dotimes (_ (- (/ l 2) p 1)) + (setq n (cdr n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-lwidth (car n)) + (undo-tree-node-char-rwidth (car n)) + undo-tree-visualizer-spacing 1))) + (when (= (mod l 2) 1) + (setq n (cdr n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-lwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)))) + (t ;; node in right subtree: move left + (setq n (nthcdr (/ l 2) n)) + (when (= (mod l 2) 1) + (undo-tree-move-backward + (+ (undo-tree-node-char-rwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)) + (setq n (cdr n))) + (dotimes (_ (- p (/ l 2) (mod l 2))) + (undo-tree-move-backward + (+ (undo-tree-node-char-lwidth (car n)) + (undo-tree-node-char-rwidth (car n)) + undo-tree-visualizer-spacing 1)) + (setq n (cdr n))) + (undo-tree-move-backward + (+ (undo-tree-node-char-lwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1))))) + ;; move vertically + (undo-tree-move-up 3))) + + +(defun undo-tree-timestamp-to-string + (timestamp &optional relative current register) + ;; Convert TIMESTAMP to string (either absolute or RELATVE time), indicating + ;; if it's the CURRENT node and/or has an associated REGISTER. + (if relative + ;; relative time + (let ((time (floor (float-time + (time-subtract (current-time) timestamp)))) + n) + (setq time + ;; years + (if (> (setq n (/ time 315360000)) 0) + (if (> n 999) "-ages" (format "-%dy" n)) + (setq time (% time 315360000)) + ;; days + (if (> (setq n (/ time 86400)) 0) + (format "-%dd" n) + (setq time (% time 86400)) + ;; hours + (if (> (setq n (/ time 3600)) 0) + (format "-%dh" n) + (setq time (% time 3600)) + ;; mins + (if (> (setq n (/ time 60)) 0) + (format "-%dm" n) + ;; secs + (format "-%ds" (% time 60))))))) + (setq time (concat + (if current "*" " ") + time + (if register (concat "[" (char-to-string register) "]") + " "))) + (setq n (length time)) + (if (< n 9) + (concat (make-string (- 9 n) ? ) time) + time)) + ;; absolute time + (concat (if current " *" " ") + (format-time-string "%H:%M:%S" timestamp) + (if register + (concat "[" (char-to-string register) "]") + " ")))) + + + + +;;; ===================================================================== +;;; Visualizer modes + +(define-derived-mode + undo-tree-visualizer-mode special-mode "undo-tree-visualizer" + "Major mode used in undo-tree visualizer. + +The undo-tree visualizer can only be invoked from a buffer in +which `undo-tree-mode' is enabled. The visualizer displays the +undo history tree graphically, and allows you to browse around +the undo history, undoing or redoing the corresponding changes in +the parent buffer. + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-mode-map}" + :syntax-table nil + :abbrev-table nil + (setq truncate-lines t) + (setq cursor-type nil) + (setq undo-tree-visualizer-selected-node nil)) + + +(define-minor-mode undo-tree-visualizer-selection-mode + "Toggle mode to select nodes in undo-tree visualizer." + :lighter "Select" + :keymap undo-tree-visualizer-selection-mode-map + :group undo-tree + (cond + ;; enable selection mode + (undo-tree-visualizer-selection-mode + (setq cursor-type 'box) + (setq undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree)) + ;; erase diff (if any), as initially selected node is identical to current + (when undo-tree-visualizer-diff + (let ((buff (get-buffer undo-tree-diff-buffer-name)) + (inhibit-read-only t)) + (when buff (with-current-buffer buff (erase-buffer)))))) + (t ;; disable selection mode + (setq cursor-type nil) + (setq undo-tree-visualizer-selected-node nil) + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))) + )) + + + + +;;; ===================================================================== +;;; Visualizer commands + +(defun undo-tree-visualize-undo (&optional arg) + "Undo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((old (undo-tree-current buffer-undo-tree)) + current) + ;; undo in parent buffer + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-undo-1 arg)) + (setq current (undo-tree-current buffer-undo-tree)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; unhighlight old current node + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face) + (inhibit-read-only t)) + (undo-tree-draw-node old)) + ;; when using lazy drawing, extend tree upwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up old current)) + ;; highlight new current node + (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current)) + ;; update diff display, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualize-redo (&optional arg) + "Redo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((old (undo-tree-current buffer-undo-tree)) + current) + ;; redo in parent buffer + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-redo-1 arg)) + (setq current (undo-tree-current buffer-undo-tree)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; unhighlight old current node + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face) + (inhibit-read-only t)) + (undo-tree-draw-node old)) + ;; when using lazy drawing, extend tree downwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-down old current)) + ;; highlight new current node + (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current)) + ;; update diff display, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualize-switch-branch-right (arg) + "Switch to next branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + ;; un-highlight old active branch below current node + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) + (inhibit-read-only t)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; increment branch + (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree)))) + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + (cond + ((>= (+ branch arg) (undo-tree-num-branches)) + (1- (undo-tree-num-branches))) + ((<= (+ branch arg) 0) 0) + (t (+ branch arg)))) + (let ((inhibit-read-only t)) + ;; highlight new active branch below current node + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; re-highlight current node + (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)))) + + +(defun undo-tree-visualize-switch-branch-left (arg) + "Switch to previous branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + (undo-tree-visualize-switch-branch-right (- arg))) + + +(defun undo-tree-visualizer-quit () + "Quit the undo-tree visualizer." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-clear-visualizer-data buffer-undo-tree) + ;; remove kill visualizer hook from parent buffer + (unwind-protect + (with-current-buffer undo-tree-visualizer-parent-buffer + (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t)) + ;; kill diff buffer, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-hide-diff)) + (let ((parent undo-tree-visualizer-parent-buffer) + window) + ;; kill visualizer buffer + (kill-buffer nil) + ;; switch back to parent buffer + (unwind-protect + (if (setq window (get-buffer-window parent)) + (select-window window) + (switch-to-buffer parent)))))) + + +(defun undo-tree-visualizer-abort () + "Quit the undo-tree visualizer and return buffer to original state." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-initial-node)) + (undo-tree-visualizer-quit) + (undo-tree-set node))) + + +(defun undo-tree-visualizer-set (&optional pos) + "Set buffer to state corresponding to undo tree node +at POS, or point if POS is nil." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (unless pos (setq pos (point))) + (let ((node (get-text-property pos 'undo-tree-node))) + (when node + ;; set parent buffer to state corresponding to node at POS + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-set node)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; re-draw undo tree + (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree)) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualizer-mouse-set (pos) + "Set buffer to state corresponding to undo tree node +at mouse event POS." + (interactive "@e") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-visualizer-set (event-start (nth 1 pos)))) + + +(defun undo-tree-visualize-undo-to-x (&optional x) + "Undo to last branch point, register, or saved state. +If X is the symbol `branch', undo to last branch point. If X is +the symbol `register', undo to last register. If X is the symbol +`saved', undo to last saved state. If X is null, undo to first of +these that's encountered. + +Interactively, a single \\[universal-argument] specifies +`branch', a double \\[universal-argument] \\[universal-argument] +specifies `saved', and a negative prefix argument specifies +`register'." + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (when (and (called-interactively-p 'any) x) + (setq x (prefix-numeric-value x) + x (cond + ((< x 0) 'register) + ((<= x 4) 'branch) + (t 'saved)))) + (let ((current (if undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree))) + (diff undo-tree-visualizer-diff) + r) + (undo-tree-visualizer-hide-diff) + (while (and (undo-tree-node-previous current) + (or (if undo-tree-visualizer-selection-mode + (progn + (undo-tree-visualizer-select-previous) + (setq current undo-tree-visualizer-selected-node)) + (undo-tree-visualize-undo) + (setq current (undo-tree-current buffer-undo-tree))) + t) + ;; branch point + (not (or (and (or (null x) (eq x 'branch)) + (> (undo-tree-num-branches) 1)) + ;; register + (and (or (null x) (eq x 'register)) + (setq r (undo-tree-node-register current)) + (undo-tree-register-data-p + (setq r (registerv-data (get-register r)))) + (eq current (undo-tree-register-data-node r))) + ;; saved state + (and (or (null x) (eq x 'saved)) + (undo-tree-node-unmodified-p current)) + )))) + ;; update diff display, if any + (when diff + (undo-tree-visualizer-show-diff + (when undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node))))) + + +(defun undo-tree-visualize-redo-to-x (&optional x) + "Redo to last branch point, register, or saved state. +If X is the symbol `branch', redo to last branch point. If X is +the symbol `register', redo to last register. If X is the sumbol +`saved', redo to last saved state. If X is null, redo to first of +these that's encountered. + +Interactively, a single \\[universal-argument] specifies +`branch', a double \\[universal-argument] \\[universal-argument] +specifies `saved', and a negative prefix argument specifies +`register'." + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (when (and (called-interactively-p 'any) x) + (setq x (prefix-numeric-value x) + x (cond + ((< x 0) 'register) + ((<= x 4) 'branch) + (t 'saved)))) + (let ((current (if undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree))) + (diff undo-tree-visualizer-diff) + r) + (undo-tree-visualizer-hide-diff) + (while (and (undo-tree-node-next current) + (or (if undo-tree-visualizer-selection-mode + (progn + (undo-tree-visualizer-select-next) + (setq current undo-tree-visualizer-selected-node)) + (undo-tree-visualize-redo) + (setq current (undo-tree-current buffer-undo-tree))) + t) + ;; branch point + (not (or (and (or (null x) (eq x 'branch)) + (> (undo-tree-num-branches) 1)) + ;; register + (and (or (null x) (eq x 'register)) + (setq r (undo-tree-node-register current)) + (undo-tree-register-data-p + (setq r (registerv-data (get-register r)))) + (eq current (undo-tree-register-data-node r))) + ;; saved state + (and (or (null x) (eq x 'saved)) + (undo-tree-node-unmodified-p current)) + )))) + ;; update diff display, if any + (when diff + (undo-tree-visualizer-show-diff + (when undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node))))) + + +(defun undo-tree-visualizer-toggle-timestamps () + "Toggle display of time-stamps." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (setq undo-tree-visualizer-timestamps (not undo-tree-visualizer-timestamps)) + (setq undo-tree-visualizer-spacing (undo-tree-visualizer-calculate-spacing)) + ;; redraw tree + (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree))) + + +(defun undo-tree-visualizer-scroll-left (&optional arg) + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (scroll-left (or arg 1) t)) + + +(defun undo-tree-visualizer-scroll-right (&optional arg) + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (scroll-right (or arg 1) t)) + + +(defun undo-tree-visualizer-scroll-up (&optional arg) + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if (or (and (numberp arg) (< arg 0)) (eq arg '-)) + (undo-tree-visualizer-scroll-down arg) + ;; scroll up and expand newly-visible portion of tree + (unwind-protect + (scroll-up-command arg) + (undo-tree-expand-down + (nth (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + (undo-tree-node-next (undo-tree-current buffer-undo-tree))))) + ;; signal error if at eob + (when (and (not undo-tree-visualizer-needs-extending-down) (eobp)) + (scroll-up)))) + + +(defun undo-tree-visualizer-scroll-down (&optional arg) + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if (or (and (numberp arg) (< arg 0)) (eq arg '-)) + (undo-tree-visualizer-scroll-up arg) + ;; ensure there's enough room at top of buffer to scroll + (let ((scroll-lines + (or arg (- (window-height) next-screen-context-lines))) + (window-line (1- (line-number-at-pos (window-start))))) + (when (and undo-tree-visualizer-needs-extending-up + (< window-line scroll-lines)) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (undo-tree-move-up (- scroll-lines window-line))))) + ;; scroll down and expand newly-visible portion of tree + (unwind-protect + (scroll-down-command arg) + (undo-tree-expand-up + (undo-tree-node-previous (undo-tree-current buffer-undo-tree)))) + ;; signal error if at bob + (when (and (not undo-tree-visualizer-needs-extending-down) (bobp)) + (scroll-down)))) + + + + +;;; ===================================================================== +;;; Visualizer selection mode commands + +(defun undo-tree-visualizer-select-previous (&optional arg) + "Move to previous node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node)) + (catch 'top + (dotimes (_ (or arg 1)) + (unless (undo-tree-node-previous node) (throw 'top t)) + (setq node (undo-tree-node-previous node)))) + ;; when using lazy drawing, extend tree upwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; move to selected node + (goto-char (undo-tree-node-marker node)) + (setq undo-tree-visualizer-selected-node node))) + + +(defun undo-tree-visualizer-select-next (&optional arg) + "Move to next node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node)) + (catch 'bottom + (dotimes (_ (or arg 1)) + (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node)) + (throw 'bottom t)) + (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))))) + ;; when using lazy drawing, extend tree downwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-down undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; move to selected node + (goto-char (undo-tree-node-marker node)) + (setq undo-tree-visualizer-selected-node node))) + + +(defun undo-tree-visualizer-select-right (&optional arg) + "Move right to a sibling node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node) + end) + (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node)) + (setq end (line-end-position)) + (catch 'end + (dotimes (_ arg) + (while (or (null node) (eq node undo-tree-visualizer-selected-node)) + (forward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) end) (throw 'end t))))) + (goto-char (undo-tree-node-marker + (or node undo-tree-visualizer-selected-node))) + (when (and undo-tree-visualizer-diff node + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + (when node (setq undo-tree-visualizer-selected-node node)))) + + +(defun undo-tree-visualizer-select-left (&optional arg) + "Move left to a sibling node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node (get-text-property (point) 'undo-tree-node)) + beg) + (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node)) + (setq beg (line-beginning-position)) + (catch 'beg + (dotimes (_ arg) + (while (or (null node) (eq node undo-tree-visualizer-selected-node)) + (backward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) beg) (throw 'beg t))))) + (goto-char (undo-tree-node-marker + (or node undo-tree-visualizer-selected-node))) + (when (and undo-tree-visualizer-diff node + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + (when node (setq undo-tree-visualizer-selected-node node)))) + + +(defun undo-tree-visualizer-select (pos) + (let ((node (get-text-property pos 'undo-tree-node))) + (when node + ;; select node at POS + (goto-char (undo-tree-node-marker node)) + ;; when using lazy drawing, extend tree up and down as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up undo-tree-visualizer-selected-node node) + (undo-tree-expand-down undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; update selected node + (setq undo-tree-visualizer-selected-node node) + ))) + + +(defun undo-tree-visualizer-mouse-select (pos) + "Select undo tree node at mouse event POS." + (interactive "@e") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-visualizer-select (event-start (nth 1 pos)))) + + + + +;;; ===================================================================== +;;; Visualizer diff display + +(defun undo-tree-visualizer-toggle-diff () + "Toggle diff display in undo-tree visualizer." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if undo-tree-visualizer-diff + (undo-tree-visualizer-hide-diff) + (undo-tree-visualizer-show-diff))) + + +(defun undo-tree-visualizer-selection-toggle-diff () + "Toggle diff display in undo-tree visualizer selection mode." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if undo-tree-visualizer-diff + (undo-tree-visualizer-hide-diff) + (let ((node (get-text-property (point) 'undo-tree-node))) + (when node (undo-tree-visualizer-show-diff node))))) + + +(defun undo-tree-visualizer-show-diff (&optional node) + ;; show visualizer diff display + (setq undo-tree-visualizer-diff t) + (let ((buff (with-current-buffer undo-tree-visualizer-parent-buffer + (undo-tree-diff node))) + (display-buffer-mark-dedicated 'soft) + win) + (setq win (split-window)) + (set-window-buffer win buff) + (shrink-window-if-larger-than-buffer win))) + + +(defun undo-tree-visualizer-hide-diff () + ;; hide visualizer diff display + (setq undo-tree-visualizer-diff nil) + (let ((win (get-buffer-window undo-tree-diff-buffer-name))) + (when win (with-selected-window win (kill-buffer-and-window))))) + + +(defun undo-tree-diff (&optional node) + ;; Create diff between NODE and current state (or previous state and current + ;; state, if NODE is null). Returns buffer containing diff. + (let (tmpfile buff) + ;; generate diff + (let ((undo-tree-inhibit-kill-visualizer t) + (current (undo-tree-current buffer-undo-tree))) + (undo-tree-set (or node (undo-tree-node-previous current) current) + 'preserve-timestamps) + (setq tmpfile (diff-file-local-copy (current-buffer))) + (undo-tree-set current 'preserve-timestamps)) + (setq buff (diff-no-select + tmpfile (current-buffer) nil 'noasync + (get-buffer-create undo-tree-diff-buffer-name))) + ;; delete process messages and useless headers from diff buffer + (let ((inhibit-read-only t)) + (with-current-buffer buff + (goto-char (point-min)) + (delete-region (point) (1+ (line-end-position 3))) + (goto-char (point-max)) + (forward-line -2) + (delete-region (point) (point-max)) + (setq cursor-type nil) + (setq buffer-read-only t))) + buff)) + + +(defun undo-tree-visualizer-update-diff (&optional node) + ;; update visualizer diff display to show diff between current state and + ;; NODE (or previous state, if NODE is null) + (with-current-buffer undo-tree-visualizer-parent-buffer + (undo-tree-diff node)) + (let ((win (get-buffer-window undo-tree-diff-buffer-name))) + (when win + (balance-windows) + (shrink-window-if-larger-than-buffer win)))) + + + +(provide 'undo-tree) + +;;; undo-tree.el ends here diff --git a/site-lisp/extensions-submodule/ace-window b/site-lisp/extensions-submodule/ace-window new file mode 160000 index 0000000..77115af --- /dev/null +++ b/site-lisp/extensions-submodule/ace-window @@ -0,0 +1 @@ +Subproject commit 77115afc1b0b9f633084cf7479c767988106c196 diff --git a/site-lisp/extensions-submodule/avy b/site-lisp/extensions-submodule/avy new file mode 160000 index 0000000..be61211 --- /dev/null +++ b/site-lisp/extensions-submodule/avy @@ -0,0 +1 @@ +Subproject commit be612110cb116a38b8603df367942e2bb3d9bdbe diff --git a/site-lisp/extensions-submodule/citre b/site-lisp/extensions-submodule/citre new file mode 160000 index 0000000..c617ace --- /dev/null +++ b/site-lisp/extensions-submodule/citre @@ -0,0 +1 @@ +Subproject commit c617acef3dc2a88aaffa42a515ce7dbaba98228a diff --git a/site-lisp/extensions-submodule/company-mode b/site-lisp/extensions-submodule/company-mode new file mode 160000 index 0000000..9c12b02 --- /dev/null +++ b/site-lisp/extensions-submodule/company-mode @@ -0,0 +1 @@ +Subproject commit 9c12b02620ed8a7ae5369fc90217f1c730e48fa6 diff --git a/site-lisp/extensions-submodule/dash.el b/site-lisp/extensions-submodule/dash.el new file mode 160000 index 0000000..6db80c7 --- /dev/null +++ b/site-lisp/extensions-submodule/dash.el @@ -0,0 +1 @@ +Subproject commit 6db80c711ce947f6c6fa11e5c2257fff2c79d139 diff --git a/site-lisp/extensions-submodule/emacs-which-key b/site-lisp/extensions-submodule/emacs-which-key new file mode 160000 index 0000000..4d20bc8 --- /dev/null +++ b/site-lisp/extensions-submodule/emacs-which-key @@ -0,0 +1 @@ +Subproject commit 4d20bc852545a2e602f59084a630f888542052b1 diff --git a/site-lisp/extensions-submodule/go-mode.el b/site-lisp/extensions-submodule/go-mode.el new file mode 160000 index 0000000..8dce1e3 --- /dev/null +++ b/site-lisp/extensions-submodule/go-mode.el @@ -0,0 +1 @@ +Subproject commit 8dce1e3ba1cdc34a856ad53c8421413cfe33660e diff --git a/site-lisp/extensions-submodule/jsonian b/site-lisp/extensions-submodule/jsonian new file mode 160000 index 0000000..22bd5e2 --- /dev/null +++ b/site-lisp/extensions-submodule/jsonian @@ -0,0 +1 @@ +Subproject commit 22bd5e20a653595b901ccfdc8780a0038755984d diff --git a/site-lisp/extensions-submodule/lua-mode b/site-lisp/extensions-submodule/lua-mode new file mode 160000 index 0000000..d074e41 --- /dev/null +++ b/site-lisp/extensions-submodule/lua-mode @@ -0,0 +1 @@ +Subproject commit d074e4134b1beae9ed4c9b512af741ca0d852ba3 diff --git a/site-lisp/extensions-submodule/markdown-mode b/site-lisp/extensions-submodule/markdown-mode new file mode 160000 index 0000000..141f9a0 --- /dev/null +++ b/site-lisp/extensions-submodule/markdown-mode @@ -0,0 +1 @@ +Subproject commit 141f9a05d121f60fe5e411c0ad114e3d3216c9ad diff --git a/site-lisp/extensions-submodule/modus-themes b/site-lisp/extensions-submodule/modus-themes new file mode 160000 index 0000000..642cc5f --- /dev/null +++ b/site-lisp/extensions-submodule/modus-themes @@ -0,0 +1 @@ +Subproject commit 642cc5f8358fd1f2911792a4bbed160d24e9b01b diff --git a/site-lisp/extensions-submodule/multiple-cursors.el b/site-lisp/extensions-submodule/multiple-cursors.el new file mode 160000 index 0000000..234806c --- /dev/null +++ b/site-lisp/extensions-submodule/multiple-cursors.el @@ -0,0 +1 @@ +Subproject commit 234806c832994cadedb42596fe235e91bbd59e8c diff --git a/site-lisp/extensions-submodule/swiper b/site-lisp/extensions-submodule/swiper new file mode 160000 index 0000000..8c30f4c --- /dev/null +++ b/site-lisp/extensions-submodule/swiper @@ -0,0 +1 @@ +Subproject commit 8c30f4cab5948aa8d942a3b2bbf5fb6a94d9441d diff --git a/site-lisp/extensions-submodule/web-mode b/site-lisp/extensions-submodule/web-mode new file mode 160000 index 0000000..df57cd0 --- /dev/null +++ b/site-lisp/extensions-submodule/web-mode @@ -0,0 +1 @@ +Subproject commit df57cd0beea9c6bdc64259bd11bde0c076a64cc9 diff --git a/site-lisp/extensions-submodule/yasnippet b/site-lisp/extensions-submodule/yasnippet new file mode 160000 index 0000000..52a1c50 --- /dev/null +++ b/site-lisp/extensions-submodule/yasnippet @@ -0,0 +1 @@ +Subproject commit 52a1c5031912243c791c55e0fe345d04f219b507 diff --git a/site-lisp/init-config/init-ace-window.el b/site-lisp/init-config/init-ace-window.el new file mode 100644 index 0000000..e596200 --- /dev/null +++ b/site-lisp/init-config/init-ace-window.el @@ -0,0 +1,10 @@ +;;; Require +(require 'ace-window) + +;;; Code: +;; 0-9 by default +(setq aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)) + +(provide 'init-ace-window) + +;;; init-ace-window.el ends here diff --git a/site-lisp/init-config/init-auto-save.el b/site-lisp/init-config/init-auto-save.el new file mode 100644 index 0000000..15b7607 --- /dev/null +++ b/site-lisp/init-config/init-auto-save.el @@ -0,0 +1,14 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'auto-save) + +;;; Code: +;; auto save after n second(s) +;; (setq auto-save-idle 1) +(setq auto-save-delete-trailing-whitespace t) +(setq auto-save-silent t) +(auto-save-enable) + +(provide 'init-auto-save) + +;;; init-auto-save.el ends here diff --git a/site-lisp/init-config/init-avy.el b/site-lisp/init-config/init-avy.el new file mode 100644 index 0000000..26e37ff --- /dev/null +++ b/site-lisp/init-config/init-avy.el @@ -0,0 +1,19 @@ +;;; Require +(require 'avy) + +;;; Code: +;; Home row only (the default). +(setq avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)) + +;; Any lower-case letter a-z. +; (setq avy-keys (number-sequence ?a ?z)) + +;; Any lower-case letter or number. Numbers are specified in the keyboard +;; number-row order, so that the candidate following '9' will be '0'. +; (setq avy-keys (nconc (number-sequence ?a ?z) +; (number-sequence ?1 ?9) +; '(?0))) + +(provide 'init-avy) + +;;; init-avy.el ends here diff --git a/site-lisp/init-config/init-citre.el b/site-lisp/init-config/init-citre.el new file mode 100644 index 0000000..e318c6e --- /dev/null +++ b/site-lisp/init-config/init-citre.el @@ -0,0 +1,10 @@ +;;; Require +(require 'citre) +(require 'citre-config) + +;;; Code: +;; (remove-hook 'find-file-hook #'citre-auto-enable-citre-mode) + +(provide 'init-citre) + +;;; init-citre.el ends here diff --git a/site-lisp/init-config/init-coding-system.el b/site-lisp/init-config/init-coding-system.el new file mode 100644 index 0000000..0f74e67 --- /dev/null +++ b/site-lisp/init-config/init-coding-system.el @@ -0,0 +1,34 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(set-language-environment 'UTF-8) + +(set-default-coding-systems 'utf-8) +(set-buffer-file-coding-system 'utf-8) +(set-file-name-coding-system 'utf-8) +(set-keyboard-coding-system 'utf-8) +(set-next-selection-coding-system 'utf-8) +(set-terminal-coding-system 'utf-8) + +(when *win64* + (set-next-selection-coding-system 'utf-16-le) + (set-selection-coding-system 'utf-16-le) + (set-clipboard-coding-system 'utf-16-le)) + +(when (or *linux* *unix* *is-a-mac*) + (set-clipboard-coding-system 'utf-8) + (set-selection-coding-system 'utf-8)) + +;; the final one will be selected first +(prefer-coding-system 'cp950) +(prefer-coding-system 'gb2312) +(prefer-coding-system 'cp936) +(prefer-coding-system 'gb18030) +(prefer-coding-system 'utf-16) +(prefer-coding-system 'utf-8-dos) +(prefer-coding-system 'utf-8-unix) + +(provide 'init-coding-system) + +;;; init-coding-system ends here diff --git a/site-lisp/init-config/init-company-mode.el b/site-lisp/init-config/init-company-mode.el new file mode 100644 index 0000000..d138fce --- /dev/null +++ b/site-lisp/init-config/init-company-mode.el @@ -0,0 +1,13 @@ +;;; Require +(require 'company) +(require 'company-ctags) + +;;; Code: +(global-company-mode) + +(with-eval-after-load 'company + (company-ctags-auto-setup)) + +(provide 'init-company-mode) + +;;; init-company-mode.el ends here diff --git a/site-lisp/init-config/init-dired.el b/site-lisp/init-config/init-dired.el new file mode 100644 index 0000000..9640ed9 --- /dev/null +++ b/site-lisp/init-config/init-dired.el @@ -0,0 +1,23 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'dired-display-buffer) +(require 'dired-narrow) +(require 'dired-subtree) + +;;; Code: +(setq dired-listing-switches "-alh1v --group-directories-first") + +;; dired-subtree +(setq dired-subtree-line-prefix " ") +(setq dired-subtree-cycle-depth 3) ;; default `3' +(setq dired-subtree-use-backgrounds nil) ;; default `t' +;; (set-face-attribute 'dired-subtree-depth-1-face nil :background "#ced9db") +;; (set-face-attribute 'dired-subtree-depth-2-face nil :background "#bbc9cc") +;; (set-face-attribute 'dired-subtree-depth-3-face nil :background "#a7babe") +;; (set-face-attribute 'dired-subtree-depth-4-face nil :background "#94aaaf") +;; (set-face-attribute 'dired-subtree-depth-5-face nil :background "#809ba2") +;; (set-face-attribute 'dired-subtree-depth-6-face nil :background "#6c8b93") + +(provide 'init-dired) + +;;; init-dired.el ends here diff --git a/site-lisp/init-config/init-generic.el b/site-lisp/init-config/init-generic.el new file mode 100644 index 0000000..aaa47f8 --- /dev/null +++ b/site-lisp/init-config/init-generic.el @@ -0,0 +1,149 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(setq package-archives + '(("gnu" . "http://elpa.emacs-china.org/gnu/") + ("melpa" . "http://elpa.emacs-china.org/melpa/"))) + +;; disable some bars +(if window-system + (progn + (tool-bar-mode -1) + (menu-bar-mode -1) + (scroll-bar-mode -1)) + (menu-bar-mode -1)) + +;; map Win key and Hyper key to Super and Hyper for emacs on Windows. +(when *win64* + (setq w32-pass-lwindow-to-system nil) + (setq w32-lwindow-modifier 'super) ; Left Windows key + (setq w32-pass-rwindow-to-system nil) + (setq w32-rwindow-modifier 'super) ; Right Windows key + (w32-register-hot-key [s-]) + ;; (setq w32-pass-apps-to-system nil) + (setq w32-apps-modifier 'hyper) ; Menu/App key + (w32-register-hot-key [H-])) + +;; Restore emacs session. +;(setq initial-buffer-choice t) +;(run-with-timer 1 nil #'(lambda () (bury-buffer))) + +;; turn on word-wrap in all buffers +(global-visual-line-mode t) +(setq word-wrap-by-category t) ;; enhanced CJK word wrap since Emacs28 + +;; line number and column number +(global-display-line-numbers-mode t) ;; show line numbers in every mode +(column-number-mode t) ;; show column number +; Line numbers are not displayed when large files are used. +(setq line-number-display-limit large-file-warning-threshold) +(setq line-number-display-limit-width 1000) + +;; parentheses config +(show-paren-mode t) ;; show bracket pairing +(electric-pair-mode t) ;; automatic completion of parentheses + +;; highlight current line +(global-hl-line-mode t) + +;; auto reload file content +(global-auto-revert-mode t) + +;; delete selected text when input on it +(delete-selection-mode t) + +;; record recently opened files +(recentf-mode 1) +(setq recentf-max-menu-items 25) +(setq recentf-max-saved-items 25) + +;; treat OneWord or one_word as one word +(global-subword-mode t) + +;; disable cursor blink +(blink-cursor-mode -1) + +;; decompress a file when open it +(auto-compression-mode t) + +;; disable the ring bell +(setq ring-bell-function 'ignore) + +;; set `text-mode' as default major-mode +(setq default-major-mode 'text-mode) + +;; use Posix format for time string +(setq system-time-locale "C") + +;; replace yes/no with y/n +;; but since emacs 28 user can use (use-short-answers t) to do it +(fset 'yes-or-no-p 'y-or-n-p) + +;; do not show welcome page +(setq inhibit-startup-screen t) + +;; use single space as sentence end, default is two +(setq sentence-end-double-space nil) + +;; make key prompt faster +(setq echo-keystrokes 0.1) + +;; increase IO performance +(setq process-adaptive-read-buffering nil) +(setq read-process-output-max (* 1024 1024)) + +;; scrolling config +(setq scroll-margin 3 + scroll-conservatively 101 + auto-window-vscroll nil) + +;; clean scratch buffer content +; a non-clean scratch buffer will disturb session restore +(setq initial-scratch-message "") + +;; exit emacs without confirmation to kill running processes +(setq confirm-kill-processes nil) + +;; resize frame in pixel +(setq frame-resize-pixelwise t) + +;; show a big square when cursor is on 'tab' +(setq x-stretch-cursor t) + +;; delete duplicate minibuffer history +(setq history-delete-duplicates t) + +;; allow scroll in isearch +(setq isearch-allow-scroll t) + +;; don't ask me when close emacs with running process +(defadvice save-buffers-kill-emacs (around no-query-kill-emacs activate) + "Prevent annoying \"Active processes exist\" query when you quit Emacs." + (cl-flet ((process-list ())) ad-do-it)) + +;; don't ask when kill process buffer +(setq kill-buffer-query-functions + (remq 'process-kill-buffer-query-function + kill-buffer-query-functions)) + +;; (setq byte-compile-warnings +;; (quote ( +;; ;; 显示的警告 +;; free-vars ;不在当前范围的引用变量 +;; unresolved ;不知道的函数 +;; callargs ;函数调用的参数和定义的不匹配 +;; obsolete ;荒废的变量和函数 +;; noruntime ;函数没有定义在运行时期 +;; interactive-only ;正常不被调用的命令 +;; make-local ;调用 `make-variable-buffer-local' 可能会不正确的 +;; mapcar ;`mapcar' 调用 +;; ;; +;; ;; 抑制的警告 +;; (not redefine) ;重新定义的函数 (比如参数数量改变) +;; (not cl-functions) ;`CL' 包中的运行时调用的函数 +;; ))) + +(provide 'init-generic) + +;;; init-generic.el ends here diff --git a/site-lisp/init-config/init-highlight-parentheses.el b/site-lisp/init-config/init-highlight-parentheses.el new file mode 100644 index 0000000..97216b1 --- /dev/null +++ b/site-lisp/init-config/init-highlight-parentheses.el @@ -0,0 +1,11 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'highlight-parentheses) + +;;; Code: +(setq hl-paren-colors '("DarkOrange" "DeepSkyBlue" "DarkRed")) +(add-hook 'find-file-hook 'highlight-parentheses-mode t) + +(provide 'init-highlight-parentheses) + +;;; init-highlight-parentheses.el ends here diff --git a/site-lisp/init-config/init-indent.el b/site-lisp/init-config/init-indent.el new file mode 100644 index 0000000..4db9fae --- /dev/null +++ b/site-lisp/init-config/init-indent.el @@ -0,0 +1,59 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: +(setq-default indent-tabs-mode nil) +(setq-default tab-width 4) + +(defun adjust-languages-indent (n) + (setq-local tab-width n) + + (when (or (derived-mode-p 'c-mode)) + (setq-local c-basic-offset n)) + + (when (or (derived-mode-p 'js-mode) + (derived-mode-p 'js2-mode) + (derived-mode-p 'web-mode)) + (setq-local javascript-indent-level n) + (setq-local js-indent-level n) + (setq-local js2-basic-offset n) + + (setq-local css-indent-offset n) + + (setq-local web-mode-attr-indent-offset n) + (setq-local web-mode-attr-value-indent-offset n) + (setq-local web-mode-code-indent-offset n) + (setq-local web-mode-css-indent-offset n) + (setq-local web-mode-markup-indent-offset n) + (setq-local web-mode-sql-indent-offset n) + )) + +(dolist (hook (list 'c-mode-hook + 'c++-mode-hook + 'java-mode-hook + 'haskell-mode-hook + 'asm-mode-hook + 'sh-mode-hook + 'haskell-cabal-mode-hook + 'ruby-mode-hook + 'qml-mode-hook + 'scss-mode-hook + 'python-mode-hook + )) + (add-hook hook #'(lambda () + (adjust-languages-indent 4) + ))) + +(dolist (hook (list 'lua-mode-hook + 'org-mode-hook + 'js-mode-hook + 'web-mode-hook + 'yaml-mode-hook + )) + (add-hook hook #'(lambda () + (adjust-languages-indent 2) + ))) + +(provide 'init-indent) + +;;; init-indent.el ends here diff --git a/site-lisp/init-config/init-mode.el b/site-lisp/init-config/init-mode.el new file mode 100644 index 0000000..ca9cc81 --- /dev/null +++ b/site-lisp/init-config/init-mode.el @@ -0,0 +1,92 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'jsonian) +(require 'lua-mode) + +;;; Code: +;; bind ext to a specific mode +(defun add-to-alist (alist-var elt-cons &optional no-replace) + "Add to the value of ALIST-VAR an element ELT-CONS if it isn't there yet. +If an element with the same car as the car of ELT-CONS is already present, +replace it with ELT-CONS unless NO-REPLACE is non-nil; if a matching +element is not already present, add ELT-CONS to the front of the alist. +The test for presence of the car of ELT-CONS is done with `equal'." + (let ((existing-element (assoc (car elt-cons) (symbol-value alist-var)))) + (if existing-element + (or no-replace + (rplacd existing-element (cdr elt-cons))) + (set alist-var (cons elt-cons (symbol-value alist-var))))) + (symbol-value alist-var)) + +(dolist (elt-cons '( + ("\\.org\\'" . org-mode) + ("\\.stumpwmrc\\'" . lisp-mode) + ("\\.jl\\'" . lisp-mode) + ("\\.asdf\\'" . lisp-mode) + + ("\\.markdown" . markdown-mode) + ("\\.md" . markdown-mode) + + ("\\.inc\\'" . asm-mode) + + ("\\.py\\'" . python-mode) + ("SConstruct". python-mode) + + ("\\.lua\\'" . lua-mode) + + ("\\.json\\'" . jsonian-mode) + + ("\\.go\\'" . go-mode) + + ("\\.css\\'" . css-mode) + ("\\.wxss\\'" . css-mode) + + ("\\.pdf\\'" . pdf-view-mode) + + ("\\.ts\\'" . typescript-mode) + ("\\.tsx\\'" . typescript-mode) + + ("\\.js.erb\\'" . web-mode) + ("\\.js\\'" . web-mode) + ("\\.wxs\\'" . web-mode) + + ("\\.vue" . web-mode) + ("\\.wxml" . web-mode) + ("\\.blade\\.php\\'" . web-mode) + ("\\.phtml\\'" . web-mode) + ("\\.tpl\\.php\\'" . web-mode) + ("\\.jsp\\'" . web-mode) + ("\\.mustache\\'" . web-mode) + ("\\.djhtml\\'" . web-mode) + ("\\.html?\\'" . web-mode) + ("\\.jsx\\'" . web-mode) + + ;; ("\\.rs$" . rust-mode) + ("CMakeLists\\.txt\\'" . cmake-mode) + ("\\.cmake\\'" . cmake-mode) + )) + (add-to-alist 'auto-mode-alist elt-cons)) + +;;; Mode load. +(autoload 'cmake-mode "cmake-mode") + +(autoload 'css-mode "css-mode") + +(autoload 'go-mode "go-mode") + +(autoload 'jsonian-mode "jsonian-mode") + +(autoload 'lua-mode "lua-mode") +(setq lua-indent-level 2) + +(autoload 'markdown-mode "markdown-mode") + +(autoload 'python-mode "init-python") + +(autoload 'web-mode "web-mode") + +;; (autoload 'rust-mode "rust-mode") + +(provide 'init-mode) + +;;; init-mode.el ends here diff --git a/site-lisp/init-config/init-neotree.el b/site-lisp/init-config/init-neotree.el new file mode 100644 index 0000000..97cf1c7 --- /dev/null +++ b/site-lisp/init-config/init-neotree.el @@ -0,0 +1,12 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'neotree) + +;;; Code: +(setq neo-theme 'ascii) +(setq neo-show-hidden-files t) +(setq neo-window-width 40) + +(provide 'init-neotree) + +;;; init-neotree.el ends here diff --git a/site-lisp/init-config/init-org-todo.el b/site-lisp/init-config/init-org-todo.el new file mode 100644 index 0000000..c33fb24 --- /dev/null +++ b/site-lisp/init-config/init-org-todo.el @@ -0,0 +1,37 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'org) + +;;; Code: +(setq org-agenda-files '("~/Documents/ld_org_todo")) + +(setq org-capture-templates + '( + ("t" "todo" entry + (file+datetree "~/Documents/ld_org_todo/todo.org") + "* TODO [#C] %?\n\n%i" + :empty-lines 1 :tree-type month) + ("w" "waiting" entry + (file+datetree "~/Documents/ld_org_todo/waiting.org") + "* TODO [#C] %?" + :empty-lines 1 :tree-type month) + )) + +(setq org-refile-targets + '( + ("~/Documents/ld_org_todo/todo.org" :maxlevel . 4) + ("~/Documents/ld_org_todo/waiting.org" :maxlevel . 4) + (nil :maxlevel . 4) + )) + +(setq org-use-fast-todo-selection t) +(setq org-todo-keywords '((sequence "TODO(t)" "DOING(i)" + "|" "DONE(d)" "ABORTED(a)"))) +(setq org-todo-keyword-faces '(("TODO" . "red") + ("DOING" . "blue") + ("DONE" . "forest green") + ("ABORTED" . "gray"))) + +(provide 'init-org-todo) + +;;; init-org-todo.el ends here. diff --git a/site-lisp/init-config/init-org.el b/site-lisp/init-config/init-org.el new file mode 100644 index 0000000..59d188c --- /dev/null +++ b/site-lisp/init-config/init-org.el @@ -0,0 +1,233 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'org) +(require 'ox-publish) + +;;; Code: +(defun ld-org-update-lastupdate-property () + "If '#+LASTUPDATE' is in org file, update it to the current date/time." + (when (eq major-mode 'org-mode) + (save-excursion + (widen) + (goto-char (point-min)) + (when (re-search-forward "^#\\+LASTUPDATE:" (point-max) t) + (progn + (setq lastupdate-point (point)) + (if (not (equal lastupdate-point (line-end-position))) + (delete-region lastupdate-point (line-end-position))) + (insert (format-time-string " %Y/%m/%d %H:%M"))))))) + +(add-hook 'before-save-hook #'ld-org-update-lastupdate-property) + +(setq org-startup-indented nil) ;; enable org-indent-mode at start, default nil. + +(setq org-goto-auto-isearch nil) +(setq org-support-shift-select t) + +(setq org-use-sub-superscripts '{}) +(setq org-export-with-sub-superscripts '{}) + +;; If it is not nil, strings below will be interpreted in exporting as +;; Org HTML LaTeX UTF-8 +;; -----+----------+--------+------- +;; \- ­ \- +;; -- – -- – +;; --- — --- — +;; ... … \ldots … +(setq org-export-with-special-strings nil) + +;; (set-face-attribute 'org-level-1 nil +;; :background "#fdf0ff" +;; :foreground "#000000" +;; :overline "#bcbcbc" +;; :bold t +;; :height 1.3) +;; (set-face-attribute 'org-level-2 nil +;; :foreground "#8f0075" +;; :overline "#bcbcbc" +;; :bold t +;; :height 1.1) +;; (set-face-attribute 'org-level-3 nil +;; :foreground "#093060" +;; :weight 'semi-bold) +;; (set-face-attribute 'org-level-4 nil +;; :foreground "#184034" +;; :weight 'semi-bold) +;; (set-face-attribute 'org-level-5 nil +;; :foreground "#61284f" +;; :weight 'semi-bold) +;; (set-face-attribute 'org-level-6 nil +;; :foreground "#3f3000" +;; :weight 'semi-bold) +;; (set-face-attribute 'org-level-7 nil +;; :foreground "#5f0000" +;; :weight 'semi-bold) +;; (set-face-attribute 'org-level-8 nil +;; :foreground "#541f4f" +;; :weight 'semi-bold) + +;; (set-face-attribute 'org-block-begin-line nil +;; :background "#f0f0f0" +;; :foreground "#505050" +;; :extend t) +;; (set-face-attribute 'org-block nil +;; :background "#f8f8f8" +;; :foreground "#000000" +;; :extend t +;; ) +;; (set-face-attribute 'org-block-end-line nil +;; :background "#f0f0f0" +;; :foreground "#505050" +;; :extend t) + +;; (set-face-attribute 'org-code nil +;; :background "#f0f0f0" +;; :foreground "#005a5f" +;; :extend t) + +;; (set-face-attribute 'org-verbatim nil +;; :background "#f0f0f0" +;; :foreground "#8f0075" +;; :extend t) + +(defun ld-org-custom-html-src-block (src-block _contents info) + "Transcode a SRC-BLOCK element from Org to HTML. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information. +MAKE FINAL HTML TO BE COMPATIBLE WITH highlight.js" + (if (org-export-read-attribute :attr_html src-block :textarea) + (org-html--textarea-block src-block) + (let ((lang (org-element-property :language src-block)) + (caption (org-export-get-caption src-block)) + (code (org-html-format-code src-block info)) + (label (let ((lbl (and (org-element-property :name src-block) + (org-export-get-reference src-block info)))) + (if lbl (format " id=\"%s\"" lbl) "")))) + (if (not lang) (format "
\n%s
" label code) + (format + "
\n%s%s\n
" + (if (not caption) "" + (format "" + (org-export-data caption info))) + (format "\n
%s
" + lang label lang code)))))) + +(advice-add 'org-html-src-block :override 'ld-org-custom-html-src-block) + +(defun ld-org-custom-html-format-list-item (contents type checkbox info + &optional term-counter-id + headline) + "Format a list item into HTML." + (let ((class (if checkbox + (format " class=\"%s\"" + (symbol-name checkbox)) "")) + (checkbox (concat (org-html-checkbox checkbox info) + (and checkbox " "))) + (br (org-html-close-tag "br" nil info)) + (extra-newline (if (and (org-string-nw-p contents) headline) "\n" ""))) + (concat + (pcase type + (`ordered + (let* ((counter term-counter-id) + (extra (if counter (format " value=\"%s\"" counter) ""))) + (concat + (format "" class extra) + (when headline (concat headline br))))) + (`unordered + (let* ((id term-counter-id) + (extra (if id (format " id=\"%s\"" id) ""))) + (concat + (format "" class extra) + (when headline (concat headline br))))) + (`descriptive + (let* ((term term-counter-id)) + (setq term (or term "(no term)")) + ;; Check-boxes in descriptive lists are associated to tag. + (concat (format "%s" + class (concat checkbox term)) + "

")))) + (unless (eq type 'descriptive) checkbox) + extra-newline + (and (org-string-nw-p contents) (org-trim contents)) + extra-newline + (pcase type + (`ordered "") + (`unordered "") + (`descriptive "

"))))) + +(advice-add 'org-html-format-list-item :override 'ld-org-custom-html-format-list-item) + +(defun ld-org-export-publish() + "Publish org and then generate sitemap.xml file." + (interactive) + ;; import project settings + (require 'ld-org-publish-project-desc) + ;; publish site + (org-publish-all) + ;; create sitemap for search engine + (let ( + ;; FULL PATH to doc root. MUST end with a slash. + (ld-site-pub-path-article-root "~/Public/ld_org_article_publish/article/") + ;; file name of sitemap file, relative to webroot. + ;; file name format: .xml + (ld-site-sitemap-file-name "sitemap.xml") + ;; site domain name + (ld-site-domain-name "lishouzhong.com") + ;; gzip it or not. t for true, nil for false. + (ld-site-sitemap-gzip-it-p nil)) + + (print (concat "begin: " (format-time-string "%Y-%m-%dT%T"))) + + ;; rename file to backup ~ if already exist + (let (f1 f2) + (setq f1 (concat ld-site-pub-path-article-root ld-site-sitemap-file-name)) + (setq f2 (concat f1 ".gz")) + (when (file-exists-p f1) + (rename-file f1 (concat f1 "~") t)) + (when (file-exists-p f2) + (rename-file f2 (concat f2 "~") t))) + + ;; create sitemap buffer + (let (article-file-path sitemap-buffer) + (setq article-file-path + (concat ld-site-pub-path-article-root ld-site-sitemap-file-name)) + (setq sitemap-buffer (find-file article-file-path)) + (erase-buffer) + (set-buffer-file-coding-system 'unix) + (insert " +") + + (require 'find-lisp) + + (let ((process-sitemap-content + (lambda (article-file-path dest-buffer) + (when (not (string-match "/zzz" article-file-path)) ; dir/file starting with zzz are not public + (with-temp-buffer + (insert-file-contents article-file-path nil nil nil t) + (goto-char 1) + (when (not (search-forward "") + (insert (concat + "http://" + ld-site-domain-name + "/" + (substring article-file-path + (length (expand-file-name ld-site-pub-path-article-root))))) + (insert "\n")))))))) + (mapc + (lambda (x) (funcall process-sitemap-content x sitemap-buffer)) + (find-lisp-find-files ld-site-pub-path-article-root "\\.html$"))) + + (insert "") + + (save-buffer) + + (when ld-site-sitemap-gzip-it-p + (shell-command (concat "gzip " article-file-path)))) + + (print (concat "finished: " (format-time-string "%Y-%m-%dT%T"))))) + +(provide 'init-org) + +;;; init-org.el ends here diff --git a/site-lisp/init-config/init-proxy.el b/site-lisp/init-config/init-proxy.el new file mode 100644 index 0000000..fa191b8 --- /dev/null +++ b/site-lisp/init-config/init-proxy.el @@ -0,0 +1,45 @@ +;; -*- coding: utf-8; -*- +;;; Require + +;;; Code: +(defun proxy-socks-show () + "Show SOCKS proxy." + (interactive) + (when (fboundp 'cadddr) + (if (bound-and-true-p socks-noproxy) + (message "Current SOCKS%d proxy is %s:%d" + (cadddr socks-server) (cadr socks-server) (caddr socks-server)) + (message "No SOCKS proxy")))) + +(defun proxy-socks-enable () + "Enable SOCKS proxy." + (interactive) + (require 'socks) + (setq url-gateway-method 'socks + socks-noproxy '("localhost") + socks-server '("Default server" "127.0.0.1" 10800 5)) + (setenv "all_proxy" "socks5://127.0.0.1:10800") + (proxy-socks-show)) + +(defun proxy-socks-disable () + "Disable SOCKS proxy." + (interactive) + (require 'socks) + (setq url-gateway-method 'native + socks-noproxy nil) + (setenv "all_proxy" "") + (proxy-socks-show)) + +(defun proxy-socks-toggle () + "Toggle SOCKS proxy." + (interactive) + (require 'socks) + (if (bound-and-true-p socks-noproxy) + (proxy-socks-disable) + (proxy-socks-enable))) + +;; (proxy-socks-enable) + +(provide 'init-proxy) + +;;; init-proxy.el ends here diff --git a/site-lisp/init-config/init-session.el b/site-lisp/init-config/init-session.el new file mode 100644 index 0000000..baf3fea --- /dev/null +++ b/site-lisp/init-config/init-session.el @@ -0,0 +1,51 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'auto-save) + +;;; Code: + +(setq desktop-load-locked-desktop t) ; don't popup dialog ask user, load anyway +(setq desktop-restore-frames nil) ; don't restore any frame + +(defun kill-unused-buffers () + (interactive) + (ignore-errors + (save-excursion + (dolist (buf (buffer-list)) + (set-buffer buf) + (when (and (string-prefix-p "*" (buffer-name)) (string-suffix-p "*" (buffer-name))) + (kill-buffer buf)) + )))) + +(defun emacs-session-restore () + "Restore emacs session." + (interactive) + (ignore-errors + ;; Kill other windows. + (delete-other-windows) + ;; Kill unused buffers. + (kill-unused-buffers) + ;; Restore session. + (desktop-read "~/.emacs.d/") + )) + +(defun emacs-session-save (&optional arg) + "Save emacs session." + (interactive "p") + (ignore-errors + (if (equal arg 4) + ;; Kill all buffers if with prefix argument. + (mapc 'kill-buffer (buffer-list)) + ;; Kill unused buffers. + (kill-unused-buffers) + ;; Save all buffers before exit. + (auto-save-buffers)) + ;; Save session. + (make-directory "~/.emacs.d/" t) + (desktop-save "~/.emacs.d/") + ;; Exit emacs. + (kill-emacs))) + +(provide 'init-session) + +;;; init-session.el ends here diff --git a/site-lisp/init-config/init-shortcut.el b/site-lisp/init-config/init-shortcut.el new file mode 100644 index 0000000..81c0bea --- /dev/null +++ b/site-lisp/init-config/init-shortcut.el @@ -0,0 +1,256 @@ +;; -*- coding: utf-8; -*- + +;;; There are 3 sections: +;;; - unset keys +;;; - extensions +;;; - extensions-local +;;; - shortcut on built-in function + +;;; ------------ unset keys + +; originally +; 'C-i' is TAB +; 'C-r' is isearch-backward +(lazy-load-unset-keys + '("C-z" "C-\\" "C-'" "C-i" "C-r")) + + + +;;; ------------ extensions + +;; ------ ace-window +(lazy-load-global-keys + '( + ("M-o" . ace-window) + ) + "init-ace-window") + +;; ------ avy +(lazy-load-global-keys + '( + ("M-g c" . avy-goto-char) + ("M-g w" . avy-goto-word-1) + ("M-g s" . avy-goto-word-0) + ("M-g l l" . avy-goto-line) + ("M-g j" . avy-next) + ("M-g k" . avy-prev) + ) + "init-avy") + +;; ------ citre +(lazy-load-global-keys + '( + ("C-x c c" . citre-mode) + ("C-x c j" . citre-jump) + ("C-x c J" . citre-jump-back) + ("C-x c p" . citre-ace-peek) + ("C-x c u" . citre-update-this-tags-file) + ) + "init-citre") + +;; ------ theme +(lazy-load-global-keys + '( + ("" . ld-modus-themes-toggle) + ) + "init-theme") + +;; ------ multiple cursors +(lazy-load-global-keys + '( + ("C-M-." . mc/mark-next-like-this) + ("C-M-," . mc/unmark-next-like-this) + ("M-<" . mc/mark-previous-like-this) + ("M->" . mc/unmark-previous-like-this) + ("C-M-<" . mc/edit-beginnings-of-lines) + ("M-" . mc/add-cursor-on-click) + ) + "multiple-cursors") + +;; ------ swiper +(lazy-load-set-keys + '( + ("C-s" . swiper-isearch) + ("C-c s" . counsel-rg) + )) + + + +;;; ------------ extensions-local + +(lazy-load-set-keys + '( + ;; dired-display-buffer + ("o" . dired-display-buffer) + ;; dired-narrow + ("/" . dired-narrow) + ;; dired-subtree + ("" . dired-subtree-cycle) + ("SPC" . dired-subtree-toggle) + ("C-p" . dired-subtree-previous-sibling) + ("C-n" . dired-subtree-next-sibling) + ("r" . dired-subtree-revert) + ) + dired-mode-map) + +(lazy-load-global-keys + '( + ("C-c e e" . toggle-echo-keys) + ("C-c e c" . echo-keys-clean) + ) + "echo-keys") ;show every pressed keys + +(lazy-load-global-keys + '( + ("C-c x e" . ld-eval-elisp-to-next-line) + ) + "evals") ;execute code + +(lazy-load-global-keys + '( + ("C-<" . ld-un-indent) + ("C->" . ld-indent) + ) + "force-indent") ;control 4 spaces indent manually + +(lazy-load-global-keys + '( + ("C-c \\" . goto-last-change) + ) + "goto-last-change") + +(lazy-load-global-keys + '( + ("M-g l p" . goto-line-preview) + ) + "goto-line-preview") + +(lazy-load-global-keys + '( + ("C-c m h a" . highlight-indentation-mode) + ("C-c m h c" . highlight-indentation-current-column-mode) + ) + "highlight-indentation") + +(lazy-load-global-keys + '( + ("C-r i" . ld-indent-buffer) + ("C-r r" . ld-rename-file-and-buffer) + ("C-r d" . ld-delete-file-and-buffer) + ("C-r e" . ld-revert-buffer-no-confirm) + ("C-i r" . ld-find-file-in-root) ; open file with root by sudo + ) + "ld-buffer-operations") + +(lazy-load-global-keys + '( + ("C-;" . ld-cursor-position-1-store) ;store cursor position + ("C-'" . ld-cursor-position-1-jump) ;jump to cursor position + ("C-c ," . ld-cursor-position-stack-push) ;push cursor position to stack + ("C-c ." . ld-cursor-position-stack-pop) ;pop corsor position from stack + ) + "ld-goto-cursor-stack") + +(lazy-load-global-keys + '( + ("M-N" . ld-delete-one-block-backward) + ("M-M" . ld-delete-one-block-forward) + ) + "ld-delete-block") ;delete a block (eg. a word) forward and backward + +(lazy-load-global-keys + '( + ("C-i r" . ld-find-file-in-root) ; open file with root by sudo + ) + "ld-file-operations") + +(lazy-load-global-keys + '( + ("M-g l p" . ld-goto-percent-line) + ("M-g t p" . ld-goto-percent-text) + ("M-g t c" . ld-goto-column) + ) + "ld-goto-simple") + +(lazy-load-global-keys + '( + ("M-p" . ld-move-text-up) + ("M-n" . ld-move-text-down) + ("C-c l d" . ld-duplicate-current-line-or-region) + ("C-c l D" . ld-duplicate-and-comment-current-line-or-region) + ("C-c l k" . ld-delete-current-line) + ("C-c m l" . ld-mark-line) + ) + "ld-text-operations") + +(lazy-load-global-keys + '( + ("C-c w t" . ld-toggle-one-window) + ) + "ld-toggle-one-window") ;maxmize current window and size back + +(lazy-load-global-keys + '(("C-x j" . neotree-toggle)) + "init-neotree") + +(lazy-load-global-keys + '( + ("M-j" . watch-next-window-up-line) ; 'up' to see previous content + ("M-k" . watch-next-window-down-line) ; 'down' to see further content + ("M-J" . watch-next-window-up) + ("M-K" . watch-next-window-down) + ) + "scroll-next-window") + +(lazy-load-global-keys + '( + ("" . emacs-session-save) + ) + "init-session") + + + +;;; ------------ shortcut on built-in function + +;; ------ org related +(lazy-load-set-keys + '( + ("C-c o c" . org-capture) + ("C-c o a" . org-agenda) + ("C-c o l r" . org-list-repair) + )) + +;; ------ move cursors in current buffer +(lazy-load-set-keys + '( + ("M-g b k" . beginning-of-buffer) + ("M-g b j" . end-of-buffer) + ("M-g h j" . forward-paragraph) + ("M-g h k" . backward-paragraph) + ("M-g l y" . backward-up-list) ;向左跳出 LIST + ("M-g l o" . up-list) ;向右跳出 LIST + ("M-g l u" . backward-down-list) ;向左跳进 LIST + ("M-g l i" . down-list) ;向右跳进 LIST + ("M-g f a" . beginning-of-defun) ;函数开头 + ("M-g f e" . end-of-defun) ;函数末尾 + )) + +;; ------ other +(lazy-load-set-keys + '( + ("C-z r" . global-hl-line-mode) + ("C-z l" . display-line-numbers-mode) + ("M--" . text-scale-decrease) + ("M-=" . text-scale-increase) + ("M-," . bury-buffer) + ("M-." . unbury-buffer) + ("C-c m m" . set-mark-command) ; replace C-Space for Chinese input method + ("M-;" . comment-dwim) + ("C-c r" . recentf-open-files) + )) + + + +(provide 'init-shortcut) + +;;; init-shortcut.el ends here diff --git a/site-lisp/init-config/init-swiper.el b/site-lisp/init-config/init-swiper.el new file mode 100644 index 0000000..8a064ea --- /dev/null +++ b/site-lisp/init-config/init-swiper.el @@ -0,0 +1,34 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'ivy) +(require 'counsel) +(require 'swiper) + +;;; Code: +(setq ivy-use-virtual-buffers t) +(setq ivy-initial-inputs-alist nil) +(setq ivy-count-format "(%d/%d) ") + +;; Map commands to their minimum required input length. +;; That is the number of characters prompted for before fetching +;; candidates. The special key t is used as a fallback. +(setq ivy-more-chars-alist '((t . 2))) + +(ivy-mode 1) + +(setq counsel-rg-base-command + `("rg" + "--max-columns" "0" + "--with-filename" + "--no-heading" + "--line-number" + "--color" "never" + "%s" + ,@(and (memq system-type '(ms-dos windows-nt)) + (list "--path-separator" "/" ".")))) + +(counsel-mode 1) + +(provide 'init-swiper) + +;; init-swiper.el ends here diff --git a/site-lisp/init-config/init-theme.el b/site-lisp/init-config/init-theme.el new file mode 100644 index 0000000..59d9c8a --- /dev/null +++ b/site-lisp/init-config/init-theme.el @@ -0,0 +1,82 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'modus-themes) + +;;; Code: +;; font +(when (and window-system *win64*) + (let ((default-font (font-spec :name "Sarasa Fixed SC")) + (cn-font (font-spec :name "Sarasa Fixed SC"))) + (set-face-attribute 'default nil :font default-font :height 116) + (dolist (charset '(kana han symbol cjk-misc bopomofo)) + (set-fontset-font t charset cn-font))) + (set-face-font 'fixed-pitch "Sarasa Fixed SC")) + +;; theme +;; In all of the following, WEIGHT is a symbol such as `semibold', +;; `light', `bold', or anything mentioned in `modus-themes-weights'. +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-mixed-fonts t + modus-themes-variable-pitch-ui nil + modus-themes-custom-auto-reload t + modus-themes-disable-other-themes t + + ;; Options for `modus-themes-prompts' are either nil (the + ;; default), or a list of properties that may include any of those + ;; symbols: `italic', `WEIGHT' + modus-themes-prompts '(italic bold) + + ;; The `modus-themes-completions' is an alist that reads two + ;; keys: `matches', `selection'. Each accepts a nil value (or + ;; empty list) or a list of properties that can include any of + ;; the following (for WEIGHT read further below): + ;; + ;; `matches' :: `underline', `italic', `WEIGHT' + ;; `selection' :: `underline', `italic', `WEIGHT' + modus-themes-completions + '((matches . (extrabold)) + (selection . (semibold italic text-also))) + + modus-themes-org-blocks 'gray-background ; {nil,'gray-background,'tinted-background} + + ;; The `modus-themes-headings' is an alist: read the manual's + ;; node about it or its doc string. Basically, it supports + ;; per-level configurations for the optional use of + ;; `variable-pitch' typography, a height value as a multiple of + ;; the base font size (e.g. 1.5), and a `WEIGHT'. + modus-themes-headings + '((1 . (variable-pitch 1.5)) + (2 . (1.3)) + (agenda-date . (1.3)) + (agenda-structure . (variable-pitch light 1.8)) + (t . (1.1)))) + +(defun ld-modus-operandi () + "Light theme." + (interactive) + ;; load theme firstly and then do user customization + ;; otherwise modus-themes will override the face user had assigned + (load-theme 'modus-operandi :no-confirm)) + +(defun ld-modus-vivendi-tinted () + "Dark theme." + (interactive) + ;; load theme firstly and then do user customization + ;; otherwise modus-themes will override the face user had assigned + (load-theme 'modus-vivendi-tinted :no-confirm)) + +(defun ld-modus-themes-toggle () + (interactive) + (if (eq (car custom-enabled-themes) 'modus-operandi) + (ld-modus-vivendi-tinted) + (ld-modus-operandi))) + +;; active light theme +(if window-system + (ld-modus-operandi) + (ld-modus-vivendi-tinted)) + +(provide 'init-theme) + +;;; init-theme.el ends here diff --git a/site-lisp/init-config/init-time.el b/site-lisp/init-config/init-time.el new file mode 100644 index 0000000..099240f --- /dev/null +++ b/site-lisp/init-config/init-time.el @@ -0,0 +1,14 @@ +;; -*- coding: utf-8; -*- +;;; Require: + +;;; Code: + +(setq display-time-day-and-date t) +(setq display-time-format "%Y/%m/%d %H:%M") +(setq display-time-24hr-format t) +(display-time-mode 1) +(display-time) + +(provide 'init-time) + +;;; init-time.el ends here diff --git a/site-lisp/init-config/init-undo-tree.el b/site-lisp/init-config/init-undo-tree.el new file mode 100644 index 0000000..af5020f --- /dev/null +++ b/site-lisp/init-config/init-undo-tree.el @@ -0,0 +1,19 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'undo-tree) + +;;; Code: +(global-undo-tree-mode) + +;; ;; --- undo-tree +;; (lazy-load-local-keys +;; '( +;; ("C-/" . undo-tree-undo) +;; ("C-?" . undo-tree-redo) +;; ) +;; undo-tree-map +;; "undo-tree") + +(provide 'init-undo-tree) + +;;; init-undo-tree.el ends here diff --git a/site-lisp/init-config/init-which-key.el b/site-lisp/init-config/init-which-key.el new file mode 100644 index 0000000..213ce9b --- /dev/null +++ b/site-lisp/init-config/init-which-key.el @@ -0,0 +1,17 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'which-key) + +;;; Code: +(setq which-key-show-early-on-C-h t) +(setq which-key-idle-delay 10000) +(setq which-key-idle-secondary-delay 0.05) +(setq which-key-max-description-length nil) ;; show entire key name + +(which-key-mode) + +(which-key-setup-side-window-bottom) + +(provide 'init-which-key) + +;;; init-which-key.el ends here diff --git a/site-lisp/init-config/init-yasnippet.el b/site-lisp/init-config/init-yasnippet.el new file mode 100644 index 0000000..f126f43 --- /dev/null +++ b/site-lisp/init-config/init-yasnippet.el @@ -0,0 +1,17 @@ +;; -*- coding: utf-8; -*- +;;; Require: +(require 'yasnippet) + +;;; Code: +(setq yas-snippet-dirs (list (concat ld-emacs-root-dir "/snippets"))) +(yas-global-mode 1) + +;; Disable yasnippet mode on some mode. +(dolist (hooks (list + 'term-mode-hook + )) + (add-hook hooks #'(lambda () (yas-minor-mode -1)))) + +(provide 'init-yasnippet) + +;;; init-yasnippet.el ends here diff --git a/site-lisp/init-config/init.el b/site-lisp/init-config/init.el new file mode 100644 index 0000000..8d03481 --- /dev/null +++ b/site-lisp/init-config/init.el @@ -0,0 +1,46 @@ +;;; -*- coding: utf-8-unix; lexical-binding: t; -*- + +(let ( + ;; Make startup faster by reducing the frequency of garbage collection. + ;; default (* 800 1000) bytes + (gc-cons-threshold most-positive-fixnum) + ;; default 0.1 + (gc-cons-percentage 0.6)) + + ;; keep frame size + (setq frame-inhibit-implied-resize t) + + ;; from local extensions + ;; firstly loaded part + (require 'init-theme) + (require 'lazy-load) + (require 'init-generic) + (require 'ld-tools) + + (require 'init-auto-save) + (require 'init-coding-system) + (require 'init-company-mode) + (require 'init-dired) + (require 'init-highlight-parentheses) + (require 'init-indent) + (require 'init-mode) + (require 'init-org-todo) + (require 'init-org) + (require 'init-proxy) + (require 'init-swiper) + (require 'init-time) + (require 'init-undo-tree) + (require 'init-which-key) + (require 'init-yasnippet) + + ;; restore session + (require 'init-session) + (emacs-session-restore) + + ;; finally load other plugins dynamically + (require 'init-shortcut) +) + +(provide 'init) + +;;; init.el ends here diff --git a/site-lisp/snippets/lua-mode/function b/site-lisp/snippets/lua-mode/function new file mode 100644 index 0000000..c02ca67 --- /dev/null +++ b/site-lisp/snippets/lua-mode/function @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: function +# key: fun +# -- +function ${1: fun_name}() +end \ No newline at end of file diff --git a/site-lisp/snippets/org-mode/bloghead b/site-lisp/snippets/org-mode/bloghead new file mode 100644 index 0000000..bf44fcb --- /dev/null +++ b/site-lisp/snippets/org-mode/bloghead @@ -0,0 +1,8 @@ +# -*- mode: snippet -*- +# name: bloghead +# key: bh +# -- + +#+TITLE: +#+DATE: +#+LASTUPDATE: \ No newline at end of file diff --git a/site-lisp/snippets/org-mode/notehead b/site-lisp/snippets/org-mode/notehead new file mode 100644 index 0000000..fd7f678 --- /dev/null +++ b/site-lisp/snippets/org-mode/notehead @@ -0,0 +1,7 @@ +# -*- mode: snippet -*- +# name: notehead +# key: nh +# -- + +#+TITLE: +#+LASTUPDATE: \ No newline at end of file diff --git a/site-lisp/snippets/sh-mode/bang b/site-lisp/snippets/sh-mode/bang new file mode 100644 index 0000000..5e11f0e --- /dev/null +++ b/site-lisp/snippets/sh-mode/bang @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: bang +# key: ! +# -- +#!/usr/bin/env bash +$0 \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/cont b/site-lisp/snippets/snippet-mode/cont new file mode 100644 index 0000000..3783d54 --- /dev/null +++ b/site-lisp/snippets/snippet-mode/cont @@ -0,0 +1,5 @@ +# -*- mode: snippet -*- +# name: cont +# key: cont +# -- +# contributor: `user-full-name` \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/elisp b/site-lisp/snippets/snippet-mode/elisp new file mode 100644 index 0000000..768e94d --- /dev/null +++ b/site-lisp/snippets/snippet-mode/elisp @@ -0,0 +1,5 @@ +# -*- mode: snippet -*- +# name: elisp +# key: ` +# -- +\`$0\` \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/field b/site-lisp/snippets/snippet-mode/field new file mode 100644 index 0000000..12ff0e0 --- /dev/null +++ b/site-lisp/snippets/snippet-mode/field @@ -0,0 +1,6 @@ +# name : ${ ... } field +# contributor : joaotavora +# key : $f +# key: field +# -- +\${${1:${2:n}:}$3${4:\$(${5:lisp-fn})}\}$0 \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/group b/site-lisp/snippets/snippet-mode/group new file mode 100644 index 0000000..3ae8fd2 --- /dev/null +++ b/site-lisp/snippets/snippet-mode/group @@ -0,0 +1,5 @@ +# -*- mode: snippet -*- +# name: group +# key: group +# -- +# group : ${1:group} \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/mirror b/site-lisp/snippets/snippet-mode/mirror new file mode 100644 index 0000000..2a45042 --- /dev/null +++ b/site-lisp/snippets/snippet-mode/mirror @@ -0,0 +1,6 @@ +# name : ${n:$(...)} mirror +# key : $m +# contributor : joaotavora +# key: mirror +# -- +\${${2:n}:${4:\$(${5:reflection-fn})}\}$0 \ No newline at end of file diff --git a/site-lisp/snippets/snippet-mode/vars b/site-lisp/snippets/snippet-mode/vars new file mode 100644 index 0000000..ec4e4b6 --- /dev/null +++ b/site-lisp/snippets/snippet-mode/vars @@ -0,0 +1,13 @@ +# -*- mode: snippet -*- +# name : Snippet header +# contributor : joaotavora +# key: vars +# -- +# name : $1${2: +# key : ${3:trigger-key}}${4: +# keybinding : ${5:keybinding}}${6: +# expand-env : (${7:})} +# contributor : $6 +# key: vars +# -- +$0 \ No newline at end of file diff --git a/site-start.el b/site-start.el new file mode 100644 index 0000000..f6f2646 --- /dev/null +++ b/site-start.el @@ -0,0 +1,51 @@ +(require 'cl-lib) + +(defun add-subdirs-to-load-path (search-dir) + (interactive) + (let* ((dir (file-name-as-directory search-dir))) + (dolist (subdir + ;; 过滤出不必要的目录，提升Emacs启动速度 + (cl-remove-if + #'(lambda (subdir) + (or + ;; 不是目录的文件都移除 + (not (file-directory-p (concat dir subdir))) + ;; 父目录、 语言相关和版本控制目录都移除 + (member subdir '("." ".." + "dist" "node_modules" "__pycache__" + "RCS" "CVS" "rcs" "cvs" ".git" ".github")))) + (directory-files dir))) + (let ((subdir-path (concat dir (file-name-as-directory subdir)))) + ;; 目录下有 .el .so .dll 文件的路径才添加到 `load-path' 中，提升Emacs启动速度 + (when (cl-some #'(lambda (subdir-file) + (and (file-regular-p (concat subdir-path subdir-file)) + ;; .so .dll 文件指非Elisp语言编写的Emacs动态库 + (member (file-name-extension subdir-file) '("el" "so" "dll")))) + (directory-files subdir-path)) + + ;; 注意：add-to-list 函数的第三个参数必须为 t ，表示加到列表末尾 + ;; 这样Emacs会从父目录到子目录的顺序搜索Elisp插件，顺序反过来会导致Emacs无法正常启动 + (add-to-list 'load-path subdir-path t)) + + ;; 继续递归搜索子目录 + (add-subdirs-to-load-path subdir-path))))) + +;; get emacs version and operating system type +(defvar *emacs27* (>= emacs-major-version 27)) +(defvar *is-a-mac* (eq system-type 'darwin)) +(defvar *win64* (eq system-type 'windows-nt)) +(defvar *cygwin* (eq system-type 'cygwin)) +(defvar *linux* (or (eq system-type 'gnu/linux) (eq system-type 'linux))) +(defvar *unix* (or *linux* + (eq system-type 'usg-unix-v) + (eq system-type 'berkeley-unix))) + +(defvar ld-emacs-root-dir (file-truename "~/ld-emacs/site-lisp")) + +(if *win64* + (add-subdirs-to-load-path ld-emacs-root-dir)) + +(if *linux* + (add-subdirs-to-load-path "/usr/share/emacs/ld")) + +(require 'init)