[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master 30603ca 3/3: * externals-list: Convert almost all remainin
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] master 30603ca 3/3: * externals-list: Convert almost all remaining :subtrees to :external |
|
Date: |
Tue, 1 Dec 2020 17:56:29 -0500 (EST) |
branch: master
commit 30603ca53edb85530d922f5a77fe0da58b695be2
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
* externals-list: Convert almost all remaining :subtrees to :external
Packages affected:
adjust-parens all auto-correct caps-lock captain cl-generic
cl-lib company-ebdb crisp cycle-quotes docbook ebdb-gnorb
el-search electric-spacing epoch-view filladapt flylisp
frame-tabs gnu-elpa-keyring-update greenbar iterators jumpc
kmb landmark lex memory-usage minibuffer-line minimap nadvice
oauth2 org-translate other-frame-window package-fixes path-iterator
poker quarter-plane rainbow-mode rcirc-menu scroll-restore sed-mode
seq shelisp shell-quasiquote smart-yank sokoban sql-beeline stream
svg-clock systemd tramp-theme transcribe uniquify-files validate
visual-fill
---
externals-list | 54 +
packages/adjust-parens/Makefile | 17 -
packages/adjust-parens/adjust-parens-tests.el | 107 -
packages/adjust-parens/adjust-parens.el | 353 --
packages/all/all.el | 203 -
packages/auto-correct/auto-correct.el | 415 --
packages/caps-lock/caps-lock.el | 50 -
packages/captain/captain.el | 229 -
packages/cl-generic/cl-generic.el | 132 -
packages/cl-lib/cl-lib.el | 376 --
packages/company-ebdb/company-ebdb.el | 91 -
packages/crisp/crisp.el | 392 --
packages/cycle-quotes/cycle-quotes-test.el | 83 -
packages/cycle-quotes/cycle-quotes.el | 147 -
packages/docbook/docbook.el | 1218 -----
packages/ebdb-gnorb/ebdb-gnorb.el | 230 -
packages/el-search/NEWS | 224 -
packages/el-search/el-search-x.el | 571 ---
packages/el-search/el-search.el | 5267 --------------------
packages/electric-spacing/electric-spacing.el | 352 --
packages/epoch-view/epoch-view.el | 99 -
packages/filladapt/filladapt.el | 854 ----
packages/flylisp/flylisp.el | 506 --
packages/frame-tabs/frame-tabs.el | 520 --
.../etc/gnu-elpa.gpg-keyring | Bin 2069 -> 0 bytes
.../gnu-elpa-keyring-update.el | 110 -
packages/greenbar/greenbar.el | 211 -
packages/iterators/iterators.el | 431 --
packages/jumpc/jumpc.el | 235 -
packages/kmb/kmb.el | 160 -
packages/landmark/landmark.el | 1686 -------
packages/lex/lex-parse-re.el | 258 -
packages/lex/lex.el | 1269 -----
packages/memory-usage/memory-usage.el | 179 -
packages/minibuffer-line/minibuffer-line.el | 78 -
packages/minimap/minimap.el | 937 ----
packages/nadvice/nadvice.el | 94 -
packages/oauth2/oauth2.el | 260 -
packages/org-translate/org-translate.el | 809 ---
packages/other-frame-window/other-frame-window.el | 436 --
packages/package-fixes/package-fixes.el | 148 -
.../path-iterator-resources/alice-1/bar-file1.text | 1 -
.../path-iterator-resources/alice-1/foo-file1.text | 1 -
.../bob-1/bob-2/foo-file2.text | 1 -
.../bob-1/bob-3/foo-file3.text | 1 -
.../path-iterator-resources/file-0.text | 1 -
packages/path-iterator/path-iterator-test.el | 203 -
packages/path-iterator/path-iterator.el | 293 --
packages/poker/poker.el | 1101 ----
packages/quarter-plane/quarter-plane.el | 113 -
packages/rainbow-mode/rainbow-mode.el | 1218 -----
packages/rcirc-menu/rcirc-menu.el | 308 --
packages/scroll-restore/scroll-restore.el | 478 --
packages/sed-mode/sed-mode.el | 140 -
packages/seq/seq-24.el | 496 --
packages/seq/seq-25.el | 601 ---
packages/seq/seq.el | 48 -
packages/seq/tests/seq-tests.el | 382 --
packages/shelisp/shelisp.el | 218 -
packages/shell-quasiquote/shell-quasiquote.el | 123 -
packages/smart-yank/smart-yank.el | 192 -
packages/sokoban/sokoban.el | 983 ----
packages/sokoban/sokoban.levels | 1290 -----
packages/sql-beeline/sql-beeline.el | 93 -
packages/stream/stream-x.el | 150 -
packages/stream/stream.el | 504 --
packages/stream/tests/stream-tests.el | 312 --
packages/svg-clock/svg-clock.el | 320 --
packages/systemd/systemctl.el | 317 --
packages/systemd/systemd-codegen.el | 258 -
packages/systemd/systemd-mode.el | 200 -
packages/systemd/systemd.el | 4802 ------------------
packages/tramp-theme/README | 11 -
packages/tramp-theme/tramp-theme.el | 179 -
packages/transcribe/transcribe.el | 419 --
.../Alice/alice-1/bar-file1.text | 1 -
.../Alice/alice-1/bar-file2.text | 1 -
.../Alice/alice-1/foo-file1.text | 1 -
.../Alice/alice-1/foo-file2.text | 1 -
.../Alice/alice-2/bar-file1.text | 1 -
.../Alice/alice-2/bar-file2.text | 1 -
.../Alice/alice-2/foo-file1.text | 1 -
.../Alice/alice-2/foo-file3.text | 1 -
.../Alice/alice-2/foo-file3.texts | 1 -
.../Alice/alice-3/foo-file4.text | 1 -
.../Bob/alice-3/foo-file4.text | 1 -
.../Bob/bob-1/foo-file1.text | 1 -
.../Bob/bob-1/foo-file2.text | 1 -
.../Bob/bob-2/foo-file1.text | 1 -
.../Bob/bob-2/foo-file5.text | 1 -
.../uniquify-files-resources/foo-file1.text | 1 -
.../uniquify-files-resources/foo-file3.texts2 | 1 -
.../wisitoken-generate-packrat-test.text | 1 -
.../wisitoken-syntax_trees-test.text | 1 -
.../wisitoken-text_io_trace.text | 1 -
packages/uniquify-files/uniquify-files-test.el | 487 --
packages/uniquify-files/uniquify-files.el | 324 --
packages/validate/validate.el | 211 -
packages/visual-fill/visual-fill.el | 77 -
99 files changed, 54 insertions(+), 36613 deletions(-)
diff --git a/externals-list b/externals-list
index 94873e7..0eaf583 100644
--- a/externals-list
+++ b/externals-list
@@ -35,15 +35,18 @@
("ada-mode" :external nil)
("ada-ref-man" :external nil)
("adaptive-wrap" :external nil)
+ ("adjust-parens" :external nil)
("advice-patch" :external nil)
("aggressive-indent" :external
"https://github.com/Malabarba/aggressive-indent-mode";)
("ahungry-theme" :external
"https://github.com/ahungry/color-theme-ahungry";)
+ ("all" :external nil)
("ampc" :external nil)
("arbitools" :external nil)
("ascii-art-to-unicode" :external nil)
("async" :external "https://github.com/jwiegley/emacs-async";)
("auctex" :external "git://git.sv.gnu.org/auctex.git")
("aumix-mode" :external nil)
+ ("auto-correct" :external nil)
("avy" :external "https://github.com/abo-abo/avy";)
("bbdb" :external "git://git.savannah.nongnu.org/bbdb.git")
("beacon" :external "https://github.com/Malabarba/beacon";)
@@ -69,18 +72,25 @@
;; ;; FIXME: elpa.gnu.org doesn't know how to
build
;; ;; the .info file from this texi file!
;; "doc/misc/cc-mode.texi"))
+ ("caps-lock" :external nil)
+ ("captain" :external nil)
("chess" :external nil) ;; Was
https://github.com/jwiegley/emacs-chess.git
+ ("cl-generic" :external nil)
+ ("cl-lib" :external nil)
("cobol-mode" :external
"https://gist.github.com/Edward-H/6768e7dc53ea3dd2adca";)
("cl-print" :core "lisp/emacs-lisp/cl-print.el")
("clipboard-collector" :external
"https://github.com/clemera/clipboard-collector";)
("coffee-mode" :external
"https://github.com/defunkt/coffee-mode";)
("compact-docstrings" :external
"https://github.com/cpitclaudel/compact-docstrings";)
("company" :external
"https://github.com/company-mode/company-mode.git";)
+ ("company-ebdb" :external nil)
("company-math" :external "https://github.com/vspinu/company-math.git";)
("company-statistics" :external
"https://github.com/company-mode/company-statistics";)
("context-coloring" :external
"https://github.com/jacksonrayhamilton/context-coloring.git";)
("cpio-mode" :external "https://github.com/dlewan/cpio-mode";)
+ ("crisp" :external nil)
("csv-mode" :external nil)
+ ("cycle-quotes" :external nil)
("darkroom" :external
"https://github.com/capitaomorte/darkroom.git";)
("dash" :external "https://github.com/magnars/dash.el.git";)
("dbus-codegen" :external "https://github.com/ueno/dbus-codegen-el.git";)
@@ -93,24 +103,32 @@
("disk-usage" :external
"https://gitlab.com/ambrevar/emacs-disk-usage";)
("dismal" :external nil)
("djvu" :external nil)
+ ("docbook" :external nil)
("dts-mode" :external "https://github.com/bgamari/dts-mode.git";)
("easy-kill" :external "https://github.com/leoliu/easy-kill";)
("ebdb" :external "https://github.com/girzel/ebdb.git";)
+ ("ebdb-gnorb" :external nil)
("ebdb-i18n-chn" :external nil)
("ediprolog" :external nil)
("eev" :external "https://github.com/edrx/eev.git";)
;branch UTF-8
("eglot" :external "https://github.com/joaotavora/eglot.git";)
+ ("el-search" :external nil)
("eldoc" :core "lisp/emacs-lisp/eldoc.el")
("eldoc-eval" :external
"https://github.com/thierryvolpiatto/eldoc-eval.git";)
+ ("electric-spacing" :external nil)
("elisp-benchmarks" :external nil)
("emms" :external "https://git.savannah.gnu.org/git/emms.git";)
("enwc" :external
"hg::https://hg.savannah.nongnu.org/hgweb/enwc/";)
+ ("epoch-view" :external nil)
("ergoemacs-mode" :external
"https://github.com/ergoemacs/ergoemacs-mode.git";)
("excorporate" :external nil)
("expand-region" :external "https://github.com/magnars/expand-region.el";)
("exwm" :external "https://github.com/ch11ng/exwm.git";)
("f90-interface-browser" :external "https://github.com/wence-/f90-iface";)
+ ("filladapt" :external nil)
+ ("flylisp" :external nil)
("flymake" :core "lisp/progmodes/flymake.el")
+ ("frame-tabs" :external nil)
("frog-menu" :external "https://github.com/clemera/frog-menu";)
("fsm" :external nil)
("gcmh" :external "https://gitlab.com/koral/gcmh";)
@@ -120,10 +138,12 @@
("gnome-c-style" :external "https://github.com/ueno/gnome-c-style.git";)
("gnorb" :external nil) ;; Was "https://github.com/girzel/gnorb";
("gnu-elpa" :external nil)
+ ("gnu-elpa-keyring-update" :external nil)
("gnugo" :external nil)
("gnus-mock" :external nil)
("gpastel" :external
"https://gitlab.petton.fr/DamienCassou/gpastel";)
("greader" :external
"https://gitlab.com/michelangelo-rodriguez/greader";)
+ ("greenbar" :external nil)
("guess-language" :external
"https://github.com/tmalsburg/guess-language.el";)
("highlight-escape-sequences" :external
"https://github.com/dgutov/highlight-escape-sequences/";)
("hook-helpers" :external
"https://git.savannah.nongnu.org/git/hook-helpers-el.git";)
@@ -131,6 +151,7 @@
("hydra" :external "https://github.com/abo-abo/hydra";)
("hyperbole" :external
"http://git.savannah.gnu.org/r/hyperbole.git";)
("ioccur" :external
"https://github.com/thierryvolpiatto/ioccur.git";)
+ ("iterators" :external nil)
("ivy-explorer" :external "https://github.com/clemera/ivy-explorer";)
("ivy-posframe" :external "https://github.com/tumashu/ivy-posframe";)
("javaimp" :external nil)
@@ -138,8 +159,12 @@
("js2-mode" :external "https://github.com/mooz/js2-mode.git";)
("json-mode" :external nil)
("jsonrpc" :core "lisp/jsonrpc.el")
+ ("jumpc" :external nil)
+ ("kmb" :external nil)
+ ("landmark" :external nil)
("leaf" :external "https://github.com/conao3/leaf.el";)
("let-alist" :core "lisp/emacs-lisp/let-alist.el")
+ ("lex" :external nil)
("lmc" :external nil)
("load-dir" :external nil)
("load-relative" :external "http://github.com/rocky/emacs-load-relative";)
@@ -148,15 +173,19 @@
("map" :core "lisp/emacs-lisp/map.el")
("markchars" :external nil)
("math-symbol-lists" :external
"https://github.com/vspinu/math-symbol-lists.git";)
+ ("memory-usage" :external nil)
("metar" :external nil)
("midi-kbd" :external nil)
("mines" :external "https://github.com/calancha/Minesweeper";)
+ ("minibuffer-line" :external nil)
+ ("minimap" :external nil)
("mmm-mode" :external "https://github.com/purcell/mmm-mode.git";)
("modus-operandi-theme":external
"https://gitlab.com/protesilaos/modus-themes";)
("modus-vivendi-theme" :external
"https://gitlab.com/protesilaos/modus-themes";)
("multishell" :external
"https://github.com/kenmanheimer/EmacsMultishell";)
("muse" :external "https://github.com/alexott/muse";) ;FIXME:
Not nearly in-sync
("myers" :external nil)
+ ("nadvice" :external nil)
("nameless" :external "https://github.com/Malabarba/Nameless";)
("names" :external "http://github.com/Malabarba/names";)
("nhexl-mode" :external nil)
@@ -164,19 +193,25 @@
("notes-mode" :external nil)
("ntlm" :core "lisp/net/ntlm.el")
("num3-mode" :external nil)
+ ("oauth2" :external nil)
("objed" :external "https://github.com/clemera/objed";)
("omn-mode" :external nil)
("on-screen" :external
"https://github.com/michael-heerdegen/on-screen.el.git";)
;;FIXME:("org" :external ??) ;; Need to introduce snapshots!!
+ ("org-translate" :external nil)
("orgalist" :external nil)
("org-edna" :external
"https://savannah.nongnu.org/projects/org-edna-el";) ;URL?
+ ("other-frame-window" :external nil)
("paced" :external
"bzr::bzr://bzr.savannah.nongnu.org/paced-el/trunk")
("pabbrev" :external "https://github.com/phillord/pabbrev.git";)
+ ("package-fixes" :external nil)
("parsec" :external
"https://github.com/cute-jumper/parsec.el.git";)
+ ("path-iterator" :external nil)
("peg" :external) ;Was in
"https://github.com/ellerh/peg.el";
("persist" :external "https://gitlab.com/phillord/persist.git";)
("phps-mode" :external
"https://github.com/cjohansson/emacs-phps-mode";)
("pinentry" :external "https://github.com/ueno/pinentry-el.git";)
+ ("poker" :external nil)
("posframe" :external "https://github.com/tumashu/posframe";)
("prefixed-core" :external nil)
("project" :core "lisp/progmodes/project.el")
@@ -188,8 +223,11 @@
;; -- -- pspp-mode.el
("pspp-mode" :external nil) ;; Was
"https://git.sv.gnu.org/r/pspp.git";
("python" :core "lisp/progmodes/python.el")
+ ("quarter-plane" :external nil)
+ ("rainbow-mode" :external nil)
("rbit" :external nil)
("rcirc-color" :external nil)
+ ("rcirc-menu" :external nil)
("realgud" :external "https://github.com/realgud/realgud";)
("realgud-ipdb" :external "https://github.com/realgud/realgud-ipdb";)
("realgud-jdb" :external "https://github.com/realgud/jdb";)
@@ -205,29 +243,44 @@
("rt-liberation" :external "https://git.savannah.nongnu.org/git/rtliber";)
("rudel" :external nil) ;; Was
bzr::bzr://rudel.bzr.sourceforge.net/bzrroot/rudel/trunk
("scanner" :external "https://gitlab.com/rstocker/scanner.git";)
+ ("scroll-restore" :external nil)
+ ("sed-mode" :external nil)
+ ("seq" :external nil)
+ ("shelisp" :external nil)
("shell-command+" :external
"https://git.sr.ht/~zge/bang/tree/shell-command+";)
+ ("shell-quasiquote" :external nil)
("shen-mode" :external nil)
("sisu-mode" :external nil)
("slime-volleyball" :external nil)
("sm-c-mode" :external nil)
("smalltalk-mode" :external "git://git.sv.gnu.org/smalltalk")
+ ("smart-yank" :external nil)
("sml-mode" :external nil)
("so-long" :core "lisp/so-long.el")
("soap-client" :core ("lisp/net/soap-client.el"
"lisp/net/soap-inspect.el"))
+ ("sokoban" :external nil)
("sotlisp" :external
"https://github.com/Malabarba/speed-of-thought-lisp";)
("spinner" :external "https://github.com/Malabarba/spinner.el";)
+ ("sql-beeline" :external nil)
("sql-indent" :external
"https://github.com/alex-hhh/emacs-sql-indent";)
("sql-smie" :external nil)
("ssh-deploy" :external
"https://github.com/cjohansson/emacs-ssh-deploy";)
+ ("stream" :external nil)
("svg" :core ("lisp/svg.el"))
+ ("svg-clock" :external nil)
("swiper" :external "https://github.com/abo-abo/swiper";)
("system-packages" :external
"https://gitlab.com/jabranham/system-packages";)
+ ("systemd" :external nil)
("temp-buffer-browse" :external
"https://github.com/leoliu/temp-buffer-browse";)
("test-simple" :external "https://github.com/rocky/emacs-test-simple";)
("timerfunctions" :external nil)
+ ("tramp-theme" :external nil)
+ ("transcribe" :external nil)
("undo-tree" :external "http://www.dr-qubit.org/git/undo-tree.git";)
("uni-confusables" :external nil)
+ ("uniquify-files" :external nil)
("url-http-ntlm" :external nil)
+ ("validate" :external nil)
("vcard" :external nil)
("vdiff" :external "https://github.com/justbur/emacs-vdiff";)
("vcl-mode" :external "git://git.gnu.org.ua/vcl-mode")
@@ -236,6 +289,7 @@
("transient" :external "https://github.com/magit/transient";)
("vigenere" :external nil)
("visual-filename-abbrev" :external nil)
+ ("visual-fill" :external nil)
("vlf" :external "https://github.com/m00natic/vlfi";)
("verilog-mode" :core "lisp/progmodes/verilog-mode.el")
("wcheck-mode" :external
"https://github.com/tlikonen/wcheck-mode";)
diff --git a/packages/adjust-parens/Makefile b/packages/adjust-parens/Makefile
deleted file mode 100644
index d4e5b94..0000000
--- a/packages/adjust-parens/Makefile
+++ /dev/null
@@ -1,17 +0,0 @@
-.PHONY: all clean
-
-ELCFILES = $(addsuffix .elc, $(basename $(wildcard *.el)))
-
-all: $(ELCFILES)
-
-%.elc : %.el
- @echo Compiling $<
- @emacs --batch -q --no-site-file -L . -f batch-byte-compile $<
-
-clean:
- @rm -f *.elc
-
-# Don't depend on $(ELCFILES) so as failures may have a non byte compiled
backtrace
-check:
- @emacs --batch -q --no-site-file -L . -l adjust-parens-tests.el -f
ert-run-tests-batch-and-exit
-
diff --git a/packages/adjust-parens/adjust-parens-tests.el
b/packages/adjust-parens/adjust-parens-tests.el
deleted file mode 100644
index 9909d76..0000000
--- a/packages/adjust-parens/adjust-parens-tests.el
+++ /dev/null
@@ -1,107 +0,0 @@
-;;; adjust-parens-tests.el --- Tests of adjust-parens package
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(require 'ert)
-(require 'adjust-parens)
-
-(defun apt-check-buffer (text-before-point text-after-point)
- (should (string= text-before-point
- (buffer-substring-no-properties (point-min)
- (point))))
- (should (string= text-after-point
- (buffer-substring-no-properties (point)
- (point-max)))))
-
-(ert-deftest apt-mode-test ()
- (with-temp-buffer
- (emacs-lisp-mode)
- (adjust-parens-mode -1)
- (should-not (eq (key-binding (kbd "TAB"))
- #'lisp-indent-adjust-parens))
- (adjust-parens-mode 1)
- (should (eq (key-binding (kbd "TAB"))
- #'lisp-indent-adjust-parens))
- (adjust-parens-mode -1)
- (should-not (eq (key-binding (kbd "TAB"))
- #'lisp-indent-adjust-parens))))
-
-(ert-deftest apt-near-bob-test ()
- (with-temp-buffer
- (emacs-lisp-mode)
- (adjust-parens-mode 1)
- (insert "(foo)\n")
- (lisp-indent-adjust-parens)
- (apt-check-buffer "(foo\n " ")")))
-
-(ert-deftest apt-indent-dedent-test ()
- (with-temp-buffer
- (emacs-lisp-mode)
- (adjust-parens-mode 1)
- (setq indent-tabs-mode nil)
- (insert ";;\n"
- "(let ((x 10) (y (some-func 20))))\n"
- "; Comment")
- (back-to-indentation)
- (lisp-indent-adjust-parens)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20)))\n"
- " ")
- "); Comment")
- (lisp-indent-adjust-parens 3)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20\n"
- " ")
- ")))); Comment")
- (lisp-dedent-adjust-parens 2)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20))\n"
- " ")
- ")); Comment")
- ;; Check what happens when point is not at the indentation, or
- ;; indentation is not correct, or both
- (beginning-of-line) ; Point not at indentation
- ;; Should simply move point to indentation and not change buffer
- (lisp-indent-adjust-parens)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20))\n"
- " ")
- ")); Comment")
-
- (delete-backward-char 3) ; Incorrect indentation
- ;; Should reindent line via indent-for-tab-command and move point to
- ;; indentation but not change parens
- (lisp-indent-adjust-parens)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20))\n"
- " ")
- ")); Comment")
- (insert " ") ; Wrong indentation
- (forward-char 2) ; Point is past indentation
- ;; Should reindent line without moving point or changing parens
- (lisp-indent-adjust-parens)
- (apt-check-buffer (concat ";;\n"
- "(let ((x 10) (y (some-func 20))\n"
- " ))")
- "; Comment")))
-
-;;; adjust-parens-tests.el ends here
diff --git a/packages/adjust-parens/adjust-parens.el
b/packages/adjust-parens/adjust-parens.el
deleted file mode 100644
index 183925d..0000000
--- a/packages/adjust-parens/adjust-parens.el
+++ /dev/null
@@ -1,353 +0,0 @@
-;;; adjust-parens.el --- Indent and dedent Lisp code, automatically adjust
close parens -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
-;; Version: 3.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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This package provides commands for indenting and dedenting Lisp
-;; code such that close parentheses and brackets are automatically
-;; adjusted to be consistent with the new level of indentation.
-;;
-;; When reading Lisp, the programmer pays attention to open parens and
-;; the close parens on the same line. But when a sexp spans more than
-;; one line, she deduces the close paren from indentation alone. Given
-;; that's how we read Lisp, this package aims to enable editing Lisp
-;; similarly: automatically adjust the close parens programmers ignore
-;; when reading. A result of this is an editing experience somewhat
-;; like python-mode, which also offers "indent" and "dedent" commands.
-;; There are differences because lisp-mode knows more due to existing
-;; parens.
-;;
-;; To use:
-;; (require 'adjust-parens)
-;; (add-hook 'emacs-lisp-mode-hook #'adjust-parens-mode)
-;; (add-hook 'clojure-mode-hook #'adjust-parens-mode)
-;; ;; etc
-;;
-;; This binds two keys in Lisp Mode:
-;; (local-set-key (kbd "TAB") 'lisp-indent-adjust-parens)
-;; (local-set-key (kbd "<backtab>") 'lisp-dedent-adjust-parens)
-;;
-;; lisp-indent-adjust-parens potentially calls indent-for-tab-command
-;; (the usual binding for TAB in Lisp Mode). Thus it should not
-;; interfere with other TAB features like completion-at-point.
-;;
-;; Some examples follow. | indicates the position of point.
-;;
-;; (let ((x 10) (y (some-func 20))))
-;; |
-;;
-;; After one TAB:
-;;
-;; (let ((x 10) (y (some-func 20)))
-;; |)
-;;
-;; After three more TAB:
-;;
-;; (let ((x 10) (y (some-func 20
-;; |))))
-;;
-;; After two Shift-TAB to dedent:
-;;
-;; (let ((x 10) (y (some-func 20))
-;; |))
-;;
-;; When dedenting, the sexp may have sibling sexps on lines below. It
-;; makes little sense for those sexps to stay at the same indentation,
-;; because they cannot keep the same parent sexp without being moved
-;; completely. Thus they are dedented too. An example of this:
-;;
-;; (defun func ()
-;; (save-excursion
-;; (other-func-1)
-;; |(other-func-2)
-;; (other-func-3)))
-;;
-;; After Shift-TAB:
-;;
-;; (defun func ()
-;; (save-excursion
-;; (other-func-1))
-;; |(other-func-2)
-;; (other-func-3))
-;;
-;; If you indent again with TAB, the sexps siblings aren't indented:
-;;
-;; (defun func ()
-;; (save-excursion
-;; (other-func-1)
-;; |(other-func-2))
-;; (other-func-3))
-;;
-;; Thus TAB and Shift-TAB are not exact inverse operations of each
-;; other, though they often seem to be.
-
-;;; Code:
-
-;; Future work:
-;; - Consider taking a region as input in order to indent a sexp and
-;; its siblings in the region. Dedenting would not take a region.
-
-(require 'cl-lib)
-
-(defun last-sexp-with-relative-depth (from-pos to-pos rel-depth)
- "Parsing sexps from FROM-POS (inclusive) to TO-POS (exclusive),
-return the position of the last sexp that had depth REL-DEPTH relative
-to FROM-POS. Returns nil if REL-DEPTH is not reached.
-
-May change point.
-
-Examples:
- Region: a (b c (d)) e (f g (h i)) j
-
- Evaluate: (last-sexp-with-relative-depth pos-a (1+ pos-j) 0)
- Returns: position of j
-
- Evaluate: (last-sexp-with-relative-depth pos-a (1+ pos-j) 1)
- Returns: position of (h i)
-
-This function assumes FROM-POS is not in a string or comment."
- (goto-char from-pos)
- (let (the-last-pos
- (parse-state '(0 nil nil nil nil nil nil nil nil)))
- (while (< (point) to-pos)
- (setq parse-state
- (parse-partial-sexp (point)
- to-pos
- nil
- t ; Stop before sexp
- parse-state))
- (and (not (eq (point) to-pos))
- (eq (car parse-state) rel-depth)
- (setq the-last-pos (point)))
- ;; The previous parse may not advance. To advance and maintain
- ;; correctness of depth, we parse over the next char.
- (when (< (point) to-pos)
- (setq parse-state
- (parse-partial-sexp (point)
- (1+ (point))
- nil
- nil
- parse-state))))
- the-last-pos))
-
-
-(defun adjust-parens-check-prior-sexp ()
- "Returns true if there is a full sexp before point, else false.
-
-May change point."
- (let ((pos1 (progn (backward-sexp)
- (point)))
- (pos2 (progn (forward-sexp)
- (backward-sexp)
- (point))))
- (>= pos1 pos2)))
-
-(defun adjust-close-paren-for-indent ()
- "Adjust a close parentheses of a sexp so as
-lisp-indent-adjust-parens can indent that many levels.
-
-If a close paren was moved, returns a two element list of positions:
-where the close paren was moved from and the position following where
-it moved to.
-
-If there's no close parens to move, either return nil or allow
-scan-error to propogate up."
- (save-excursion
- (let* ((deleted-paren-char nil)
- (deleted-paren-pos
- (save-excursion
- (beginning-of-line)
- ;; Account for edge case when point has no sexp before it
- ;;
- ;; This is primarily to avoid funny behavior when there
- ;; is no sexp between bob and point.
- (if (not (adjust-parens-check-prior-sexp))
- nil
- ;; If the sexp at point is a list,
- ;; delete its closing paren
- (when (eq (scan-lists (point) 1 0)
- (scan-sexps (point) 1))
- (forward-sexp)
- (setq deleted-paren-char (char-before))
- (delete-char -1)
- (point))))))
- ;; Invariant: deleted-paren-pos nil iff deleted-paren-char nil
- (when deleted-paren-pos
- (let ((sexp-to-close
- (save-excursion
- (last-sexp-with-relative-depth (point)
- (progn (end-of-line)
- (point))
- 0))))
- (when sexp-to-close
- (goto-char sexp-to-close)
- (forward-sexp))
- ;; Note: when no sexp-to-close found, line is empty. So put
- ;; close paren after point.
- (insert deleted-paren-char)
- (list deleted-paren-pos (point)))))))
-
-(defun adjust-close-paren-for-dedent ()
- "Adjust a close parentheses of a sexp so as
-lisp-dedent-adjust-parens can dedent that many levels.
-
-If a close paren was moved, returns a two element list of positions:
-where the close paren was moved from and the position following where
-it moved to.
-
-If there's no close parens to move, either return nil or allow
-scan-error to propogate up."
- (save-excursion
- (let* ((deleted-paren-char nil)
- (deleted-paren-pos
- (save-excursion
- (when (< (point)
- (progn (up-list)
- (point)))
- (setq deleted-paren-char (char-before))
- (delete-char -1)
- (point)))))
- ;; Invariant: deleted-paren-pos nil iff deleted-paren-char nil
- (when deleted-paren-pos
- (let ((sexp-to-close
- ;; Needs to work when dedenting in an empty list, in
- ;; which case backward-sexp will signal scan-error and
- ;; sexp-to-close will be nil.
- (condition-case nil
- (progn (backward-sexp)
- (point))
- (scan-error nil))))
- ;; Move point to where to insert close paren
- (if sexp-to-close
- (forward-sexp)
- (backward-up-list)
- (forward-char 1))
- (insert deleted-paren-char)
- ;; The insertion makes deleted-paren-pos off by 1
- (list (1+ deleted-paren-pos)
- (point)))))))
-
-(defun adjust-parens-p ()
- "Whether to adjust parens."
- (save-excursion
- (let ((orig-pos (point)))
- (back-to-indentation)
- (and (= orig-pos (point))
- (not (use-region-p))
- ;; Current line indented?
- (let ((indent (calculate-lisp-indent)))
- (and indent
- (= (current-column)
- (if (listp indent)
- (car indent)
- indent))))))))
-
-(defun adjust-parens-and-indent (raw-parg
- adjust-function
- adjust-function-negative
- fallback-function)
- "Adjust close parens and indent the region over which the parens
-moved."
- (if (adjust-parens-p)
- (let* ((parg (prefix-numeric-value raw-parg))
- (adjust-function (if (and parg (< parg 0))
- adjust-function-negative
- adjust-function))
- (region-of-change (list (point) (point))))
- (cl-loop for i from 1 to (or (and parg (abs parg)) 1)
- with finished = nil
- while (not finished)
- do
- (condition-case err
- (let ((close-paren-movement
- (funcall adjust-function)))
- (if close-paren-movement
- (setq region-of-change
- (list (min (car region-of-change)
- (car close-paren-movement)
- (cadr close-paren-movement))
- (max (cadr region-of-change)
- (car close-paren-movement)
- (cadr close-paren-movement))))
- (setq finished t)))
- (scan-error (setq finished err))))
- (apply 'indent-region region-of-change)
- (back-to-indentation)
- t)
- (funcall fallback-function raw-parg)))
-
-(defcustom adjust-parens-fallback-indent-function 'indent-for-tab-command
- "The function to call with prefix arg instead of
-adjust-parens-and-indent when adjust-parens-p returns false."
- :type 'function
- :group 'adjust-parens)
-(defun lisp-indent-adjust-parens (&optional raw-parg)
- "Indent Lisp code to the next level while adjusting sexp balanced
-expressions to be consistent.
-
-Returns t if adjust-parens changed the buffer, else returns the
-result of calling adjust-parens-fallback-indent-function.
-
-This command can be bound to TAB instead of indent-for-tab-command. It
-potentially calls the latter."
- (interactive "P")
- (adjust-parens-and-indent raw-parg
- #'adjust-close-paren-for-indent
- #'adjust-close-paren-for-dedent
- adjust-parens-fallback-indent-function))
-
-(defcustom adjust-parens-fallback-dedent-function 'indent-for-tab-command
- "The function to call with prefix arg instead of
-adjust-parens-and-indent when adjust-parens-p returns false."
- :type 'function
- :group 'adjust-parens)
-(defun lisp-dedent-adjust-parens (&optional raw-parg)
- "Dedent Lisp code to the previous level while adjusting sexp
-balanced expressions to be consistent.
-
-Returns t if adjust-parens changed the buffer, else returns the
-result of calling adjust-parens-fallback-dedent-function.
-
-Binding to <backtab> (ie Shift-Tab) is a sensible choice."
- (interactive "P")
- (adjust-parens-and-indent raw-parg
- #'adjust-close-paren-for-dedent
- #'adjust-close-paren-for-indent
- adjust-parens-fallback-dedent-function))
-
-(defgroup adjust-parens nil
- "Indent and dedent Lisp code, automatically adjust close parens."
- :prefix "adjust-parens-"
- :group 'convenience)
-
-(defvar adjust-parens-mode-map (make-sparse-keymap)
- "Keymap for `adjust-parens-mode'")
-(define-key adjust-parens-mode-map (kbd "TAB") 'lisp-indent-adjust-parens)
-(define-key adjust-parens-mode-map (kbd "<backtab>")
'lisp-dedent-adjust-parens)
-
-;;;###autoload
-(define-minor-mode adjust-parens-mode
- "Indent and dedent Lisp code, automatically adjust close parens."
- :group 'adjust-parens
- :keymap adjust-parens-mode-map)
-
-(provide 'adjust-parens)
-
-;;; adjust-parens.el ends here
diff --git a/packages/all/all.el b/packages/all/all.el
deleted file mode 100644
index 845b85a..0000000
--- a/packages/all/all.el
+++ /dev/null
@@ -1,203 +0,0 @@
-;;; all.el --- Edit all lines matching a given regexp
-
-;; Copyright (C) 1985-1987,1992,1994,2011-2012 Free Software Foundation, Inc.
-
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Version: 1.0
-;; Keywords: matching
-
-;; LCD Archive Entry:
-;; all|Per Abrahamsen|abraham@dina.kvl.dk|
-;; Edit all lines matching a given regexp|
-;; $Date: 1997/03/04 10:29:42 $|$Revision: 5.2 $|~/misc/all.Z|
-
-;; 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, 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Just like occur, except that changes in the *All* buffer are
-;; propagated to the original buffer.
-
-;; You can no longer use mouse-2 to find a match in the original file,
-;; since the default definition of mouse is too useful.
-;; However, `C-c C-c' still works.
-
-;; Line numbers are not listed in the *All* buffer.
-
-;; Ok, it is _not_ just like occur.
-
-;; Some limitations:
-
-;; - Undo in the *All* buffer is an ordinary change in the original.
-;; - Changes to the original buffer are not reflected in the *All* buffer.
-;; - A single change in the *All* buffer must be limited to a single match.
-
-;;; Code:
-
-(defvar all-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'all-mode-goto)
- map))
-
-(defvar all-buffer nil)
-(make-variable-buffer-local 'all-buffer)
-
-(define-derived-mode all-mode fundamental-mode "All"
- "Major mode for output from \\[all].
-
-All changes made in this buffer will be propagated to the buffer where
-you ran \\[all].
-
-Press \\[all-mode-goto] to go to the same spot in the original buffer."
- (add-hook 'before-change-functions 'all-before-change-function nil 'local)
- (add-hook 'after-change-functions 'all-after-change-function nil 'local))
-
-(defun all-mode-find (pos)
- ;; Find position in original buffer corresponding to POS.
- (let ((overlay (all-mode-find-overlay pos)))
- (if overlay
- (+ (marker-position (overlay-get overlay 'all-marker))
- (- pos (overlay-start overlay))))))
-
-(defun all-mode-find-overlay (pos)
- ;; Find the overlay containing POS.
- (let ((overlays (overlays-at pos)))
- (while (and overlays (null (overlay-get (car overlays) 'all-marker)))
- (setq overlays (cdr overlays)))
- (car-safe overlays)))
-
-(defun all-mode-goto ()
- "Move point to the corresponding position in the original buffer."
- (interactive)
- (let ((pos (all-mode-find (point))))
- (if pos
- (pop-to-buffer all-buffer)
- (error "This text is not from the original buffer"))
- (goto-char pos)))
-
-(defvar all-initialization-p nil)
-
-(defun all-before-change-function (from to)
- ;; Check that change is legal.
- (and all-buffer
- (not all-initialization-p)
- (let ((start (all-mode-find-overlay from))
- (end (all-mode-find-overlay to)))
- (not (and start (eq start end))))
- (error "Changes should be limited to a single text piece")))
-
-(defun all-after-change-function (from to length)
- ;; Propagate changes from *All* buffer.
- (and all-buffer
- (null all-initialization-p)
- (let ((buffer (current-buffer))
- (pos (all-mode-find from)))
- (if pos
- (with-current-buffer all-buffer
- (save-excursion
- (goto-char pos)
- (delete-region pos (+ pos length))
- (insert-buffer-substring buffer from to)))))))
-
-;;;###autoload
-(defun all (regexp &optional nlines)
- "Show all lines in the current buffer containing a match for REGEXP.
-
-If a match spreads across multiple lines, all those lines are shown.
-
-Each line is displayed with NLINES lines before and after, or -NLINES
-before if NLINES is negative.
-NLINES defaults to `list-matching-lines-default-context-lines'.
-Interactively it is the prefix arg.
-
-The lines are shown in a buffer named `*All*'.
-Any changes made in that buffer will be propagated to this buffer."
- (interactive
- (list (let* ((default (car regexp-history)))
- (read-string
- (if default
- (format
- "Edit lines matching regexp (default `%s'): " default)
- "Edit lines matching regexp: ")
- nil 'regexp-history default))
- current-prefix-arg))
- (setq nlines (if nlines (prefix-numeric-value nlines)
- list-matching-lines-default-context-lines))
- (let ((all-initialization-p t)
- (buffer (current-buffer))
- (prevend nil)
- (prevstart nil)
- (prevpos (point-min)))
- (with-output-to-temp-buffer "*All*"
- (with-current-buffer standard-output
- (all-mode)
- (setq all-buffer buffer)
- (insert "Lines matching ")
- (prin1 regexp)
- (insert " in buffer " (buffer-name buffer) ?. ?\n)
- (insert "--------\n"))
- (if (eq buffer standard-output)
- (goto-char (point-max)))
- (save-excursion
- (goto-char (point-min))
- ;; Find next match, but give up if prev match was at end of buffer.
- (while (and (not (= prevpos (point-max)))
- (re-search-forward regexp nil t))
- (goto-char (match-beginning 0))
- (beginning-of-line)
- (setq prevpos (point))
- (goto-char (match-end 0))
- (let* ((start (save-excursion
- (goto-char (match-beginning 0))
- (forward-line (if (< nlines 0) nlines (- nlines)))
- (point)))
- (end (save-excursion
- (goto-char (match-end 0))
- (if (> nlines 0)
- (forward-line (1+ nlines))
- (forward-line 1))
- (point))))
- (cond ((null prevend)
- (setq prevstart start
- prevend end))
- ((> start prevend)
- (all-insert prevstart prevend regexp nlines)
- (setq prevstart start
- prevend end))
- (t
- (setq prevend end)))))
- (if prevend
- (all-insert prevstart prevend regexp nlines))))))
-
-(defun all-insert (start end regexp nlines)
- ;; Insert match.
- (let ((marker (copy-marker start))
- (buffer (current-buffer)))
- (with-current-buffer standard-output
- (let ((from (point))
- to)
- (insert-buffer-substring buffer start end)
- (setq to (point))
- (overlay-put (make-overlay from to) 'all-marker marker)
- (goto-char from)
- (while (re-search-forward regexp to t)
- (put-text-property (match-beginning 0) (match-end 0)
- 'face 'match))
- (goto-char to)
- (if (> nlines 0)
- (insert "--------\n"))))))
-
-(provide 'all)
-
-;;; all.el ends here
diff --git a/packages/auto-correct/auto-correct.el
b/packages/auto-correct/auto-correct.el
deleted file mode 100644
index 528dad2..0000000
--- a/packages/auto-correct/auto-correct.el
+++ /dev/null
@@ -1,415 +0,0 @@
-;;; auto-correct.el --- Remembers and automatically fixes past corrections -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
-
-;; Author: Ian Dunn <dunni@gnu.org>
-;; Maintainer: Ian Dunn <dunni@gnu.org>
-;; Keywords: editing
-;; Version: 1.1.4
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; To enable, use:
-
-;; M-x `auto-correct-mode'
-
-;; After that, any future corrections made with flyspell or Ispell (or any
other
-;; supported package) will be automatically corrected for you as you type.
-
-;; For example, if you type "befroe" and fixed it with `ispell-word',
-;; `auto-correct-mode' will change "befroe" to "before" every time you type it
-;; from then on.
-
-;; Corrections are only made when `auto-correct-mode' is enabled. Expansion is
-;; case-insensitive, so trying to fix alice as Alice won't work. Use the
-;; captain package for this instead.
-
-;; Auto-correct is controlled further by `auto-correct-predicate'. In order to
-;; enable auto-correct in a given buffer, the function to which
-;; `auto-correct-predicate' is set must return true at the current point.
-
-;; For example, the following will tell auto-correct to only correct mistakes
in
-;; a programming mode buffer that fall within a comment:
-
-;; (add-hook 'prog-mode-hook
-;; (lambda ()
-;; (setq auto-correct-predicate (lambda () (nth 8 (syntax-ppss
(point)))))))
-
-;; Or for text modes, work all the time:
-
-;; (add-hook 'text-mode-hook
-;; (lambda ()
-;; (setq auto-correct-predicate (lambda () t))))
-
-;; Or don't work in source blocks in Org mode:
-
-;; (add-hook
-;; 'org-mode-hook
-;; (lambda ()
-;; (setq auto-correct-predicate
-;; (lambda () (not (org-in-src-block-p))))))
-
-;; Behind the scenes, auto-correct uses an abbrev table, so in order to clean
-;; out or modify any fixes auto-correct has learned, use `list-abbrevs'. This
-;; also means that fixes are saved between Emacs sessions along with the abbrev
-;; tables.
-
-;; Ispell and flyspell are the only two packages that auto-correct supports out
-;; of the box, but it's possible to add support for any package that corrects
-;; text:
-
-;; 1. Create a function that calls `auto-correct--add-or-update-correction'
with
-;; the old text and the corrected text from your package.
-
-;; 2. Write a function to activate and deactivate support for your package. It
-;; should take a single argument, which is a boolean indicating whether to
-;; activate or deactivate support.
-
-;; 3. Call `auto-correct-handle-support', passing t as the first argument and
-;; your function as the second. To disable support, pass nil as the first
-;; argument instead.
-
-;; 4. You're done.
-
-;;; Code:
-
-(eval-when-compile (require 'subr-x))
-(require 'thingatpt)
-
-(defgroup auto-correct nil
- "Auto correction support."
- :prefix "auto-correct-"
- :group 'editing)
-
-;; Core Functionality
-
-(defun auto-correct--default-predicate ()
- "The default predicate for determining whether auto-correct should run.
-
-Disabled by default."
- nil)
-
-(defvar-local auto-correct-predicate #'auto-correct--default-predicate
- "Predicate to check whether automatic corrections should be made.
-
-This should be a function of no arguments that returns non-nil if
-auto-correct should operate on the current text.
-
-This is buffer-local so it can be set to a value that works best
-with each different mode.
-
-This is `auto-correct--default-predicate' by default, which keeps
-auto-correct disabled. This is to prevent auto-correct from
-happening all the time.")
-
-(defun auto-correct-expand-p ()
- "Return non-nil if auto-correct should operate on the current point.
-
-To customize this behavior, set `auto-correct-predicate'."
- (funcall auto-correct-predicate))
-
-(define-abbrev-table 'auto-correct-abbrev-table nil
- "Abbrev table where automatic corrections are stored."
- :enable-function #'auto-correct-expand-p)
-
-(defun auto-correct--get-abbrev-table (local)
- "Get the abbrev table to use with auto-correct.
-
-If LOCAL is non-nil, use the local table if it exists.
-Otherwise, use auto-correct's abbrev table."
- (if local
- (or local-abbrev-table auto-correct-abbrev-table)
- auto-correct-abbrev-table))
-
-(defun auto-correct--add-or-update-correction (before after &optional local)
- "Add or update a correction into auto-correct's table.
-
-BEFORE is the misspelled word, and AFTER is the correct spelling.
-
-Optional argument LOCAL determines whether to make the correction
-locally. If nil, the correction will be made whenever
-`auto-correct-mode' is enabled."
- (let ((table (auto-correct--get-abbrev-table local))
- (bef (downcase before))
- (aft (downcase after)))
- (define-abbrev table bef aft nil :count 1)
- ;; Save the abbrevs.
- (write-abbrev-file)
- (message "\"%s\" now expands to \"%s\"" bef aft)))
-
-;; The mode
-
-;;;###autoload
-(define-minor-mode auto-correct-mode
- "Activate automatic corrections.
-
-Auto correct expansions will only work when this mode is enabled,
-but auto-correct can be trained with `auto-correct-fix-and-add'
-even if this mode is disabled.
-
-When this mode is enabled, corrections made with flyspell and
-Ispell will be made automatically after fixing them once.
-
-In order to add corrections to the auto-correct abbrev table in
-flyspell (and thus have them corrected later), set
-`flyspell-use-global-abbrev-table-p' to non-nil.
-
-In order to set corrections as local using Ispell, use
-the command `auto-correct-toggle-ispell-local'.
-
-\\{auto-correct-mode-map}"
- :group 'auto-correct
- :global t
- :init-value nil
- :lighter " Auto-Correct")
-
-;; Only enable the abbrev list when auto-correct-mode is active.
-(add-to-list 'abbrev-minor-mode-table-alist
- `(auto-correct-mode ,auto-correct-abbrev-table)
- 'append
- #'equal)
-
-(defsubst auto-correct--support-function (base-function)
- "Return a function that calls BASE-FUNCTION with `auto-correct-mode' as its
argument."
- `(lambda ()
- (funcall (quote ,base-function) auto-correct-mode)))
-
-(defun auto-correct-handle-support (activate support-fun)
- "Helper function to add or remove auto-correct support for a package.
-
-If ACTIVATE is non-nil, add support, otherwise remove it.
-SUPPORT-FUN is a function that takes a single argument: a boolean
-indicating whether to activate or deactivate support."
- (if activate
- (add-hook 'auto-correct-mode-hook (auto-correct--support-function
support-fun))
- (remove-hook 'auto-correct-mode-hook (auto-correct--support-function
support-fun)))
- ;; If `auto-correct-mode' is enabled, activate or deactivate support.
- (when auto-correct-mode
- (funcall support-fun activate)))
-
-;; Flyspell Support
-
-(defvar-local auto-correct--flyspell-old-word nil)
-
-(defvar flyspell-auto-correct-word)
-(defvar flyspell-use-global-abbrev-table-p)
-(defvar flyspell-insert-function)
-
-(defun auto-correct--flyspell-do-correct-wrapper (oldfun replace poss word
cursor-location start end save)
- "Wraps `flyspell-do-correct' to store the word it's correcting."
- (let ((auto-correct--flyspell-old-word word))
- (funcall oldfun replace poss word cursor-location start end save)))
-
-(defun auto-correct-flyspell-insert (word)
- "Insert WORD and add it as a correction.
-
-The original (misspelled) word is drawn from the variable
-`flyspell-auto-correct-word' (if coming from
-`flyspell-auto-correct-word') or `auto-correct--flyspell-old-word'
-if coming from `flyspell-do-correct'.
-
-When `auto-correct-mode' is enabled, this function is set as
-`flyspell-insert-function'."
- ;; If coming from `flyspell-auto-correct-word' (the function), use
- ;; `flyspell-auto-correct-word' (the variable) for the old word. Otherwise,
- ;; we're coming from `flyspell-do-correct', so use our stored old word.
- (let ((old-word (or flyspell-auto-correct-word
- auto-correct--flyspell-old-word))
- (new-word word)
- (local (not flyspell-use-global-abbrev-table-p)))
- (auto-correct--add-or-update-correction old-word new-word local)))
-
-(defun auto-correct--activate-flyspell-support (activate)
- "Activate or deactivate auto-correct support for flyspell.
-
-If ACTIVATE is non-nil, activate support for flyspell.
-Otherwise, deactivate it.
-
-Activation means adding `auto-correct-flyspell-insert' to
-`flyspell-insert-function'."
- (if activate
- (progn
- (advice-add 'flyspell-do-correct :around
- #'auto-correct--flyspell-do-correct-wrapper)
- (add-function :before flyspell-insert-function
- #'auto-correct-flyspell-insert))
- (remove-function flyspell-insert-function #'auto-correct-flyspell-insert)
- (advice-remove 'flyspell-do-correct
#'auto-correct--flyspell-do-correct-wrapper)))
-
-;; Silence the byte-compiler; this will be enabled shortly
-(defvar auto-correct-enable-flyspell-support)
-
-(defun auto-correct-defer-flyspell-support ()
- ;; Don't fully activate flyspell support until after it's loaded.
- (with-eval-after-load 'flyspell
- (auto-correct-handle-support
- auto-correct-enable-flyspell-support
- 'auto-correct--activate-flyspell-support)))
-
-(defun auto-correct-set-enable-flyspell-support (sym val)
- (set sym val)
- (auto-correct-defer-flyspell-support))
-
-(defcustom auto-correct-enable-flyspell-support t
- "Whether to automatically correct corrections made in flyspell.
-
-Support will not be enabled until after flyspell has been loaded.
-
-Use the following to set this manually to NEW-VALUE:
-
-(setq auto-correct-enable-flyspell-support NEW-VALUE)
-(auto-correct-defer-flyspell-support)"
- :group 'auto-correct
- :type 'boolean
- :set 'auto-correct-set-enable-flyspell-support)
-
-;; Ispell support
-
-(defvar ispell-following-word)
-
-(defvar auto-correct--ispell-use-local-table nil
- "Whether to use the local table with Ispell.
-
-Toggle this interactively with `auto-correct-toggle-ispell-local'.")
-
-(defun auto-correct-toggle-ispell-local ()
- "Toggle whether to use the local or auto-correct table for Ispell."
- (interactive)
- (setq auto-correct--ispell-use-local-table
- (not auto-correct--ispell-use-local-table))
- (message "Auto-Correct is now using the %s table"
- (if auto-correct--ispell-use-local-table "local" "global")))
-
-(defun auto-correct--ispell-handler (ispell-result)
- "Add ISPELL-RESULT as a correction.
-
-The original (misspelled) word is drawn from the function
-`word-at-point'.
-
-This is intended to be added as advice to `ispell-command-loop'."
- (when-let ((word-before (word-at-point))
- (correction ispell-result))
- (when (and correction (consp correction))
- ;; The correction was entered by hand.
- (setq correction (car correction)))
- (if (and (not (or (eq correction 0) ;; Word was corrected from list
- (eq correction 'quit))) ;; Session was exited
- (not (equal word-before correction))) ;; Word was corrected
- (auto-correct--add-or-update-correction word-before correction
-
auto-correct--ispell-use-local-table)))
- ispell-result)
-
-(defun auto-correct--activate-ispell-support (activate)
- "Activate or deactivate Ispell auto-correct support.
-
-If ACTIVATE is non-nil, activate support for Ispell. Otherwise,
-deactivate it.
-
-Activating means adding advice to `ispell-command-loop' that adds
-the result as a correction."
- (if activate
- (advice-add 'ispell-command-loop :filter-return
- #'auto-correct--ispell-handler)
- (advice-remove 'ispell-command-loop #'auto-correct--ispell-handler)))
-
-;; We don't defer ispell support because adding advice will work even if the
-;; feature hasn't been loaded yet.
-
-(defcustom auto-correct-enable-ispell-support t
- "Whether to automatically correct corrections made in Ispell."
- :group 'auto-correct
- :type 'boolean
- :set (lambda (sym val)
- (set sym val)
- (auto-correct-handle-support
- val
- 'auto-correct--activate-ispell-support)))
-
-;; Standalone (piggybacks on Ispell)
-
-;;;###autoload
-(defun auto-correct-fix-and-add (local)
- "Use `ispell-word' to fix a misspelled word at point.
-
-Once the misspelled word is fixed, auto-correct will remember the
-fix and auto-correct it from then on, so long as
-`auto-correct-mode' is enabled.
-
-With a non-nil argument LOCAL (interactively, the prefix argument),
-create a fix for the typo that will be auto-corrected for buffers
-using the current local mode.
-
-This is pointless to use when `auto-correct-mode' is enabled;
-instead, use `ispell-word' and `auto-correct-toggle-ispell-local'
-to use the local abbrev table."
- (interactive "P")
- (let ((auto-correct--ispell-use-local-table local))
- (auto-correct--ispell-handler (ispell-word ispell-following-word
'quietly))))
-
-;;;###autoload
-(defun auto-correct-scan-buffer ()
- "Scan current buffer for misspelled words.
-
-When a misspelled word is found, offer to correct the misspelled
-word and auto-correct the typo in the future.
-
-When `auto-correct-mode' is enabled, use the `ispell' command
-instead."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- ;; Stop from being prompted to save the personal dictionary after every
- ;; change.
- (cl-letf (((symbol-function 'ispell-pdict-save) #'ignore))
- (while (forward-word)
- (auto-correct-fix-and-add nil)))
- (ispell-pdict-save)))
-
-;;;###autoload
-(defun auto-correct-scan-region (start end)
- "Scan the region between START and END for misspelled words.
-
-Interactively, START and END are the current region.
-
-When a misspelled word is found, offer to correct the misspelled
-word and auto-correct the typo in the future.
-
-When `auto-correct-mode' is enabled, use the `ispell' command
-instead."
- (interactive "r")
- (save-restriction
- (narrow-to-region start end)
- (auto-correct-scan-buffer)))
-
-;;;###autoload
-(defun auto-correct-scan ()
- "Scan the buffer or region for misspelled words.
-
-When a misspelled word is found, offer to correct the misspelled
-word and auto-correct the typo in the future.
-
-When `auto-correct-mode' is enabled, use the `ispell' command
-instead."
- (interactive)
- (if (region-active-p)
- (auto-correct-scan-region (region-beginning) (region-end))
- (auto-correct-scan-buffer)))
-
-(provide 'auto-correct)
-
-;;; auto-correct.el ends here
diff --git a/packages/caps-lock/caps-lock.el b/packages/caps-lock/caps-lock.el
deleted file mode 100644
index 24729a4..0000000
--- a/packages/caps-lock/caps-lock.el
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; caps-lock.el --- Caps-lock as a minor mode -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Version: 1.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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(defvar caps-lock-commands
- '(self-insert-command isearch-printing-char)
- "List of commands that are subject to `caps-lock-mode'.")
-
-;;;###autoload
-(define-minor-mode caps-lock-mode
- "Make self-inserting keys invert the capitalization."
- :global t
- (if caps-lock-mode
- (add-hook 'pre-command-hook #'caps-lock--pch)
- (remove-hook 'pre-command-hook #'caps-lock--pch)))
-
-(defun caps-lock--pch ()
- (when (and (characterp last-command-event)
- (or (memq this-command caps-lock-commands)
- (eq this-command (key-binding [remap self-insert-command]))))
- (setq last-command-event
- (condition-case nil
- (let ((up (upcase last-command-event)))
- (if (eq up last-command-event)
- (downcase last-command-event)
- up))
- (error last-command-event)))))
-
-(provide 'caps-lock)
-;;; caps-lock.el ends here
diff --git a/packages/captain/captain.el b/packages/captain/captain.el
deleted file mode 100644
index 5f8d205..0000000
--- a/packages/captain/captain.el
+++ /dev/null
@@ -1,229 +0,0 @@
-;;; captain.el --- CAPiTalization is Automatic IN emacs -*- lexical-binding:
t; -*-
-
-;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
-
-;; Author: Ian Dunn <dunni@gnu.org>
-;; Maintainer: Ian Dunn <dunni@gnu.org>
-;; Keywords: editing
-;; Version: 1.0.3
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The captain handles capitalizing text as you type, freeing you to do other
-;; things.
-
-;; Invoke the captain across the globe with `global-captain-mode', or just on
-;; one ship (buffer) at a time with `captain-mode'.
-
-;; For normal people:
-
-;; Automatically capitalizes the first word of a sentence as you type. The
-;; bounds of a sentence are determined by local variable
-;; `captain-sentence-start-function'. For example, you can set it to find the
-;; start of a list or heading in `org-mode'.
-
-;; In order to get the captain to start working, `captain-predicate' must be
-;; set. Otherwise, the slacker will just lie around all day doing nothing.
-
-;; The following will tell the captain to only work on comments in programming
-;; modes:
-
-;; (add-hook 'prog-mode-hook
-;; (lambda ()
-;; (setq captain-predicate (lambda () (nth 8 (syntax-ppss (point)))))))
-
-;; Or for text modes, work all the time:
-
-;; (add-hook 'text-mode-hook
-;; (lambda ()
-;; (setq captain-predicate (lambda () t))))
-
-;; Or don't work in source blocks in Org mode:
-
-;; (add-hook
-;; 'org-mode-hook
-;; (lambda ()
-;; (setq captain-predicate
-;; (lambda () (not (org-in-src-block-p))))))
-
-;; It's also possible to automatically capitalize individual words using the
-;; command `captain-capitalize-word'. This will capitalize the word at point
-;; and tell the captain about it, so he knows that you want it capitalized from
-;; then on. For a package that handles this for any automatic correction, see
-;; the auto-correct package.
-
-;; This solves a similar problem to that of Kevin Rodgers's auto-capitalize
-;; package, but using more modern Emacs features.
-
-;;; Code:
-
-(eval-when-compile (require 'subr-x))
-(require 'thingatpt)
-
-(defun captain--default-predicate ()
- "The default predicate for determining whether the captain should work.
-
-He does nothing by default."
- nil)
-
-(defvar-local captain-predicate #'captain--default-predicate
- "Predicate to check for whether auto-capitalization should be handled.
-
-Should be a function of no arguments, and return non-nil if
-auto-capitalization should be performed at the current point.
-
-For example, this could be a function to check if point is in a
-comment.
-
-This is `captain--default-predicate' by default, which returns
-nil to avoid automatic capitalization happening everywhere, so to
-start using captain, set it to a function of your choosing.")
-
-(defun captain-should-capitalize-p ()
- "Return non-nil if the captain should auto-capitalize your work."
- (funcall captain-predicate))
-
-(defun captain--default-sentence-start ()
- "Default value of `captain-sentence-start-function'.
-
-Just runs `bounds-of-thing-at-point' for a sentence."
- (car (bounds-of-thing-at-point 'sentence)))
-
-(defvar-local captain-sentence-start-function
- #'captain--default-sentence-start
- "Function to determine the start of the current sentence.
-
-This should be a function of no arguments that returns the point
-at which the current function begins.")
-
-(defun captain--run ()
- "Automatically capitalize the word preceding point if it is the start of a
sentence."
- ;; Only do this if the last inserted character isn't part of a word,
- ;; (preceding-char) is the previously inserted character;
- ;; We also need the character before that (It must be a word constituent, so
- ;; enter or space don't keep trying to capitalize the sentence).
- (when (and (captain-should-capitalize-p)
- (not (or (bobp) (eq (char-syntax (preceding-char)) ?w)))
- (eq (char-syntax (save-excursion (forward-char -1)
- (preceding-char)))
- ?w))
- (save-excursion
- ;; Move back to the word that was just finished, and determine if it
- ;; starts a sentence.
- (backward-word-strictly)
- ;; Ensure we're still expected to capitalize. Case: New character put us
- ;; inside a string, but backward-word-strictly brought us outside the
- ;; string.
- (when (captain-should-capitalize-p)
- (when-let ((word-bounds (bounds-of-thing-at-point 'word))
- (sentence-start (funcall captain-sentence-start-function)))
- (cond
- ((let ((case-fold-search nil))
- (string-match-p "[[:upper:]]" (word-at-point)))
- nil)
- ;; This word does start a sentence, so capitalize it
- ((eq (car word-bounds) sentence-start) (capitalize-word 1))
- ;; Word bound will only ever be one greater than the sentence bound
if
- ;; the sentence begins with some sort of punctuation. Remember,
spaces
- ;; don’t count, so if we have a sentence starting with "A ball...",
- ;; ’ball’ wont trigger this, only ’A’.
- ((eq (car word-bounds) (1+ sentence-start))
- (capitalize-word 1))))))))
-
-(defun captain-capitalize-sentence ()
- "Tell the captain to capitalize the start of the current sentence."
- (interactive)
- (save-excursion
- (goto-char (funcall captain-sentence-start-function))
- (capitalize-word 1)))
-
-;;;###autoload
-(define-minor-mode captain-mode
- "Call the captain to automatically capitalize the start of every sentence.
-
-The captain will also automatically capitalize words you've told
-him you want capitalized with `captain-capitalize-word'.
-
-\\{captain-mode-map}"
- :init-value nil
- :lighter " Captain"
- :global nil
- (if captain-mode
- (progn
- (add-hook 'post-self-insert-hook 'captain--run nil t))
- (remove-hook 'post-self-insert-hook 'captain--run t)))
-
-;;;###autoload
-(define-globalized-minor-mode global-captain-mode
- captain-mode captain-mode)
-
-;; Support for capitalizing individual words automatically
-
-(define-abbrev-table 'captain-mode-abbrev-table nil
- "Abbrev table where words that should be automatically capitalized are
stored.
-
-This is case sensitive by default so `expand-region-abbrevs'
-won't keep trying to expand \"Name\" to \"Name\"."
- :enable-function #'captain-should-capitalize-p
- :case-fixed t)
-
-;; Only enable the abbrev table when captain-mode is active
-(add-to-list 'abbrev-minor-mode-table-alist
- `(captain-mode ,captain-mode-abbrev-table)
- 'append
- #'equal)
-
-(defun captain--start-of-word-p ()
- "Return non-nil if at the start of a word."
- (and
- ;; looking at a word constituent...
- (eq (char-syntax (following-char)) ?w)
- ;; ...but before us isn't a word constituent
- (not (eq (char-syntax (preceding-char)) ?w))))
-
-(defun captain-capitalize-word ()
- "Tell the captain to capitalize the word at point.
-
-After that, the captain will remember your choice, and
-automatically capitalize the word from then on.
-
-If not looking at a word, move forward to find the next word."
- (interactive)
- (save-excursion
- ;; Cases for where we are:
- (cond
- ;; Looking at the start of a word, so don't move
- ((captain--start-of-word-p))
- ((word-at-point)
- ;; If we're in the middle of a word, then move back to the start.
- (backward-word-strictly))
- (t
- ;; Otherwise, we're not on a word, so move forward to find the next one.
- ;; This is to remain consistent with the behavior of `capitalize-word'.
- (forward-to-word 1)))
- (when-let ((old-word (substring-no-properties (word-at-point)))
- (new-word (capitalize old-word)))
- ;; Store the abbrev so this word is automatically capitalized later.
- (define-abbrev captain-mode-abbrev-table
- old-word new-word nil :count 1))
- ;; Finally, capitalize the word at point.
- (capitalize-word 1)))
-
-(provide 'captain)
-
-;;; captain.el ends here
diff --git a/packages/cl-generic/cl-generic.el
b/packages/cl-generic/cl-generic.el
deleted file mode 100644
index a40723c..0000000
--- a/packages/cl-generic/cl-generic.el
+++ /dev/null
@@ -1,132 +0,0 @@
-;;; cl-generic.el --- Forward cl-generic compatibility for Emacs<25
-
-;; Copyright (C) 2015, 2016 Free Software Foundation, Inc
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; vcomment: Emacs-25's version is 1.0 so this has to stay below.
-;; Version: 0.3
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is a forward compatibility package, which provides (a subset of) the
-;; features of the cl-generic package introduced in Emacs-25, for use on
-;; previous emacsen.
-
-;; Make sure this is installed *late* in your `load-path`, i.e. after Emacs's
-;; built-in .../lisp/emacs-lisp directory, so that if/when you upgrade to
-;; Emacs≥25, the built-in version of the file will take precedence, otherwise
-;; you could get into trouble (although we try to hack our way around the
-;; problem in case it happens).
-
-;; AFAIK, the main incompatibilities between cl-generic and EIEIO's defmethod
-;; are:
-;; - EIEIO does not support multiple dispatch. We ignore this difference here
-;; and rely on EIEIO to detect and signal the problem.
-;; - EIEIO only supports primary, :before, and :after qualifiers. We ignore
-;; this difference here and rely on EIEIO to detect and signal the problem.
-;; - EIEIO does not support specializers other than classes. We ignore this
-;; difference here and rely on EIEIO to detect and signal the problem.
-;; - EIEIO uses :static instead of (subclass <foo>) and :static methods match
-;; both class arguments as well as object argument of that class. Here we
-;; turn (subclass <foo>) into a :static qualifier and ignore the semantic
-;; difference, hoping noone will notice.
-;; - EIEIO's defgeneric does not reset the function. We ignore this difference
-;; and hope for the best.
-;; - EIEIO uses `call-next-method' and `next-method-p' while cl-defmethod uses
-;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming).
-;; We handle that by renaming the calls in the `cl-defmethod' macro.
-;; - The errors signaled are slightly different. We make
-;; cl-no-applicable-method into a "parent" error of no-method-definition,
-;; which should cover the usual cases.
-;; - EIEIO's no-next-method and no-applicable-method have different calling
-;; conventions from cl-generic's. We don't try to handle this, so just
-;; refrain from trying to call (or add methods to) `cl-no-next-method' or
-;; `cl-no-applicable-method'.
-;; - EIEIO's `call-next-method' and `next-method-p' have dynamic scope whereas
-;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically
-;; scoped. The cl-defmethod here handles the common subset between the two.
-
-;;; Code:
-
-;; We need to handle the situation where this package is used with an Emacs
-;; that comes with a real cl-generic (i.e. ≥25.1).
-
-;; First line of defense: try to make sure the built-in cl-lib comes earlier in
-;; load-path so we never get loaded:
-;;;###autoload (let ((d (file-name-directory #$)))
-;;;###autoload (when (member d load-path)
-;;;###autoload (setq load-path (append (remove d load-path) (list d)))))
-
-(require 'cl-lib nil 'noerror)
-
-;; In Emacs≥25, cl-lib autoloads cl-defmethod and friends.
-
-(unless (fboundp 'cl-defmethod)
- (require 'eieio)
- (require 'cl) ;For `labels'.
-
- (defalias 'cl-defgeneric 'defgeneric)
-
- ;; Compatibility with code which tries to catch
- ;; `cl-no-applicable-method' errors.
- (push 'cl-no-applicable-method (get 'no-method-definition 'error-conditions))
-
- (defalias 'cl-generic-apply #'apply)
-
- (defmacro cl-defmethod (name args &rest body)
- (let ((qualifiers nil))
- (while (not (listp args))
- (push args qualifiers)
- (setq args (pop body)))
- (let ((docstring (if (and (stringp (car body)) (cdr body)) (pop body))))
- ;; Backward compatibility for `no-next-method' and
- ;; `no-applicable-method', which have slightly different calling
- ;; convention than their cl-generic counterpart.
- (pcase name
- (`cl-no-next-method
- (setq name 'no-next-method)
- (setq args (cddr args)))
- (`cl-no-applicable-method
- (setq name 'no-applicable-method)
- (setq args `(,(nth 1 args) ,(nth 0 args)
- ,(make-symbol "_ignore") . ,(nthcdr 2 args)))))
- (let ((arg1 (car args)))
- (when (eq (car-safe (car (cdr-safe arg1))) 'subclass)
- ;; There's no exact equivalent to `subclass', but :static
- ;; provides a superset which should work just as well in practice.
- (push :static qualifiers)
- (setf (cadr arg1) (cadr (cadr arg1)))))
-
- `(defmethod ,name ,@qualifiers ,args
- ,@(if docstring (list docstring))
- ;; We could just alias `cl-call-next-method' to `call-next-method',
- ;; and that would work, but then files compiled with this cl-generic
- ;; wouldn't work in Emacs-25 any more.
- ;; Also we fallback on `labels' if `cl-flet' is not available
- ;; (ELPA's cl-lib emulation doesn't provide cl-flet).
- ;; We don't always use `labels' because that generates warnings
- ;; in newer Emacsen where `cl-flet' is available.
- ,@(if qualifiers
- ;; Must be :before or :after, so can't call next-method.
- body
- `((,(if (fboundp 'cl-flet) 'cl-flet 'labels)
- ((cl-call-next-method (&rest args)
- (apply #'call-next-method args))
- (cl-next-method-p () (next-method-p)))
- ,@body))))))))
-
-(provide 'cl-generic)
-;;; cl-generic.el ends here
diff --git a/packages/cl-lib/cl-lib.el b/packages/cl-lib/cl-lib.el
deleted file mode 100644
index 0f05c3e..0000000
--- a/packages/cl-lib/cl-lib.el
+++ /dev/null
@@ -1,376 +0,0 @@
-;;; cl-lib.el --- Forward cl-lib compatibility library for Emacs<24.3 -*-
coding: utf-8 -*-
-
-;; Copyright (C) 2012-2019 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; vcomment: Emacs-24.3's version is 1.0 so this has to stay below.
-;; Version: 0.6.1
-;; Y-Package-Requires: ((emacs "21")) ¡`emacs' package only exists in Emacs≥24!
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is a forward compatibility package, which provides (a subset of) the
-;; features of the cl-lib package introduced in Emacs-24.3, for use on
-;; previous emacsen (it should work on Emacs≥21 as well as XEmacs).
-
-;; Make sure this is installed *late* in your `load-path`, i.e. after Emacs's
-;; built-in .../lisp/emacs-lisp directory, so that if/when you upgrade to
-;; Emacs-24.3, the built-in version of the file will take precedence, otherwise
-;; you could get into trouble (although we try to hack our way around the
-;; problem in case it happens).
-
-;; This code is largely copied from Emacs-24.3's cl.el, with the alias bindings
-;; simply reversed.
-
-;;; Code:
-
-;; We need to handle the situation where this package is used with an Emacs
-;; that comes with a real cl-lib (i.e. ≥24.3).
-
-;; First line of defense: try to make sure the built-in cl-lib comes earlier in
-;; load-path so we never get loaded:
-;;;###autoload (let ((d (file-name-directory #$)))
-;;;###autoload (when (member d load-path)
-;;;###autoload (setq load-path (append (remove d load-path) (list d)))))
-
-(when (functionp 'macroexp--compiler-macro)
- ;; `macroexp--compiler-macro' was introduced as part of the big CL
- ;; reorganization which moved/reimplemented some of CL into core (mostly the
- ;; setf and compiler-macro support), so its presence indicates we're running
- ;; in an Emacs that comes with the new cl-lib.el, where this file should
- ;; never be loaded!
- (message "Real cl-lib shadowed by compatibility cl-lib? (%s)" load-file-name)
- (when load-file-name
- ;; (message "Let's try to patch things up")
- (let ((loaddir (file-name-directory load-file-name))
- load-path-dir)
- ;; Find the problematic directory from load-path.
- (dolist (dir load-path)
- (if (equal loaddir (expand-file-name (file-name-as-directory dir)))
- (setq load-path-dir dir)))
- (when load-path-dir
- ;; (message "Let's move the offending dir to the end")
- (setq load-path (append (remove load-path-dir load-path)
- (list load-path-dir)))
- ;; Here we could manually load cl-lib and then return immediately.
- ;; But Emacs currently doesn't provide any way for a file to "return
- ;; immediately", so instead we make sure the rest of the file does not
- ;; throw away any pre-existing definition.
- ))))
-
-(require 'cl)
-
-;; Some of Emacs-24.3's cl.el definition are not just aliases, because either
-;; the feature was dropped from cl-lib.el or because the cl-lib version is
-;; not fully compatible.
-;; Let's just not include them here, since it is very important that if code
-;; works with this cl-lib.el it should also work with Emacs-24.3's cl-lib.el,
-;; whereas the reverse is much less important.
-
-(dolist (var '(
- ;; loop-result-var
- ;; loop-result
- ;; loop-initially
- ;; loop-finally
- ;; loop-bindings
- ;; loop-args
- ;; bind-inits
- ;; bind-block
- ;; lambda-list-keywords
- float-negative-epsilon
- float-epsilon
- least-negative-normalized-float
- least-positive-normalized-float
- least-negative-float
- least-positive-float
- most-negative-float
- most-positive-float
- ;; custom-print-functions
- ))
- (let ((new (intern (format "cl-%s" var))))
- (if (fboundp 'defvaralias)
- (unless (boundp new) (defvaralias new var))
- (if (fboundp 'cl-float-limits) (cl-float-limits))
- (eval `(defvar ,new ,var ,(format "`cl-lib' alias of `%s'" var))))))
-
-;; The following cl-lib functions were already defined in the old cl.el,
-;; with a different meaning:
-;; - cl-position and cl-delete-duplicates
-;; the two meanings are clearly different, but we can distinguish which was
-;; meant by looking at the arguments.
-;; - cl-member
-;; the old meaning hasn't been used for a long time and is a subset of the
-;; new, so we can simply override it.
-;; - cl-adjoin
-;; the old meaning is actually the same as the new except for optimizations.
-
-(dolist (fun '(
- (get* . cl-get)
- (random* . cl-random)
- (rem* . cl-rem)
- (mod* . cl-mod)
- (round* . cl-round)
- (truncate* . cl-truncate)
- (ceiling* . cl-ceiling)
- (floor* . cl-floor)
- (rassoc* . cl-rassoc)
- (assoc* . cl-assoc)
- ;; (member* . cl-member) ;Handle specially below.
- (delete* . cl-delete)
- (remove* . cl-remove)
- (defsubst* . cl-defsubst)
- (sort* . cl-sort)
- (function* . cl-function)
- (defmacro* . cl-defmacro)
- (defun* . cl-defun)
- (mapcar* . cl-mapcar)
-
- remprop
- getf
- tailp
- list-length
- nreconc
- revappend
- concatenate
- subseq
- random-state-p
- make-random-state
- signum
- isqrt
- lcm
- gcd
- notevery
- notany
- every
- some
- mapcon
- mapcan
- mapl
- maplist
- map
- equalp
- coerce
- tree-equal
- nsublis
- sublis
- nsubst-if-not
- nsubst-if
- nsubst
- subst-if-not
- subst-if
- subsetp
- nset-exclusive-or
- set-exclusive-or
- nset-difference
- set-difference
- nintersection
- intersection
- nunion
- union
- rassoc-if-not
- rassoc-if
- assoc-if-not
- assoc-if
- member-if-not
- member-if
- merge
- stable-sort
- search
- mismatch
- count-if-not
- count-if
- count
- position-if-not
- position-if
- ;; position ;Handle specially via defadvice below.
- find-if-not
- find-if
- find
- nsubstitute-if-not
- nsubstitute-if
- nsubstitute
- substitute-if-not
- substitute-if
- substitute
- ;; delete-duplicates ;Handle specially via defadvice below.
- remove-duplicates
- delete-if-not
- delete-if
- remove-if-not
- remove-if
- replace
- fill
- reduce
- compiler-macroexpand
- define-compiler-macro
- assert
- check-type
- typep
- deftype
- defstruct
- callf2
- callf
- letf*
- letf
- rotatef
- shiftf
- remf
- psetf
- declare
- the
- locally
- multiple-value-setq
- multiple-value-bind
- symbol-macrolet
- macrolet
- progv
- psetq
- do-all-symbols
- do-symbols
- dotimes
- dolist
- do*
- do
- loop
- return-from
- return
- block
- etypecase
- typecase
- ecase
- case
- load-time-value
- eval-when
- destructuring-bind
- gentemp
- gensym
- pairlis
- acons
- subst
- ;; adjoin ;It's already defined.
- copy-list
- ldiff
- list*
- cddddr
- cdddar
- cddadr
- cddaar
- cdaddr
- cdadar
- cdaadr
- cdaaar
- cadddr
- caddar
- cadadr
- cadaar
- caaddr
- caadar
- caaadr
- caaaar
- cdddr
- cddar
- cdadr
- cdaar
- caddr
- cadar
- caadr
- caaar
- tenth
- ninth
- eighth
- seventh
- sixth
- fifth
- fourth
- third
- endp
- rest
- second
- first
- svref
- copy-seq
- evenp
- oddp
- minusp
- plusp
- floatp-safe
- declaim
- proclaim
- nth-value
- multiple-value-call
- multiple-value-apply
- multiple-value-list
- values-list
- values
- pushnew
- decf
- incf
-
- dolist
- dotimes
- ))
- (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
- (intern (format "cl-%s" fun)))))
- (if (fboundp new)
- (unless (or (eq (symbol-function new) fun)
- (eq new (and (symbolp fun) (fboundp fun)
- (symbol-function fun))))
- (message "%S already defined, not rebinding" new))
- (defalias new fun))))
-
-(unless (symbolp (symbol-function 'position))
- (autoload 'cl-position "cl-seq")
- (defadvice cl-position (around cl-lib (cl-item cl-seq &rest cl-keys)
activate)
- (let ((argk (ad-get-args 2)))
- (if (or (null argk) (keywordp (car argk)))
- ;; This is a call to cl-lib's `cl-position'.
- (setq ad-return-value
- (apply #'position (ad-get-arg 0) (ad-get-arg 1) argk))
- ;; Must be a call to cl's old `cl-position'.
- ad-do-it))))
-
-(unless (symbolp (symbol-function 'delete-duplicates))
- (autoload 'cl-delete-duplicates "cl-seq")
- (defadvice cl-delete-duplicates (around cl-lib (cl-seq &rest cl-keys)
activate)
- (let ((argk (ad-get-args 1)))
- (if (or (null argk) (keywordp (car argk)))
- ;; This is a call to cl-lib's `cl-delete-duplicates'.
- (setq ad-return-value
- (apply #'delete-duplicates (ad-get-arg 0) argk))
- ;; Must be a call to cl's old `cl-delete-duplicates'.
- ad-do-it))))
-
-(when (or (not (fboundp 'cl-member))
- (eq (symbol-function 'cl-member) #'memq))
- (defalias 'cl-member #'member*))
-
-;; `cl-labels' is not 100% compatible with `labels' when using dynamic scoping
-;; (mostly because it does not turn lambdas that refer to those functions into
-;; closures). OTOH it is compatible when using lexical scoping.
-
-(unless (fboundp 'cl-labels)
- (defmacro cl-labels (&rest args)
- (unless (and (boundp 'lexical-binding) lexical-binding)
- ;; We used to signal an error rather than a message, but in many uses of
- ;; cl-labels, the value of lexical-binding doesn't actually matter.
- ;; More importantly, the value of `lexical-binding' here is unreliable
- ;; (it does not necessarily reflect faithfully whether the output of this
- ;; macro will be interpreted as lexically bound code or not).
- (message "This `cl-labels' requires `lexical-binding' to be non-nil"))
- `(labels ,@args)))
-
-(provide 'cl-lib)
-;;; cl-lib.el ends here
diff --git a/packages/company-ebdb/company-ebdb.el
b/packages/company-ebdb/company-ebdb.el
deleted file mode 100644
index 3659d37..0000000
--- a/packages/company-ebdb/company-ebdb.el
+++ /dev/null
@@ -1,91 +0,0 @@
-;;; company-ebdb.el --- company-mode completion backend for EBDB in
message-mode
-
-;; Copyright (C) 2013-2014, 2016 Free Software Foundation, Inc.
-
-;; Author: Jan Tatarik <jan.tatarik@gmail.com>
-;; Maintainer: Eric Abrahamsen <eric@ericabrahamsen.net>
-;; Version: 1.1
-;; Package-Requires: ((company "0.9.4") (ebdb "0.2"))
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Company integration for EBDB. Copied more or less intact from
-;; company-bbdb, originally by Jan Tatarik.
-
-;;; Code:
-
-(require 'company)
-(require 'cl-lib)
-
-(declare-function ebdb-record-mail "ebdb")
-(declare-function ebdb-records "ebdb")
-(declare-function ebdb-dwim-mail "ebdb-com")
-(declare-function ebdb-search "ebdb-com")
-
-(defgroup company-ebdb nil
- "Completion backend for EBDB."
- :group 'company)
-
-(defcustom company-ebdb-modes '(message-mode mail-mode)
- "Major modes in which `company-ebdb' may complete."
- :type '(repeat (symbol :tag "Major mode"))
- :package-version '(company . "0.8.8"))
-
-(defcustom company-ebdb-pop-up t
- "When non-nil, pop up an *EBDB* buffer after completion."
- :type 'boolean)
-
-(defun company-ebdb--candidates (arg)
- (cl-mapcan (lambda (record)
- (delq nil
- (mapcar (lambda (mail)
- (let ((dwim (ebdb-dwim-mail record mail)))
- (when (string-match-p arg dwim)
- dwim)))
- (ebdb-record-mail record))))
- (eval '(ebdb-search (ebdb-records) `((ebdb-field-name ,arg)
- (ebdb-field-mail ,arg))))))
-
-(defun company-ebdb--post-complete (arg)
- (when (and company-ebdb-pop-up
- (apply #'derived-mode-p company-ebdb-modes))
- (let* ((bits (ebdb-decompose-ebdb-address arg))
- (recs (ebdb-message-search (car bits) (nth 1 bits))))
- (when recs
- (ebdb-display-records recs nil nil nil (ebdb-popup-window))))))
-
-;;;###autoload
-(defun company-ebdb (command &optional arg &rest ignore)
- "`company-mode' completion backend for EBDB."
- (interactive (list 'interactive))
- (cl-case command
- (interactive (company-begin-backend 'company-ebdb))
- (prefix (and (apply #'derived-mode-p company-ebdb-modes)
- (featurep 'ebdb-com)
- (looking-back "^\\(To\\|Cc\\|Bcc\\): *.*? *\\([^,;]*\\)"
- (line-beginning-position))
- (match-string-no-properties 2)))
- (candidates (company-ebdb--candidates arg))
- (post-completion (company-ebdb--post-complete arg))
- (sorted t)
- (no-cache t)))
-
-(add-to-list 'company-backends 'company-ebdb)
-
-(provide 'company-ebdb)
-;;; company-ebdb.el ends here
diff --git a/packages/crisp/crisp.el b/packages/crisp/crisp.el
deleted file mode 100644
index e7835f2..0000000
--- a/packages/crisp/crisp.el
+++ /dev/null
@@ -1,392 +0,0 @@
-;;; crisp.el --- CRiSP/Brief Emacs emulator
-
-;; Copyright (C) 1997-1999, 2001-2014, 2018 Free Software Foundation, Inc.
-
-;; Author: Gary D. Foster <Gary.Foster@Corp.Sun.COM>
-;; Maintainer: Luke Lee <luke.yx.lee@gmail.com>
-;; Keywords: emulations brief crisp
-;; Package-Require: ((cl-lib "0.5"))
-;; Version: 1.3.6
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Keybindings and minor functions to duplicate the functionality and
-;; finger-feel of the CRiSP/Brief editor. This package is designed to
-;; facilitate transitioning from Brief to (XE|E)macs with a minimum
-;; amount of hassles.
-
-;; Enable this package by putting (require 'crisp) in your .emacs and
-;; use M-x crisp-mode to toggle it on or off.
-
-;; This package will automatically load the scroll-all.el package if
-;; you put (setq crisp-load-scroll-all t) in your .emacs before
-;; loading this package. If this feature is enabled, it will bind
-;; meta-f1 to the scroll-all mode toggle. The scroll-all package
-;; duplicates the scroll-all feature in CRiSP.
-
-;; Also, the default keybindings for brief/CRiSP override the M-x
-;; key to exit the editor. If you don't like this functionality, you
-;; can prevent this behavior (or redefine it dynamically) by setting
-;; the value of `crisp-override-meta-x' either in your .emacs or
-;; interactively. The default setting is t, which means that M-x will
-;; by default run `save-buffers-kill-emacs' instead of the command
-;; `execute-extended-command'.
-
-;; Finally, if you want to change the string displayed in the mode
-;; line when this mode is in effect, override the definition of
-;; `crisp-mode-mode-line-string' in your .emacs. The default value is
-;; " *Crisp*" which may be a bit lengthy if you have a lot of things
-;; being displayed there.
-
-;; All these overrides should go *before* the (require 'crisp) statement.
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-
-;; local variables
-
-(defgroup crisp nil
- "Emulator for CRiSP and Brief key bindings."
- :prefix "crisp-"
- :group 'emulations)
-
-(defvar crisp-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [(f1)] 'other-window)
-
- (define-key map [(f2) (down)] 'enlarge-window)
- (define-key map [(f2) (left)] 'shrink-window-horizontally)
- (define-key map [(f2) (right)] 'enlarge-window-horizontally)
- (define-key map [(f2) (up)] 'shrink-window)
- (define-key map [(f3) (down)] 'split-window-below)
- (define-key map [(f3) (right)] 'split-window-right)
-
- (define-key map [(f4)] 'delete-window)
- (define-key map [(control f4)] 'delete-other-windows)
-
- (define-key map [(f5)] 'search-forward-regexp)
- (define-key map [(f19)] 'search-forward-regexp)
- (define-key map [(meta f5)] 'search-backward-regexp)
-
- (define-key map [(f6)] 'query-replace)
-
- (define-key map [(f7)] 'start-kbd-macro)
- (define-key map [(meta f7)] 'end-kbd-macro)
-
- (define-key map [(f8)] 'call-last-kbd-macro)
- (define-key map [(meta f8)] 'save-kbd-macro)
-
- (define-key map [(f9)] 'find-file)
- (define-key map [(meta f9)] 'load-library)
-
- (define-key map [(f10)] 'execute-extended-command)
- (define-key map [(meta f10)] 'compile)
-
- (define-key map [(SunF37)] 'kill-buffer)
- (define-key map [(kp-add)] 'crisp-copy-line)
- (define-key map [(kp-subtract)] 'crisp-kill-line)
- ;; just to cover all the bases (GNU Emacs, for instance)
- (define-key map [(f24)] 'crisp-kill-line)
- (define-key map [(insert)] 'crisp-yank-clipboard)
- (define-key map [(f16)] 'crisp-set-clipboard) ; copy on Sun5 kbd
- (define-key map [(f20)] 'crisp-kill-region) ; cut on Sun5 kbd
- (define-key map [(f18)] 'crisp-yank-clipboard) ; paste on Sun5 kbd
-
- (define-key map [(control f)] 'fill-paragraph-or-region)
- (define-key map [(meta d)] (lambda ()
- (interactive)
- (beginning-of-line) (kill-line)))
- (define-key map [(meta e)] 'find-file)
- (define-key map [(meta g)] 'goto-line)
- (define-key map [(meta h)] 'help)
- (define-key map [(meta i)] 'overwrite-mode)
- (define-key map [(meta j)] 'bookmark-jump)
- (define-key map [(meta l)] 'crisp-mark-line)
- (define-key map [(meta m)] 'set-mark-command)
- (define-key map [(meta n)] 'bury-buffer)
- (define-key map [(meta p)] 'crisp-unbury-buffer)
- (define-key map [(meta u)] 'undo)
- (define-key map [(f14)] 'undo)
- (define-key map [(meta w)] 'save-buffer)
- (define-key map [(meta x)] 'crisp-meta-x-wrapper)
- (define-key map [(meta ?0)] (lambda ()
- (interactive)
- (bookmark-set "0")))
- (define-key map [(meta ?1)] (lambda ()
- (interactive)
- (bookmark-set "1")))
- (define-key map [(meta ?2)] (lambda ()
- (interactive)
- (bookmark-set "2")))
- (define-key map [(meta ?3)] (lambda ()
- (interactive)
- (bookmark-set "3")))
- (define-key map [(meta ?4)] (lambda ()
- (interactive)
- (bookmark-set "4")))
- (define-key map [(meta ?5)] (lambda ()
- (interactive)
- (bookmark-set "5")))
- (define-key map [(meta ?6)] (lambda ()
- (interactive)
- (bookmark-set "6")))
- (define-key map [(meta ?7)] (lambda ()
- (interactive)
- (bookmark-set "7")))
- (define-key map [(meta ?8)] (lambda ()
- (interactive)
- (bookmark-set "8")))
- (define-key map [(meta ?9)] (lambda ()
- (interactive)
- (bookmark-set "9")))
-
- (define-key map [(shift delete)] 'kill-word)
- (define-key map [(shift backspace)] 'backward-kill-word)
- (define-key map [(control left)] 'backward-word)
- (define-key map [(control right)] 'forward-word)
-
- (define-key map [(home)] 'crisp-home)
- (define-key map [(control home)] (lambda ()
- (interactive)
- (move-to-window-line 0)))
- (define-key map [(meta home)] 'beginning-of-line)
- (define-key map [(end)] 'crisp-end)
- (define-key map [(control end)] (lambda ()
- (interactive)
- (move-to-window-line -1)))
- (define-key map [(meta end)] 'end-of-line)
- map)
- "Local keymap for CRiSP emulation mode.
-All the bindings are done here instead of globally to try and be
-nice to the world.")
-
-(define-obsolete-variable-alias 'crisp-mode-modeline-string
- 'crisp-mode-mode-line-string "24.3")
-
-(defcustom crisp-mode-mode-line-string " *CRiSP*"
- "String to display in the mode line when CRiSP emulation mode is enabled."
- :type 'string)
-
-(defcustom crisp-override-meta-x t
- "Controls overriding the normal Emacs M-x key binding in the CRiSP emulator.
-Normally the CRiSP emulator rebinds M-x to `save-buffers-exit-emacs', and
-provides the usual M-x functionality on the F10 key. If this variable
-is non-nil, M-x will exit Emacs."
- :type 'boolean)
-
-(defcustom crisp-load-scroll-all nil
- "Controls loading of the Scroll Lock in the CRiSP emulator.
-Its default behavior is to load and enable the Scroll Lock minor mode
-package when enabling the CRiSP emulator.
-
-If this variable is nil when you start the CRiSP emulator, it
-does not load the scroll-all package."
- :type 'boolean)
-
-(defcustom crisp-load-hook nil
- "Hooks to run after loading the CRiSP emulator package."
- :type 'hook)
-
-(defcustom crisp-mode-hook nil
- "Hook run by the function `crisp-mode'."
- :type 'hook)
-
-(defconst crisp--version-or-file
- (if (fboundp 'package-get-version) (package-get-version)
- (list load-file-name))
- "The version of the CRiSP emulator.")
-
-(defconst crisp-mode-help-address "gfoster@suzieq.ml.org"
- "The email address of the CRiSP mode author/maintainer.")
-
-;; Silence the byte-compiler.
-(defvar crisp-last-last-command nil
- "The previous value of `last-command'.")
-
-;; The cut and paste routines are different between XEmacs and Emacs
-;; so we need to set up aliases for the functions.
-
-(defalias 'crisp-set-clipboard
- (if (fboundp 'clipboard-kill-ring-save)
- 'clipboard-kill-ring-save
- 'copy-primary-selection))
-
-(defalias 'crisp-kill-region
- (if (fboundp 'clipboard-kill-region)
- 'clipboard-kill-region
- 'kill-primary-selection))
-
-(defalias 'crisp-yank-clipboard
- (if (fboundp 'clipboard-yank)
- 'clipboard-yank
- 'yank-clipboard-selection))
-
-(defun crisp-region-active ()
- "Compatibility function to test for an active region."
- (if (featurep 'xemacs)
- zmacs-region-active-p
- mark-active))
-
-(defun crisp-version (&optional arg)
- "Version number of the CRiSP emulator package.
-If ARG, insert results at point."
- (interactive "P")
- (when (consp crisp--version-or-file)
- (setq crisp--version-or-file
- (let ((file (car crisp--version-or-file)))
- ;; Copy/pasted from package-get-version:
- (cond
- ((null file) nil)
- ;; Packages are normally installed into directories named
- ;; "<pkg>-<vers>", so get the version number from there.
- ((string-match
"/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'"
file)
- (match-string 1 file))
- ;; For packages run straight from the an elpa.git clone, there's
- ;; no "-<vers>" in the directory name, so we have to fetch the
- ;; version the hard way.
- (t
- (let* ((pkgdir (file-name-directory file))
- (pkgname (file-name-nondirectory
- (directory-file-name pkgdir)))
- (mainfile (expand-file-name
- (concat pkgname ".el") pkgdir)))
- (when (file-readable-p mainfile)
- (require 'lisp-mnt)
- (with-temp-buffer
- (insert-file-contents mainfile)
- (or (lm-header "package-version")
- (lm-header "version"))))))))))
- (let* ((foo (concat "CRiSP version "
- (or crisp--version-or-file "<unknown>"))))
- (if arg
- (insert (message foo))
- (message foo))))
-
-(defun crisp-mark-line (arg)
- "Set mark at the end of the line.
-Arg works as in `end-of-line'."
- (interactive "p")
- (let (newmark)
- (save-excursion
- (end-of-line arg)
- (setq newmark (point)))
- (push-mark newmark nil t)))
-
-(defun crisp-kill-line (arg)
- "Mark and kill line(s).
-Marks from point to end of the current line (honoring prefix arguments),
-copies the region to the kill ring and clipboard, and then deletes it."
- (interactive "*p")
- (if (crisp-region-active)
- (call-interactively 'crisp-kill-region)
- (crisp-mark-line arg)
- (call-interactively 'crisp-kill-region)))
-
-(defun crisp-copy-line (arg)
- "Mark and copy line(s).
-Marks from point to end of the current line (honoring prefix arguments),
-copies the region to the kill ring and clipboard, and then deactivates
-the region."
- (interactive "*p")
- (if (crisp-region-active)
- (call-interactively 'crisp-set-clipboard)
- (crisp-mark-line arg)
- (call-interactively 'crisp-set-clipboard))
- ;; clear the region after the operation is complete
- ;; XEmacs does this automagically, Emacs doesn't.
- (if (boundp 'mark-active)
- (setq mark-active nil)))
-
-(defun crisp-home ()
- "\"Home\" the point, the way CRiSP would do it.
-The first use moves point to beginning of the line. Second
-consecutive use moves point to beginning of the screen. Third
-consecutive use moves point to the beginning of the buffer."
- (interactive "^")
- (cond
- ((and (eq last-command 'crisp-home)
- (eq crisp-last-last-command 'crisp-home))
- (goto-char (point-min)))
- ((eq last-command 'crisp-home)
- (move-to-window-line 0))
- (t
- (beginning-of-line)))
- (setq crisp-last-last-command last-command))
-
-(defun crisp-end ()
- "\"End\" the point, the way CRiSP would do it.
-The first use moves point to end of the line. Second
-consecutive use moves point to the end of the screen. Third
-consecutive use moves point to the end of the buffer."
- (interactive "^")
- (cond
- ((and (eq last-command 'crisp-end)
- (eq crisp-last-last-command 'crisp-end))
- (goto-char (point-max)))
- ((eq last-command 'crisp-end)
- (move-to-window-line -1)
- (end-of-line))
- (t
- (end-of-line)))
- (setq crisp-last-last-command last-command))
-
-(defun crisp-unbury-buffer ()
- "Go back one buffer."
- (interactive)
- (switch-to-buffer (car (last (buffer-list)))))
-
-(defun crisp-meta-x-wrapper ()
- "Wrapper function to conditionally override the normal M-x bindings.
-When `crisp-override-meta-x' is non-nil, M-x will exit Emacs (the
-normal CRiSP binding) and when it is nil M-x will run
-`execute-extended-command' (the normal Emacs binding)."
- (interactive)
- (if crisp-override-meta-x
- (save-buffers-kill-emacs)
- (call-interactively 'execute-extended-command)))
-
-(defvar crisp--minor-mode-map (make-sparse-keymap)
- "Dummy map for `minor-mode-map-alist'.")
-
-;;;###autoload
-(define-minor-mode crisp-mode
- "Toggle CRiSP/Brief emulation (CRiSP mode).
-With a prefix argument ARG, enable CRiSP mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
- :keymap crisp--minor-mode-map
- :lighter crisp-mode-mode-line-string
- :global t
- (cond
- (crisp-mode
- ;; Make menu entries show M-u or f14 in preference to C-x u.
- (put 'undo :advertised-binding
- `([?\M-u] [f14] ,@(get 'undo :advertised-binding)))
- (cl-pushnew crisp-mode-map (cdr global-map))
- (if crisp-load-scroll-all
- (require 'scroll-all))
- (if (fboundp 'scroll-all-mode)
- (define-key crisp-mode-map [(meta f1)] 'scroll-all-mode)))
- (t ;; not crisp-mode
- (cl-callf (lambda (binds) (delq crisp-mode-map binds)) (cdr global-map)))))
-
-(run-hooks 'crisp-load-hook)
-(provide 'crisp)
-
-;;; crisp.el ends here
diff --git a/packages/cycle-quotes/cycle-quotes-test.el
b/packages/cycle-quotes/cycle-quotes-test.el
deleted file mode 100644
index 43c2bc6..0000000
--- a/packages/cycle-quotes/cycle-quotes-test.el
+++ /dev/null
@@ -1,83 +0,0 @@
-;;; cycle-quotes-test.el --- Tests for cycle-quotes.el -*- lexical-binding:
t; -*-
-
-;; Copyright (C) 2015-2018 Free Software Foundation, Inc.
-
-;; Author: Simen Heggestøyl <simenheg@gmail.com>
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(require 'cycle-quotes)
-(require 'ert)
-;; For testing triple quotes
-(require 'python)
-
-(ert-deftest test-cycle-quotes--set-quote-chars ()
- (with-temp-buffer
- (let ((st (make-syntax-table)))
- (set-syntax-table st)
- (modify-syntax-entry ?a "\"")
- (modify-syntax-entry ?b "\"")
- (cycle-quotes--set-quote-chars)
- (should (= (length cycle-quotes--quote-chars) 3))
- (should (memq ?a cycle-quotes--quote-chars))
- (should (memq ?b cycle-quotes--quote-chars))
- (should (memq ?\" cycle-quotes--quote-chars)))))
-
-(ert-deftest test-cycle-quotes--next-quote-char ()
- (let ((cycle-quotes--quote-chars '(?a)))
- (should (= (cycle-quotes--next-quote-char ?a) ?a)))
- (let ((cycle-quotes--quote-chars '(?a ?b)))
- (should (= (cycle-quotes--next-quote-char ?a) ?b)))
- (let ((cycle-quotes--quote-chars '(?a ?b ?c)))
- (should (= (cycle-quotes--next-quote-char ?c) ?a))))
-
-(ert-deftest test-cycle-quotes--fix-escapes ()
- (with-temp-buffer
- (insert "b\\baabc\\b")
- (cycle-quotes--fix-escapes (point-min) (point-max) ?a ?b)
- (should (equal (buffer-string) "bb\\a\\abcb"))))
-
-(ert-deftest test-cycle-quotes ()
- (with-temp-buffer
- (let ((st (make-syntax-table)))
- (set-syntax-table st)
- (modify-syntax-entry ?' "\"")
- (modify-syntax-entry ?` "\"")
- (insert "\"Hi, it's me!\"")
- (goto-char 5)
- (cycle-quotes)
- (should (equal (buffer-string) "`Hi, it's me!`"))
- (cycle-quotes)
- (should (equal (buffer-string) "'Hi, it\\'s me!'"))
- (cycle-quotes)
- (should (equal (buffer-string) "\"Hi, it's me!\"")))))
-
-(ert-deftest test-cycle-quotes-triple-quotes ()
- (with-temp-buffer
- (python-mode)
- (insert "'''Triple quotes, as found in Python.'''")
- (goto-char 5)
- (cycle-quotes)
- (should (equal (buffer-string)
- "\"\"\"Triple quotes, as found in Python.\"\"\""))
- (cycle-quotes)
- (should (equal (buffer-string)
- "'''Triple quotes, as found in Python.'''"))))
-
-(provide 'cycle-quotes-test)
-;;; cycle-quotes-test.el ends here
diff --git a/packages/cycle-quotes/cycle-quotes.el
b/packages/cycle-quotes/cycle-quotes.el
deleted file mode 100644
index b2f8465..0000000
--- a/packages/cycle-quotes/cycle-quotes.el
+++ /dev/null
@@ -1,147 +0,0 @@
-;;; cycle-quotes.el --- Cycle between quote styles -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2015-2018 Free Software Foundation, Inc.
-
-;; Author: Simen Heggestøyl <simenheg@gmail.com>
-;; Maintainer: Simen Heggestøyl <simenheg@gmail.com>
-;; Keywords: convenience
-;; Version: 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package provides the `cycle-quotes' command to cycle between
-;; different string quote styles. For instance, in JavaScript,
-;; there's three string quote characters: ", ` and '. In a JavaScript
-;; buffer, with point located someplace within the string,
-;; `cycle-quotes' will cycle between the following quote styles each
-;; time it's called:
-;;
-;; --> "Hi, it's me!" --> `Hi, it's me!` --> 'Hi, it\'s me!' --
-;; | |
-;; ------------------------------------------------------------
-;;
-;; As seen in the above example, `cycle-quotes' tries to escape and
-;; unescape quote characters intelligently.
-
-;;; Code:
-
-(defvar-local cycle-quotes--quote-chars '()
- "A list of string quote characters for the current mode.
-Set the first time `cycle-quotes' is called in a buffer.")
-
-(defvar-local cycle-quotes--quote-chars-mode nil
- "The latest mode that the quote char list was last computed for.
-If this is different from the current mode, the quote chars need
-to be recomputed.")
-
-(defun cycle-quotes--set-quote-chars ()
- "Set the quote chars for the current syntax table."
- (let ((syntax-table (syntax-table)))
- (while syntax-table
- (map-char-table
- (lambda (char-code-or-range syntax)
- (when (equal (syntax-class syntax) 7)
- (if (consp char-code-or-range)
- (let ((from (car char-code-or-range))
- (to (cdr char-code-or-range)))
- (dolist (char-code (number-sequence from to))
- (add-to-list 'cycle-quotes--quote-chars char-code)))
- (add-to-list
- 'cycle-quotes--quote-chars char-code-or-range))))
- syntax-table)
- (setq syntax-table (char-table-parent syntax-table)))
- (setq-local cycle-quotes--quote-chars-mode major-mode)))
-
-(defun cycle-quotes--next-quote-char (char)
- "Return quote char after CHAR."
- (let ((list-from-char (member char cycle-quotes--quote-chars)))
- (when list-from-char
- (if (= (length list-from-char) 1)
- (car cycle-quotes--quote-chars)
- (cadr list-from-char)))))
-
-(defun cycle-quotes--fix-escapes (beg end escape-char unescape-char)
- "Fix character escapes between BEG and END.
-Instances of ESCAPE-CHAR will be escaped by `\\', while instances
-where UNESCAPE-CHAR are escaped by `\\' will have their escape
-character removed."
- (let ((escape-string (string escape-char))
- (unescape-string (string unescape-char)))
- (save-excursion
- (goto-char end)
- (while (search-backward (concat "\\" unescape-string) beg t)
- (replace-match unescape-string nil t)))
- (save-excursion
- (goto-char end)
- (while (search-backward escape-string beg t)
- (replace-match (concat "\\" escape-string) nil t)
- (forward-char -1)))))
-
-;;;###autoload
-(defun cycle-quotes ()
- "Cycle between string quote styles."
- (interactive)
- (unless (eq major-mode cycle-quotes--quote-chars-mode)
- (cycle-quotes--set-quote-chars))
- (if (< (length cycle-quotes--quote-chars) 2)
- (message "The current mode has no alternative quote syntax")
- (let ((quote-char (nth 3 (syntax-ppss))))
- (if (not quote-char)
- (message "Not inside a string")
- (let ((inside-generic-string (eq quote-char t))
- ;; Can't use `save-excursion', because the marker will get
- ;; deleted if point is at the beginning of the string.
- (start-pos (point)))
- (when inside-generic-string
- (skip-syntax-backward "^|")
- (forward-char -1)
- (setq quote-char (char-after)))
- (let ((new-quote-char
- (cycle-quotes--next-quote-char
- (if inside-generic-string
- (char-after)
- quote-char))))
- (unless inside-generic-string
- (search-backward-regexp
- (concat "\\([^\\]" (string quote-char) "\\)\\|"
- "^" (string quote-char)))
- (when (match-beginning 1)
- (forward-char)))
- (let ((repeat
- ;; Handle multiple quotes, such as Python's triple
- ;; quotes.
- (save-excursion
- (search-forward-regexp
- (format "%c+" quote-char))
- (- (match-end 0) (match-beginning 0)))))
- (save-excursion
- (let ((beg (point)))
- (forward-sexp)
- ;; `forward-sexp' fails to jump to the matching quote
- ;; in some modes, for instance `js2-mode'.
- (skip-syntax-backward "^\"|")
- (cycle-quotes--fix-escapes
- (+ beg 1) (+ (point) 1) new-quote-char quote-char))
- (delete-char (- repeat))
- (dotimes (_ repeat)
- (insert new-quote-char)))
- (delete-char repeat)
- (dotimes (_ repeat)
- (insert new-quote-char))))
- (goto-char start-pos))))))
-
-(provide 'cycle-quotes)
-;;; cycle-quotes.el ends here
diff --git a/packages/docbook/docbook.el b/packages/docbook/docbook.el
deleted file mode 100644
index faaac01..0000000
--- a/packages/docbook/docbook.el
+++ /dev/null
@@ -1,1218 +0,0 @@
-;;; docbook.el --- Info-like viewer for DocBook -*- lexical-binding: t -*-
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Chong Yidong <cyd@gnu.org>
-;; Keywords: docs, help
-;; Version: 0.1
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; An Info-like viewer for DocBook manuals.
-;;
-;; Entry point: M-x docbook-find-file
-
-;;; TODO:
-
-;; table
-;; informaltable
-;; graphics
-;;
-;; funcsynopsis
-;; classsynopsis
-;; citerefentry
-;;
-;; see, primaryie, secondaryie
-
-;;; Code:
-
-(require 'xml)
-
-(defgroup docbook nil
- "The Emacs DocBook reader."
- :group 'help
- :group 'docs)
-
-(defface docbook-xref
- '((t :inherit button))
- "Face for DocBook cross references."
- :group 'docbook)
-
-(defface docbook-warning
- '((t :inherit font-lock-warning-face))
- "Face for warning text in DocBook documents."
- :group 'docbook)
-
-(defface docbook-emphasis
- '((t :slant italic))
- "Face for emphasized text in DocBook documents."
- :group 'docbook)
-
-(defface docbook-literal
- '((t :inherit (font-lock-constant-face fixed-pitch)))
- "Face for DocBook text marked as being literal."
- :group 'docbook)
-
-(defface docbook-computer
- '((t :inherit (font-lock-type-face fixed-pitch)))
- "Face for DocBook text marked as computer output."
- :group 'docbook)
-
-(defface docbook-computer-term
- '((t :inherit (font-lock-keyword-face fixed-pitch)))
- "Face for DocBook text marked as computer terminology."
- :group 'docbook)
-
-(defface docbook-replaceable
- '((t :inherit (font-lock-string-face bold)))
- "Face for DocBook text marked as replaceable."
- :group 'docbook)
-
-(defface docbook-citation
- '((t :slant italic))
- "Face for DocBook text marked as non-xref citations."
- :group 'docbook)
-
-(defface docbook-label
- '((t :weight bold :underline t))
- "Face for DocBook text marked as labels for Q&A entries,"
- :group 'docbook)
-
-(defface docbook-small '((t :height 0.8))
- "Face for DocBook text marked as small."
- :group 'docbook)
-
-(defface docbook-chapter-title
- '((((type tty pc) (class color) (background light))
- :foreground "green" :weight bold :underline t)
- (((type tty pc) (class color) (background dark))
- :foreground "yellow" :weight bold :underline t)
- (t :height 1.5 :inherit docbook-section-title))
- "Face for DocBook chapter titles."
- :group 'docbook)
-
-(defface docbook-section-title
- '((((type tty pc) (class color))
- :foreground "lightblue" :weight bold :underline t)
- (t :height 1.2 :inherit docbook-subsection-title))
- "Face for DocBook section titles."
- :group 'docbook)
-
-(defface docbook-subsection-title
- '((t :weight bold :height 1.1 :inherit variable-pitch))
- "Face for DocBook subsection titles."
- :group 'docbook)
-
-(defface docbook-misc-title '((t :weight bold :underline t))
- "Face for miscellaneous DocBook titles."
- :group 'docbook)
-
-(defvar docbook-title-markup-alist
- '((book . docbook-chapter-title)
- (chapter . docbook-chapter-title)
- (sect1 . docbook-section-title)
- (sect2 . docbook-subsection-title)
- (sect3 . docbook-subsection-title)
- (sect4 . docbook-subsection-title)
- (sect5 . docbook-subsection-title)
- (section . docbook-section-title)
- (simplesect . docbook-section-title))
- "Alist mapping DocBook section types to title faces")
-
-(defvar docbook-text-markup-alist
- '((emphasis . docbook-emphasis)
- (foreignphrase . docbook-emphasis)
- (firstterm . docbook-emphasis)
- (bridgehead . docbook-section-title)
- (refname . docbook-section-title)
- (refpurpose . docbook-emphasis)
- (citetitle . docbook-citation)
- (subscript . docbook-small)
- (superscript . docbook-small)
- (replaceable . docbook-replaceable)
- ;; Computer output
- (accel . docbook-computer)
- (computeroutput . docbook-computer)
- (guibutton . docbook-computer)
- (guiicon . docbook-computer)
- (guilabel . docbook-computer)
- (guimenu . docbook-computer)
- (guimenuitem . docbook-computer)
- (guisubmenu . docbook-computer)
- (keycap . docbook-computer)
- (keycode . docbook-computer)
- (keycombo . docbook-computer)
- (keysym . docbook-computer)
- (markup . docbook-computer)
- (menuchoice . docbook-computer)
- (mousebutton . docbook-computer)
- (msgset . docbook-computer)
- (prompt . docbook-computer)
- (shortcut . docbook-computer)
- (tag . docbook-computer)
- (userinput . docbook-computer)
- ;; Computer terminology
- (application . docbook-computer-term)
- (classname . docbook-computer-term)
- (command . docbook-computer-term)
- (constant . docbook-computer-term)
- (database . docbook-computer-term)
- (envar . docbook-computer-term)
- (errorcode . docbook-computer-term)
- (errorname . docbook-computer-term)
- (errortype . docbook-computer-term)
- (filename . docbook-computer-term)
- (function . docbook-computer-term)
- (hardware . docbook-computer-term)
- (option . docbook-computer-term)
- (optional . docbook-computer-term)
- (parameter . docbook-computer-term)
- (property . docbook-computer-term)
- (returnvalue . docbook-computer-term)
- (symbol . docbook-computer-term)
- (systemitem . docbook-computer-term)
- (token . docbook-computer-term)
- (type . docbook-computer-term)
- (varname . docbook-computer-term)
- ;; docbook-literal
- (literal . docbook-literal)
- ;; Admonitions
- (caution . docbook-warning)
- (important . docbook-emphasis)
- (tip . docbook-emphasis)
- (warning . docbook-warning))
- "Alist mapping DocBook element types to markup faces.")
-
-(defvar docbook-page-types
- '(acknowledgements appendix article bibliography book chapter colophon
- dedication glossary part preface sect1 sect2 sect3 sect4 sect5
- section set setindex toc)
- "List of DocBook sectioning element types.
-DocBook mode shows one section at a time, as a single page.")
-
-(defvar docbook-block-types
- '(para simpara formalpara equation informalequation
- informalexample figure informalfigure
- blockquote epigraph msgset sidebar
- bridgehead caution important note tip warning
- cmdsynopsis)
- "List of DocBook block types which require no additional processing.")
-
-(defvar docbook-list-types
- '(calloutlist bibliolist glosslist itemizedlist orderedlist
- segmentedlist simplelist variablelist qandaset
- task procedure substeps)
- "List of DocBook block-level list types")
-
-(defvar docbook-literal-block-types
- '(address literallayout programlisting screen screenco
- screenshot synopsis)
- "List of DocBook block element types which preserve whitespace.")
-
-(defvar docbook-suppressed-types
- '(comment info bookinfo chapterinfo sectioninfo articleinfo label
- refmeta refclass)
- "List of DocBook element types which are not printed.")
-
-(defvar docbook-index-separator-column 30
- "Column number of xrefs printed by `docbook--print-index'.")
-
-(defvar docbook-entity-alist
- ;; makeinfo emits these entities, even though the DocBook spec does
- ;; not appear to define them.
- '(("lsquo" . "`")
- ("rsquo" . "'")
- ("ldquo" . "\"")
- ("rdquo" . "\"")
- ("copy" . "(C)")
- ("tex" . "TeX")
- ("latex" . "LaTeX")
- ("hellip" . "...")
- ("period" . ".")
- ("minus" . "-")
- ("colon" . ":")
- ("mdash" . "--")
- ("ndash" . "-"))
- "Alist mapping XML entities to their replacement text.
-These elements are added to `xml-entity-alist' while parsing
-DocBook documents.")
-
-;;; Buffer setup
-
-(defvar docbook--parse-tree nil
- "Parse tree of the current DocBook document.")
-
-(defvar docbook--id-table nil
- "Hash table mapping DocBook IDs (symbols) to node contents.
-Each key should be a Lisp symbol. Each XML node with an XML ID
-is keyed by an interned Lisp symbol with a matching symbol name.
-Sectioning (page) nodes which lack their own XML IDs are keyed
-using uninterned Lisp symbols created when parsing the XML tree.
-
-Each hash table value has one of these two forms:
-
- (NODE TITLE-NODE PARENT-ID PREV NEXT SUBSECTIONS)
- (NODE TITLE-NODE PARENT-ID)
-
-The first represents a node corresponding to a DocBook section,
-which is displayed as a separate page in the DocBook reader.
-The second represents a node which does not correspond to a
-DocBook section, e.g. a position within a section for a
-cross-reference to jump to.
-
-NODE is the Lisp list tree corresponding to the XML node.
-TITLE-NODE is the node corresponding to the node's title (a
-string), or nil.
-PARENT-ID is the ID of the node's parent page, or nil.
-PREV and NEXT are the IDs of the previous and next page.
-SUBSECTIONS is a list of IDs of child pages.")
-
-(defvar docbook-id-markers-alist nil
- "Alist mapping DocBook node IDs to markers.
-Each key should be a Lisp symbol, but it is not required to be
-one of the keys in `docbook--id-table'. This alist is used to
-record the positions of xref'ed elements on the current page.")
-
-(defvar docbook-top-page nil
- "ID of the topmost (root) page in the current DocBook document.
-The value should be one of the keys in `docbook--id-table'.")
-
-(defvar docbook-current-page nil
- "ID of the current DocBook page.
-The value should be one of the keys in `docbook--id-table'.")
-
-(defvar docbook--last-page-registered)
-(defvar docbook--last-page-id-registered)
-(defvar docbook--footnotes)
-(defvar docbook--indent-level 0)
-(defvar docbook--list-context nil)
-
-(defvar docbook--index-alist nil
- "Alist mapping index types to index data.
-Each list element has the form (TYPE . ALIST), where TYPE is a
-symbol specifying the index type (nil for the default index) and
-ALIST is an alist (TERM . ID-LIST).")
-
-(defvar docbook-history nil
- "List of DocBook node IDs which were previously viewed.")
-
-(defvar docbook-history-forward nil
- "List of DocBook node IDs visited with `docbook-history-back'.")
-
-;; Used in place of the interned version of the string "nil".
-(defconst docbook--nil (make-symbol "nil"))
-
-(defun docbook-setup (parse-tree)
- "Set up a DocBook buffer using the XML parse tree PARSE-TREE.
-PARSE-TREE should be a list of the sort returned by
-`xml-parse-file' or `xml-parse-buffer'."
- (docbook-mode)
- (setq docbook--parse-tree parse-tree
- docbook--id-table (make-hash-table :test 'eq)
- docbook--index-alist nil
- docbook-history nil
- docbook-history-forward nil)
- (let ((docbook--last-page-registered nil)
- (docbook--last-page-id-registered nil))
- (docbook-register-node parse-tree nil nil))
- ;; Sort indices
- (dolist (index docbook--index-alist)
- (setcdr index (sort (cdr index) (lambda (a b)
- (string< (car a) (car b)))))
- (dolist (entry (cdr index))
- (setcdr entry (nreverse (cdr entry))))))
-
-;;; Utility functions
-
-(defsubst docbook--node-record (&optional node-id)
- "Return the record keyed by NODE-ID in `docbook--id-table'.
-If NODE-ID is nil, it defaults to ID of the current page."
- (gethash (or node-id docbook-current-page) docbook--id-table))
-
-(defsubst docbook-add-fragment-link (id)
- "If ID is non-nil, add a marker for it to `docbook-id-markers-alist'."
- (if id (push (cons id (point-marker)) docbook-id-markers-alist)))
-
-(defun docbook--attr (attribute node)
- "Return the value of attribute ATTRIBUTE in xml node NODE.
-The value is automatically converted to a Lisp symbol. If the
-node lacks the specified attribute, return nil."
- (let ((str (cdr (assq attribute (xml-node-attributes node)))))
- (and (stringp str)
- (not (equal str ""))
- (if (equal str "nil") docbook--nil (intern str)))))
-
-(defun docbook--display-string (base-string fallback)
- "Return a string which displays as BASE-STRING on graphical terminals.
-Use a display property so that on non-graphical terminals, the
-string displays as the FALLBACK string."
- (propertize base-string
- 'display `(when (not (display-graphic-p)) . ,fallback)))
-
-(defun docbook--node-text (node)
- "Return the contents of the DocBook node NODE, as a string."
- (let ((str (mapconcat
- (lambda (x)
- (cond ((stringp x)
- (if (string-match "\\`\\s-+\\'" x) "" x))
- ((consp x)
- (docbook--node-text x))))
- (xml-node-children node)
- "")))
- (if (string-match "\\`\\s-+" str)
- (setq str (substring str (match-end 0))))
- (if (string-match "\\s-+\\'" str)
- (setq str (substring str 0 (match-beginning 0))))
- str))
-
-(defun docbook--print-block-delimiter ()
- "Insert newlines for the start or end of a DocBook block element."
- (cond
- ((bobp))
- ((looking-back "\n\n"))
- ((eq (char-before) ?\n) (insert ?\n))
- (t (insert "\n\n"))))
-
-(defun docbook--print-string (str &optional literal face)
- "Insert STR (a string) at point, unless it is useless whitespace.
-If LITERAL is non-nil, preserve whitespace. If FACE is non-nil,
-apply it as the face for the inserted text."
- (cond ((or literal (not (string-match "\\`\\s-+\\'" str)))
- (insert (propertize str 'font-lock-face face)))
- ((not (or (bolp) (memq (char-before) '(?\s ?\t))))
- (insert " "))))
-
-(defun docbook--merge-face (base-face face)
- "Return a face or list of faces, by merging BASE-FACE and FACE."
- (cond
- ((null base-face) face)
- ((null face) base-face)
- ((eq face base-face) base-face)
- (t
- (append (if (consp face) face (list face))
- (if (consp base-face) base-face (list base-face))))))
-
-(defun docbook--node-face (base-face type &optional parent)
- "Return a face suitable for displaying DocBook node type TYPE.
-BASE-FACE is the face specified by the node's parent elements.
-If PARENT is non-nil, treat TYPE as the type of the parent node,
-and assume that we are looking up the face of a title node."
- (let ((face (if parent
- (or (cdr (assq type docbook-title-markup-alist))
- 'docbook-misc-title)
- (cdr (assq type docbook-text-markup-alist)))))
- (docbook--merge-face base-face face)))
-
-;;; Parsing the DocBook XML tree
-
-(defun docbook-register-node (node parent-page-id parent-node-id)
- "Register NODE.
-NODE should be a cons cell---a subnode of the tree returned by
-`xml-parse-file'. PARENT is the registered node ID of the parent
-page (a symbol). PARENT-NODE-ID is the registered node ID of the
-node's immediate parent (which may or may not correspond to a
-page node), or nil if the parent has no ID.
-
-If NODE is a page node, return its registered node ID (a symbol).
-Otherwise, return nil."
- (let ((type (xml-node-name node)))
- (cond
- ((eq type 'comment))
- ((eq type 'indexterm)
- (docbook--register-indexterm node parent-page-id))
- ((memq type docbook-page-types)
- (docbook--register-page-node node parent-page-id))
- (t
- (docbook--register-nonpage-node node parent-page-id
- parent-node-id)))))
-
-(defun docbook--register-indexterm (node parent-id)
- (let ((id (docbook--attr 'id node)))
- (if id (puthash id `(,node nil ,parent-id) docbook--id-table))
- ;; HACK: Modify the XML tree to add an indexterm id (a symbol).
- (setq id (make-symbol "indexterm"))
- (setcar (cdr node) (cons (cons 'docbook-indexterm-id id)
- (xml-node-attributes node)))
- (puthash id `(,node nil ,parent-id) docbook--id-table)
- (let* ((type (docbook--attr 'type node))
- (index (assq type docbook--index-alist)))
- ;; If there is no index of the indicated type yet, add it.
- (unless index
- (setq docbook--index-alist
- (cons (setq index (cons type nil))
- docbook--index-alist)))
- (dolist (subnode (xml-node-children node))
- (cond
- ((not (consp subnode)))
- ((memq (xml-node-name subnode) '(primary secondary tertiary))
- (let* ((term (docbook--node-text subnode))
- (entry (assoc term (cdr index))))
- (if entry
- (setcdr entry (cons id (cdr entry)))
- (setcdr index (cons (list term id) (cdr index))))))))
- nil)))
-
-(defun docbook--register-page-node (node parent-id)
- (let ((id (docbook--attr 'id node)))
- ;; If there is no ID, generate an uninterned symbol as the ID.
- (unless id
- (setq id (make-symbol "Unnamed section")))
- (unless parent-id
- (setq docbook-top-page id))
- ;; Make the node record and update the NEXT record of the last node
- ;; processed. This must be done before descending into the tree.
- (if docbook--last-page-registered
- (setcar (nthcdr 4 docbook--last-page-registered) id))
- (let ((record (list node nil parent-id
- docbook--last-page-id-registered nil nil)))
- (setq docbook--last-page-registered record
- docbook--last-page-id-registered id)
- ;; Add the entry for this page node into the hash table.
- (if id (puthash id record docbook--id-table))
- ;; Descend into the children, registering them.
- (let ((subnodes
- (mapcar (lambda (subnode)
- (when (consp subnode)
- (docbook-register-node subnode id id)))
- (xml-node-children node))))
- ;; If this is a section node, update its record with the IDs of
- ;; the subsections, then return the ID of this node.
- (setcar (nthcdr 5 record) (delq nil subnodes))))
- id))
-
-(defun docbook--register-nonpage-node (node parent-page-id parent-node-id)
- (let ((id (docbook--attr 'id node)))
- ;; If this is a title node, register it in the parent node.
- (when (and (eq (xml-node-name node) 'title) parent-node-id)
- (let ((parent-record (docbook--node-record parent-node-id)))
- (if parent-record (setcar (cdr parent-record) node))))
- ;; Construct the node record.
- (if id (puthash id `(,node nil ,parent-page-id) docbook--id-table))
- ;; Descend into the children, registering them.
- (dolist (subnode (xml-node-children node))
- (when (consp subnode)
- (docbook-register-node subnode parent-page-id id)))
- nil))
-
-;;; Rendering DocBook
-
-(defun docbook-print-page (node-id &optional error-msg norecord)
- "Print the DocBook section corresponding to NODE-ID.
-If NODE-ID is not a registered DocBook section node, signal an
-error. The optional argument ERROR-MSG, if non-nil, specifies a
-default error message.
-
-If optional argument NORECORD is non-nil, do not record this node
-in `docbook-history'."
- (let ((node-record (when (and node-id (symbolp node-id))
- (docbook--node-record node-id))))
- (unless node-record
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- (or error-msg "Node not found")))
- (unless norecord
- (push node-id docbook-history)
- (setq docbook-history-forward nil))
- (if (= (length node-record) 3)
- ;; If the id points to a page fragment, visit the parent page
- ;; and jump to the relevant marker within that page.
- (progn
- (docbook-print-page (nth 2 node-record) nil t)
- (docbook--visit-xref-marker node-id))
- ;; If the id points to a page, visit it.
- (let* ((inhibit-read-only t)
- (node (car node-record))
- (subsections (nth 5 node-record))
- (docbook--footnotes nil))
- (erase-buffer)
- ;; Add a fragment marker to the top of this page.
- (setq docbook-id-markers-alist nil
- docbook-current-page node-id)
- (docbook-add-fragment-link node-id)
- ;; Each section contains any number of blocks followed by any
- ;; number of subsections. Loop over subnodes, printing
- ;; block-level nodes.
- (dolist (subnode (xml-node-children node))
- (cond ((null subnode))
- ((stringp subnode)
- (docbook--print-string subnode))
- ((not (memq (xml-node-name subnode) docbook-page-types))
- (docbook--print-node subnode (xml-node-name node)))))
- ;; If there are footnotes, print them.
- (docbook--print-footnotes)
- ;; If there are subsections, print a submenu.
- (when subsections
- (docbook--print-block-delimiter)
- (docbook--print-string "Menu" nil 'docbook-misc-title)
- (insert "\n")
- (let ((bullet (docbook--display-string "• " "* "))
- opoint)
- (dolist (id subsections)
- (setq opoint (point))
- (insert bullet)
- (docbook-insert-xref id)
- (insert ?\n)
- (put-text-property opoint (point) 'docbook-menu-xref id))))
- (goto-char (point-min))))))
-
-(defun docbook--print-node (node parent-type &optional literal face)
- "Insert the contents of NODE at point.
-NODE should be a cons cell---a subnode of the tree returned by
-`xml-parse-file'. PARENT-TYPE should be the node type of the
-parent node (a symbol), or nil if this is the topmost node.
-
-Optional arg LITERAL, if non-nil, means to preserve whitespace
-and newlines when printing this node.
-
-Optional arg FACE, if non-nil, should be a face or list of faces
-to use, by default, for printing this node. The node may apply
-additional markup on top to of the specified FACE."
- (let ((type (xml-node-name node)))
- (cond
- ((memq type docbook-suppressed-types)
- (docbook-add-fragment-link (docbook--attr 'id node)))
- ((eq type 'title)
- (docbook--print-block node literal
- (docbook--node-face face parent-type t)))
- ((progn
- ;; For the sake of all the remaining node types, set FACE to
- ;; the markup face for this node's type.
- (setq face (docbook--node-face face type))
- (memq type docbook-block-types))
- (docbook--print-block node literal face))
- ((progn
- ;; For the sake of all remaining node types, apply the
- ;; fragment ID if any.
- (docbook-add-fragment-link (docbook--attr 'id node))
- (eq type 'xref))
- (docbook--print-xref node literal face))
- ;; Index handling
- ((eq type 'indexterm)
- (docbook-add-fragment-link
- (cdr (assq 'docbook-indexterm-id (xml-node-attributes node)))))
- ((eq type 'index)
- (docbook--print-index (docbook--attr 'type node)))
- ;; Refentry and friends
- ((eq type 'refnamediv)
- (docbook--print-refnamediv node literal face))
- ((eq type 'refsynopsisdiv)
- (docbook--print-refsynopsisdiv node literal face))
- ;; List handling
- ((memq type docbook-list-types)
- (docbook--print-list node literal face))
- ((memq type '(listitem question answer step))
- (docbook--print-listitem node literal face))
- ((memq type '(term glossterm))
- (docbook--print-term node literal face))
- ;; Cross References
- ((memq type '(link ulink))
- (docbook--print-link node literal face))
- ((eq type 'email)
- (docbook--print-email node literal face))
- ;; Misc markup
- ((eq type 'quote)
- (docbook--print-string (docbook--display-string "“" "`")
- literal face)
- (docbook--print-children node literal face)
- (docbook--print-string (docbook--display-string "”" "'")
- literal face))
- ((eq type 'footnote)
- (docbook--print-footnote-tag node))
- ((eq type 'subscript)
- (docbook--print-with-display-prop node literal face '(raise -0.2)))
- ((eq type 'superscript)
- (docbook--print-with-display-prop node literal face '(raise 0.2)))
- ((eq type 'arg)
- (docbook--print-arg node literal face))
- ((eq type 'anchor))
- (t
- (docbook--print-children node literal face)))))
-
-(defun docbook--print-block (node literal face)
- (docbook--print-block-delimiter)
- (let* ((type (xml-node-name node))
- (beg (point)))
- ;; If the block has an ID tag, apply it.
- (docbook-add-fragment-link (docbook--attr 'id node))
- ;; Print the contents of the block.
- (docbook--print-children node literal
- (docbook--node-face face type))
- (unless literal
- ;; Flush the beginning of the block to column zero, and fill.
- (let ((stop (point)))
- (save-excursion
- (goto-char beg)
- (skip-chars-forward "[:space:]" stop)
- (delete-region beg (point))
- (setq beg (point))))
- (let ((left-margin docbook--indent-level))
- (fill-region-as-paragraph beg (point))))
- (docbook--print-block-delimiter)))
-
-(defun docbook--print-list (node literal face)
- (docbook--print-block-delimiter)
- (let ((type (xml-node-name node))
- (docbook--indent-level docbook--indent-level)
- (docbook--list-context docbook--list-context))
- (cond
- ((memq type '(procedure substeps))
- ;; We use a version list to denote (sub)steps.
- (let* ((version (if (eq (car-safe docbook--list-context) 'procedure)
- (append (cdr docbook--list-context) '(1))
- '(1)))
- (str (mapconcat 'int-to-string version ".")))
- (setq docbook--indent-level (+ (length str) 3 docbook--indent-level)
- docbook--list-context (cons 'procedure version))))
- ((eq type 'orderedlist)
- (setq docbook--indent-level (+ 4 docbook--indent-level)
- docbook--list-context 1))
- ((memq type '(glosslist variablelist))
- (setq docbook--indent-level (+ 4 docbook--indent-level)
- docbook--list-context 'variablelist))
- ((eq type 'qandaset)
- (let ((label (docbook--attr 'defaultlabel node)))
- (setq docbook--indent-level (+ 4 docbook--indent-level)
- docbook--list-context (cons 'qandaset label))))
- (t
- (setq docbook--indent-level (+ 2 docbook--indent-level)
- docbook--list-context 'itemizedlist)))
- (docbook--print-children node literal face))
- (docbook--print-block-delimiter))
-
-(defun docbook--print-term (node literal face)
- (when (eq docbook--list-context 'variablelist)
- (unless (eq (char-before) ?\n)
- (insert "\n"))
- (let ((opoint (point)))
- (docbook--print-children node literal face)
- (save-excursion
- (let ((stop (point)))
- (goto-char opoint)
- (skip-chars-forward "[:space:]" stop)
- (delete-region opoint (point))
- (indent-line-to (- docbook--indent-level 4))
- (docbook--print-string (docbook--display-string "• " "* ")
- literal face))))))
-
-(defun docbook--print-listitem (node literal face)
- (let ((opoint (point)))
- (docbook--print-children node literal face)
- (when (not (memq docbook--list-context '(nil variablelist)))
- (cond
- ;; A step in a procedure
- ((eq (car-safe docbook--list-context) 'procedure)
- (let* ((version (cdr docbook--list-context))
- (str (concat (mapconcat 'int-to-string version ".") ". "))
- (subversion (nthcdr (1- (length version)) version)))
- (docbook--print-listitem-1 opoint str (length str)
- literal face)
- (setcar subversion (1+ (car subversion)))))
- ;; Question or answer
- ((eq (car-safe docbook--list-context) 'qandaset)
- (let ((subnodes (xml-node-children node))
- label)
- ;; Look for a label for the question or answer.
- (while (and (null label) subnodes)
- (when (and (consp (car subnodes))
- (eq (xml-node-name (car subnodes)) 'label))
- (setq label (docbook--node-text (car subnodes))))
- (setq subnodes (cdr subnodes)))
- ;; If there is none, consult the default label.
- (and (not (stringp label))
- (eq (cdr docbook--list-context) 'qanda)
- (setq label (if (eq (xml-node-name node) 'question)
- "Q:"
- "A:")))
- (if (null label)
- ;; Use a bullet, like an itemizedlist.
- (docbook--print-listitem-1
- opoint (docbook--display-string "• " "* ") 2 literal face)
- (docbook--print-listitem-1
- opoint label 0 literal
- (docbook--merge-face face 'docbook-label) " " face))))
- ;; orderedlist
- ((integerp docbook--list-context)
- (docbook--print-listitem-1
- opoint (format "%2d. " docbook--list-context) 4 literal face)
- (setq docbook--list-context (1+ docbook--list-context)))
- ;; itemizedlist
- (t
- (docbook--print-listitem-1
- opoint (docbook--display-string "• " "* ") 2 literal face))))))
-
-(defun docbook--print-listitem-1 (opoint bullet bullet-len literal face
- &optional after-string after-string-face)
- (save-excursion
- (let ((stop (point)))
- (goto-char opoint)
- (skip-chars-forward "[:space:]" stop)
- (indent-line-to (- docbook--indent-level bullet-len))
- (docbook--print-string bullet literal face)
- (if after-string
- (docbook--print-string after-string literal
- after-string-face)))))
-
-(defun docbook--print-footnote-tag (node)
- (when (boundp 'docbook--footnotes)
- (let ((n (1+ (length docbook--footnotes)))
- (tag-id (make-symbol "footnote-id"))
- (footnote-id (make-symbol "footnote")))
- (docbook-add-fragment-link tag-id)
- (docbook-insert-xref footnote-id (format "(%d)" n))
- (push (list tag-id footnote-id node) docbook--footnotes))))
-
-(defun docbook--print-footnotes ()
- (when (bound-and-true-p docbook--footnotes)
- (docbook--print-block-delimiter)
- (docbook--print-string "--- Footnotes ---")
- (let ((n 1) opoint)
- (dolist (footnote (nreverse docbook--footnotes))
- (docbook--print-block-delimiter)
- (setq opoint (point))
- (docbook--print-children (nth 2 footnote))
- (save-excursion
- (goto-char opoint)
- (if (eq (char-after) ?\n) (forward-char))
- (docbook-add-fragment-link (nth 1 footnote))
- (docbook-insert-xref (car footnote) (format "(%d)" n))
- (insert " "))
- (setq n (1+ n))))))
-
-(defun docbook--print-with-display-prop (node literal face prop)
- (let ((opoint (point)))
- (docbook--print-children node literal face)
- (put-text-property opoint (point) 'display prop)))
-
-(defun docbook--print-children (node &optional literal face)
- "Print the child nodes of the DocBook node NODE.
-LITERAL and FACE mean the same as in `docbook--print-node'."
- (dolist (subnode (xml-node-children node))
- (cond
- ((null subnode))
- ((stringp subnode)
- (docbook--print-string subnode literal face))
- (t
- (docbook--print-node subnode (xml-node-name node)
- literal face)))))
-
-(defun docbook--print-refnamediv (node literal face)
- (docbook--print-block-delimiter)
- (let (names purpose)
- (dolist (subnode (xml-node-children node))
- (cond ((not (consp subnode)))
- ((eq (xml-node-name subnode) 'refname)
- (push subnode names))
- ((eq (xml-node-name subnode) 'refpurpose)
- (setq purpose subnode))))
- (setq names (nreverse names))
- (indent-to docbook--indent-level)
- (while names
- (docbook--print-node (car names) 'refnamediv literal face)
- (setq names (cdr names))
- (if names (docbook--print-string ", " literal face)))
- (when purpose
- (or (eq (char-before) ?\n) (insert ?\n))
- (indent-to docbook--indent-level)
- (docbook--print-node purpose literal face)))
- (docbook--print-block-delimiter))
-
-(defun docbook--print-refsynopsisdiv (node literal face)
- (docbook--print-block-delimiter)
- (indent-to docbook--indent-level)
- (docbook--print-string "Synopsis" nil 'docbook-misc-title)
- (docbook--print-block-delimiter)
- (docbook--print-children node literal face))
-
-(defun docbook--print-arg (node literal face)
- (let ((choice (docbook--attr 'choice node))
- (repeat (docbook--attr 'rep node)))
- (if (eq choice 'opt)
- (docbook--print-string "[ " literal face))
- (docbook--print-children node literal face)
- (if (eq choice 'opt)
- (docbook--print-string " ]" literal face))
- (if (eq repeat 'repeat)
- (docbook--print-string "..." literal face))))
-
-;;; Cross-reference handling
-
-(defun docbook--print-xref (node literal face)
- "Insert the contents of an xref node NODE."
- (let ((target (docbook--attr 'linkend node)))
- (when target
- (let ((endterm (docbook--attr 'endterm node)))
- ;; If an endterm attribute is present, print its contents.
- ;; FIXME: protect against a recursion bomb.
- (if (and endterm
- (setq endterm (car (docbook--node-record endterm))))
- (docbook--print-link endterm literal face target)
- (docbook-insert-xref target))))))
-
-(defun docbook--print-link (node literal face &optional linkend)
- "Insert the contents of a link node NODE."
- (let ((target (or linkend (docbook--attr 'linkend node)))
- (opoint (point))
- (action 'docbook-xref-button-action))
- (unless target
- ;; If there is no linkend attribute, look for an external URL.
- (let ((attributes (xml-node-attributes node)))
- (setq target
- (or (cdr (assq 'xlink:href attributes))
- (cdr (assq 'href attributes))
- ;; Used by obsolete `url' elements.
- (cdr (assq 'url attributes))))
- (setq action 'docbook-link-button-action)))
- (docbook--print-children node literal face)
- (make-text-button opoint (point)
- 'action action
- 'docbook-target target)))
-
-(defun docbook--print-email (node literal face)
- "Insert the contents of a link node NODE."
- (let ((opoint (point)))
- (docbook--print-children node literal face)
- (make-text-button opoint (point)
- 'action 'docbook-email-button-action)))
-
-(defun docbook-insert-xref (node-id &optional label)
- "Insert a cross reference to NODE-ID at point.
-NODE-ID should be a node ID, as either a symbol or a string.
-LABEL, if non-nil, specifies the text label."
- (unless label
- (setq label (docbook-node-label node-id)))
- (insert-text-button label
- 'action 'docbook-xref-button-action
- 'docbook-target node-id))
-
-(defun docbook-node-label (node-id)
- "Return an appropriate label for the node with ID NODE-ID."
- (let* ((record (docbook--node-record node-id))
- (attributes (xml-node-attributes (car record)))
- ;; Use the target node's xreflabel attribute.
- (label (cdr (assq 'xreflabel attributes))))
- (when (memq label '(nil ""))
- ;; Otherwise, use the target node's title.
- (setq label (and (nth 1 record)
- (docbook--node-text (nth 1 record))))
- (when (memq label '(nil ""))
- ;; Otherwise, default to the node ID's name.
- (setq label (symbol-name node-id))))
- label))
-
-(defun docbook--visit-xref-marker (node-id &optional noerror)
- "Visit the position of NODE-ID on the current DocBook page.
-Return non-nil if we found the element and jumped to it.
-Otherwise, signal an error if NOERROR is nil, and return nil if
-NOERROR is non-nil."
- (let ((marker (cdr (assq node-id docbook-id-markers-alist))))
- (cond
- ((markerp marker)
- (goto-char marker))
- ((null noerror)
- (error "Node not found")))))
-
-(defun docbook-visit-xref (node-id)
- (or (docbook--visit-xref-marker node-id t)
- (docbook-print-page node-id)))
-
-(defun docbook-xref-button-action (button)
- "Visit the DocBook node indicated by BUTTON."
- (docbook-visit-xref (button-get button 'docbook-target)))
-
-(defun docbook-link-button-action (button)
- "Call `browse-url' to visit the link indicated by BUTTON."
- (let ((target (button-get button 'docbook-target)))
- (if (string-match "\\`mailto:"; target)
- (compose-mail (substring-no-properties target (match-end 0)))
- (browse-url (button-get button 'docbook-target)))))
-
-(defun docbook-email-button-action (button)
- "Send mail to the address indicated by BUTTON."
- (compose-mail (buffer-substring-no-properties
- (button-start button) (button-end button))))
-
-;; Printing the index and history list
-
-(defun docbook--print-index (type)
- "Insert the DocBook index of type TYPE at point."
- (let ((index (assq type docbook--index-alist))
- (bullet (docbook--display-string "• " "* "))
- opoint)
- (unless (eq (char-before) ?\n) (insert ?\n))
- (dolist (entry (cdr index))
- (setq opoint (point))
- (insert bullet)
- (insert (car entry))
- (let* ((ids (cdr entry))
- (id (car ids)))
- (indent-to docbook-index-separator-column 2)
- (docbook-insert-xref
- id (docbook-node-label (nth 2 (docbook--node-record id))))
- (insert ?\n)
- (put-text-property opoint (point) 'docbook-menu-xref id)
- (if (> (length ids) 1)
- (dolist (id (cdr ids))
- (setq opoint (point))
- (indent-to docbook-index-separator-column 2)
- (docbook-insert-xref
- id (docbook-node-label
- (nth 2 (docbook--node-record id))))
- (insert ?\n)
- (put-text-property opoint (point) 'docbook-menu-xref id)))))
- (insert ?\n)))
-
-(defun docbook--print-history ()
- "Insert the DocBook navigation history menu at point."
- (let ((bullet (docbook--display-string "◦ " "* ")))
- (dolist (id (reverse (cdr docbook-history)))
- (unless (eq (char-before) ?\n) (insert ?\n))
- (insert bullet)
- (docbook-insert-xref id))
- ;; Indicate the current page with a more prominent bullet.
- (unless (eq (char-before) ?\n) (insert ?\n))
- (insert (docbook--display-string "• " "* "))
- (docbook-insert-xref (car docbook-history))
- (dolist (id docbook-history-forward)
- (unless (eq (char-before) ?\n) (insert ?\n))
- (insert bullet)
- (docbook-insert-xref id))
- (insert ?\n)))
-
-;;; Major mode
-
-(defvar docbook-mode-map
- (let ((map (make-keymap)))
- (set-keymap-parent map (make-composed-keymap button-buffer-map
- special-mode-map))
- (define-key map "." 'beginning-of-buffer)
- (define-key map " " 'docbook-scroll-up)
- (define-key map "\177" 'docbook-scroll-down)
- (define-key map "\C-m" 'docbook-follow-nearest-node)
-
- (dotimes (n 9)
- (define-key map (number-to-string (1+ n)) 'docbook-nth-menu-item))
-
- (define-key map "b" 'beginning-of-buffer)
- (define-key map "e" 'end-of-buffer)
- (define-key map "\M-n" 'clone-buffer)
-
- (define-key map "i" 'docbook-index)
- (define-key map "I" 'docbook-index)
- (define-key map "l" 'docbook-history-back)
- (define-key map "r" 'docbook-history-forward)
- (define-key map "L" 'docbook-history)
-
- (define-key map "]" 'docbook-forward-page)
- (define-key map "[" 'docbook-backward-page)
- (define-key map "n" 'docbook-forward-page)
- (define-key map "p" 'docbook-backward-page)
-
- ;; (define-key map "f" 'docbook-follow-reference)
- ;; (define-key map "g" 'docbook-goto-node)
- ;; (define-key map "m" 'docbook-menu)
-
- ;; (define-key map "s" 'docbook-search)
- ;; (define-key map "S" 'docbook-search-case-sensitively)
- ;; (define-key map "T" 'docbook-toc)
- ;; (define-key map "," 'docbook-index-next)
-
- (define-key map "t" 'docbook-top-page)
- (define-key map "u" 'docbook-up)
- (define-key map "^" 'docbook-up)
- (define-key map [follow-link] 'mouse-face)
- map)
- "Keymap containing DocBook commands.")
-
-(define-derived-mode docbook-mode special-mode "DocBook"
- "Major mode for viewing DocBook documents.
-Type \\[docbook-find-file] to visit DocBook files for viewing.
-Most of the commands in DocBook mode are similar to Info mode.
-
-DocBook documents are divided into \"section nodes\" (which
-includes chapters, sections, subsections, etc.). DocBook mode
-displays one section node at a time, as a single page.
-Navigation commands and hyperlinks can be used to view other
-pages.
-
-Moving within a page:
-\\[docbook-scroll-up] Normally, scroll forward a full screen.
- If you have scrolled to the end of this page,
- view the next page.
-\\[docbook-scroll-down] Normally, scroll backward a full screen.
- If you have scrolled to the beginning of this page,
- view the preceding page.
-\\[beginning-of-buffer] Jump to beginning of this page.
-
-Selecting other nodes:
-\\[docbook-follow-nearest-node] Follow a node reference near point.
-\\[docbook-backward-page] View the preceding page.
-\\[docbook-forward-page] View the next page.
-\\[docbook-up] View the parent of the current page.
-\\[docbook-top-page] View the topmost section of this document.
-\\[docbook-history-back] View the last page you were at.
-\\[docbook-history-forward] Move forward in history to the page you were at
before using \\[docbook-history-back].
-\\[docbook-history] View a menu of visited pages."
- (make-local-variable 'docbook--parse-tree)
- (make-local-variable 'docbook--id-table)
- (make-local-variable 'docbook-current-page)
- (make-local-variable 'docbook-top-page)
- (make-local-variable 'docbook-id-markers-alist)
- (make-local-variable 'docbook--index-alist)
- (make-local-variable 'docbook-history)
- (make-local-variable 'docbook-history-foward)
- (setq-local adaptive-fill-mode nil)
- (setq indent-tabs-mode nil)
- (setq fill-prefix nil)
- (setq use-hard-newlines t))
-
-;;; Navigation commands
-
-(defun docbook-up ()
- "View the parent of the current DocBook page."
- (interactive)
- (docbook-print-page (nth 2 (docbook--node-record)) "No parent page"))
-
-(defun docbook-top-page ()
- "View the topmost page in the current DocBook document."
- (interactive)
- (docbook-print-page docbook-top-page))
-
-(defun docbook-backward-page ()
- "View the previous DocBook page."
- (interactive)
- (docbook-print-page (nth 3 (docbook--node-record)) "No previous page"))
-
-(defun docbook-forward-page ()
- "View the next DocBook page."
- (interactive)
- (docbook-print-page (nth 4 (docbook--node-record)) "No following page"))
-
-(defun docbook-scroll-up ()
- "Scroll forward, or view the next DocBook page."
- (interactive)
- (condition-case nil
- (scroll-up nil)
- (end-of-buffer (docbook-forward-page))))
-
-(defun docbook-scroll-down ()
- "Scroll backward, or view the preceding DocBook page."
- (interactive)
- (condition-case nil
- (scroll-down nil)
- (beginning-of-buffer (docbook-backward-page))))
-
-(defun docbook-nth-menu-item ()
- "View the Nth menu item, based on the key typed."
- (interactive)
- (let ((n (- (aref (this-command-keys)
- (1- (length (this-command-keys)))) ?0))
- (node-record (docbook--node-record)))
- (unless node-record
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "No menu in this node"))
- (let ((id (nth (1- n) (nth 5 node-record))))
- (unless id
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "Too few items in menu"))
- (docbook-visit-xref id))))
-
-(defun docbook-follow-nearest-node ()
- "Follow a node reference near point.
-If point is on a reference, follow that reference. Otherwise,
-if point is in a menu item description, follow that menu item."
- (interactive)
- (let ((id (get-text-property (point) 'docbook-menu-xref)))
- (if id
- (docbook-visit-xref id)
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "Point neither in reference nor in menu item description"))))
-
-;; History commands
-
-(defun docbook-history-back (n)
- "Go back in history to the previous DocBook page viewed."
- (interactive "p")
- (dotimes (_i n)
- (unless (cdr docbook-history)
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "This is the first node you looked at"))
- (push (pop docbook-history) docbook-history-forward)
- (docbook-print-page (car docbook-history) nil t)))
-
-(defun docbook-history-forward (n)
- "Go forward in history to the next DocBook page viewed."
- (interactive "p")
- (dotimes (_i n)
- (if (null docbook-history-forward)
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "This is the last node you looked at"))
- (let ((id (pop docbook-history-forward)))
- (push id docbook-history)
- (docbook-print-page id nil t))))
-
-(defun docbook-history ()
- "Display a list of recently-visited DocBook pages."
- (interactive)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (docbook--print-string "Recently visited pages"
- nil 'docbook-chapter-title)
- (insert ?\n ?\n)
- (docbook--print-history)))
-
-;; Misc commands
-
-(defun docbook-index (type)
- "Display a list of index topics fo the current DocBook document.
-The argument TYPE is the index type; DocBook documents can define
-several indices for different topics. If called interactively,
-prompt for TYPE."
- (interactive (list (if (<= (length docbook--index-alist) 1)
- (caar docbook--index-alist)
- (completing-read
- (format "View index type%s: "
- (if (assq nil docbook--index-alist)
- " (empty input for default index)"
- ""))
- (cons "" (mapcar (lambda (x) (symbol-name (car x)))
- docbook--index-alist))
- nil t))))
- (unless (assq type docbook--index-alist)
- (funcall (if (fboundp 'user-error) 'user-error 'error)
- "Index is empty"))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (docbook--print-string (if type
- (format "Index: %s" (symbol-name type))
- "Index")
- nil 'docbook-chapter-title)
- (insert ?\n ?\n)
- (docbook--print-index type)))
-
-;;;###autoload
-(defun docbook-find-file (filename)
- "Visit FILENAME as a DocBook document."
- (interactive "fView DocBook file: ")
- (docbook-setup
- (car (let ((xml-entity-alist (append docbook-entity-alist
- xml-entity-alist)))
- (xml-parse-file filename))))
- (docbook-print-page docbook-top-page))
-
-(provide 'docbook)
-
-;;; docbook.el ends here
diff --git a/packages/ebdb-gnorb/ebdb-gnorb.el
b/packages/ebdb-gnorb/ebdb-gnorb.el
deleted file mode 100644
index f210737..0000000
--- a/packages/ebdb-gnorb/ebdb-gnorb.el
+++ /dev/null
@@ -1,230 +0,0 @@
-;;; ebdb-gnorb.el --- Utilities for connecting EBDB to Gnorb -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2016-2017 Free Software Foundation, Inc.
-
-;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
-;; Maintainer: Eric Abrahamsen <eric@ericabrahamsen.net>
-;; Version: 1.0.2
-;; Package-Requires: ((gnorb "1.1.0") (ebdb "0.2"))
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Bits and pieces useful for tying EBDB in with Gnorb. Everything in
-;; this file can be moved elsewhere.
-
-;;; Code:
-
-(require 'ebdb-format)
-(require 'ebdb-com)
-(require 'gnorb-org)
-(require 'gnorb-gnus)
-
-(autoload 'org-gnus-follow-link "org-gnus")
-(autoload 'article-lapsed-string "gnus-art")
-
-(defgroup ebdb-gnorb nil
- "Customizations for Gnorb-specific functionality."
- :group 'ebdb)
-
-(defcustom gnorb-ebdb-collect-N-messages 5
- "For records with a `ebdb-gnorb-messages-field',
-collect links to a maximum of this many messages."
-
- :group 'ebdb-gnorb
- :type 'integer)
-
-(defcustom gnorb-ebdb-define-recent 'seen
- "For records with a `gnorb-ebdb-message-tag-field',
-this variable controls how gnorb defines a \"recent\" message.
-Setting it to the symbol 'seen will collect the messages most
-recently opened and viewed. The symbol 'received means gnorb will
-collect the most recent messages by Date header.
-
-In other words, if this variable is set to `received', and a
-record's messages field is already full of recently-received
-messages, opening a five-year-old message (for instance) from
-this record will not push a link to the message into the field."
-
- :group 'ebdb-gnorb
- :type '(choice (const :tag "Most recently seen" 'seen)
- (const :tag "Most recently received" 'received)))
-
-(defcustom gnorb-ebdb-collect-by-thread t
- "When collecting links to messages, only collect one link per thread.
-
-This option won't work correctly unless `gnus-show-thread' is set
-to t; if it is nil, this option will be ignored.
-
-This also affects how links are followed: when t, following a
-link will display the whole thread."
-
- :group 'ebdb-gnorb
- :type 'boolean)
-
-(defcustom gnorb-ebdb-message-format "%:lapsed days: %:subject"
- "How a single message is formatted in the list of recent messages.
-This format string is used in multi-line record display.
-
-Available information for each message includes the subject, the
-date, and the message's count in the list, as an integer. You can
-access subject and count using the %:subject and %:count escapes.
-The message date can be formatted using any of the escapes
-mentioned in the docstring of `format-time-string', which see, or
-the escape %:lapsed, which inserts the number of days ago the
-message was received."
-
- :group 'ebdb-gnorb
- :type 'string)
-
-(defface gnorb-ebdb-link '((t :inherit org-link))
- "Custom face for displaying message links in the *BBDB* buffer.
- Defaults to org-link."
- :group 'ebdb-gnorb)
-
-;;;###autoload
-(cl-defstruct gnorb-ebdb-link
- subject date group id)
-
-;;;###autoload
-(defclass gnorb-ebdb-field-messages (ebdb-field-user)
- ((messages
- :type (list-of gnorb-ebdb-link)
- :initarg :messages
- :initform nil)
- (actions :initform '(("Follow link" . gnorb-ebdb-follow-link))))
- :human-readable "gnus messages")
-
-(defun gnorb-ebdb-follow-link (_record _field)
- (when-let ((link (or
- (get-text-property (point) 'gnorb-link)
- (get-text-property
- (ebdb-scan-property 'gnorb-link #'gnorb-ebdb-link-p 1)
- 'gnorb-link))))
- (org-gnus-follow-link (gnorb-ebdb-link-group link)
- (gnorb-ebdb-link-id link))
- (when (and gnus-show-threads
- gnorb-ebdb-collect-by-thread)
- (gnus-summary-refer-thread))))
-
-(cl-defmethod ebdb-string ((field gnorb-ebdb-field-messages))
- (format "%d messages" (length (slot-value field 'messages))))
-
-(defun ebdb-gnorb-lapsed-days (date)
- "Return the number of days between now and DATE."
- ;; Cribbed/simplified from `article-lapsed-string'. Need to handle
- ;; dates in the future, though that's stupid.
- (let* ((now (current-time))
- (delta (time-subtract now date))
- (real-sec (and delta
- (+ (* (float (car delta)) 65536)
- (cadr delta))))
- (sec (and delta (abs real-sec))))
- (floor (/ sec 86400))))
-
-(cl-defmethod ebdb-fmt-field ((_fmt ebdb-formatter-ebdb)
- (field gnorb-ebdb-field-messages)
- _style
- (_record ebdb-record))
- (let* ((msgs (slot-value field 'messages))
- (outstring
- (if (= (length msgs) 0)
- "No message yet"
- (mapconcat
- #'identity
- (let ((count 0) str)
- (mapcar
- (lambda (m)
- (setq str
- (format-time-string
- (replace-regexp-in-string
- "%:subject" (substring
- (gnorb-ebdb-link-subject m)
- 0 (min 30
- (length (gnorb-ebdb-link-subject
m))))
- (replace-regexp-in-string
- "%:count" (number-to-string (cl-incf count))
- gnorb-ebdb-message-format))
- (gnorb-ebdb-link-date m)))
- ;; Avoid doing the lapse calculation if not
- ;; necessary. Of course, this is probably more
- ;; wasteful than just doing it anyway.
- (when (string-match-p "%:lapsed" str)
- (setq str
- (replace-regexp-in-string
- "%:lapsed" (number-to-string
- (ebdb-gnorb-lapsed-days
- (gnorb-ebdb-link-date m)))
- str)))
- (propertize
- str
- 'face 'gnorb-ebdb-link
- 'gnorb-link m))
- msgs))
- "\n"))))
- outstring))
-
-(cl-defmethod ebdb-notice-field ((field gnorb-ebdb-field-messages)
- (_type (eql sender))
- (record ebdb-record))
- "Used in the `bbdb-notice' to possibly save a link
-to a message into the record's `gnorb-ebdb-messages-field'."
-
- (with-current-buffer gnus-summary-buffer
- (let* ((links (slot-value field 'messages))
- (art-no (gnus-summary-article-number))
- (heads (gnus-summary-article-header art-no))
- (date (apply 'encode-time
- (parse-time-string (mail-header-date heads))))
- (refs (gnus-extract-references (mail-header-references heads)))
- (subject (gnus-simplify-subject (mail-header-subject heads)))
- (id (mail-header-id heads))
- (group (gnorb-get-real-group-name
- gnus-newsgroup-name
- art-no))
- link)
- (if (not (and date subject id group))
- (message "Could not save a link to this message")
- (setq link (make-gnorb-ebdb-link :subject subject :date date
- :group group :id id))
- (when (and gnus-show-threads
- gnorb-ebdb-collect-by-thread)
- ;; If the new link has a ref to an earlier link, then don't
- ;; save the new link, but do update the date of the earlier
- ;; link. Ie, the new link isn't kept, but it "refreshes" the
- ;; date of the whole thread.
- (dolist (l links)
- (when (member (gnorb-ebdb-link-id l)
- refs)
- (setf (gnorb-ebdb-link-date l) date)
- ;; We can discard link.
- (setq link nil))))
- (when link
- (setq links (cons link (delete link links))))
- (when (eq gnorb-ebdb-define-recent 'received)
- (setq links (sort links
- (lambda (a b)
- (time-less-p
- (gnorb-ebdb-link-date b)
- (gnorb-ebdb-link-date a))))))
- (setq links (cl-subseq links 0 (min (length links)
- gnorb-ebdb-collect-N-messages)))
- (ebdb-record-change-field
- record field
- (make-instance 'gnorb-ebdb-field-messages
- :messages links))))))
-
-(provide 'ebdb-gnorb)
-;;; ebdb-gnorb.el ends here
diff --git a/packages/el-search/NEWS b/packages/el-search/NEWS
deleted file mode 100644
index af22f9e..0000000
--- a/packages/el-search/NEWS
+++ /dev/null
@@ -1,224 +0,0 @@
-Some of the user visible news were:
-
-
-Version: 1.12.6
-
- New command 'el-search-repository' to search the worktree or a
- specified revision of a repository.
-
-Version: 1.12.5
-
- The prefix argument of 'el-search-pattern' provides now analogue
- functionalities as for 'el-search-query-replace': It normally
- resumes the last search; 0 restarts the search and a negative or C-u
- C-u prefix arg lets you choose an older search to resume.
-
- 'el-search-jump-to-search-head' has been renamed to
- 'el-search-jump'. The meaning of the prefix arg has been limited to
- the jump-by-matches applications, everything else can now be
- accomplished with 'el-search-pattern'.
-
-Version: 1.12.4
-
- Key syntax cleanup: In some cases the code used to bind some keys
- twice: it bound events E1 and E2 where in some environments hitting
- a certain key generates E1 in in others E2 where E2 is normally
- translated into E1. For example, the code created bindings for
- "\C-j" and also for [(meta return)], although binding only "\C-j"
- would suffice because in environments where [(meta return)] is
- created it would be immediately translated to "\C-j".
-
- That means that should you add a binding for the event that is
- generated only in some environments like [(meta return)] in the
- respective key map you would get the effect that your binding
- shadows the el-search binding in some environments and in others
- not. If you experience something like that, check your init file if
- you do something like that.
-
-Version: 1.12.2
-
- Some changes to the 'el-search-query-replace' prompt to make it
- shorter. The keys o and e to show and ediff the replacement changed
- to e and E ("edit", "Ediff").
-
-Version: 1.12.1
-
- Like searches, 'el-search-query-replace' sessions are now also
- internally represented by objects with state, which means you can do
- similar things: Resuming or restarting sessions can be achieved by
- calling the command `el-search-query-replace' with a prefix arg.
- The new command 'el-search-query-replace-to-register' lets you save
- the current session to a register.
-
- The 'el-search-query-replace' user interface also got a new key "/"
- that replaces all remaining matches in the current buffer
- automatically and then suspends the session. This gives you the
- chance to check if everything is alright in that buffer before you
- continue with the next file or buffer by resuming that session.
-
-Version: 1.11.3
-
- When copying large parts of an *El Occur* buffer to the kill ring
- (large here means "includes file headlines"), or you save an
- *El Occur* buffer, matches are surrounded with --> <-- text markers
- so that they are better visible when you send the output to someone
- else, for example. This can be turned off or be configured with the
- new user option 'el-search-occur-match-markers'.
-
-Version: 1.11.1
-
- Eldoc now displays signatures of search patterns for the search
- pattern prompt.
-
- Some 'display-buffer' actions have been slightly changed.
-
-Version: 1.10.2
-
- New help command 'el-search-list-defined-patterns' listing all
- currently defined pattern types.
-
-Version: 1.10.1
-
- El-search now shows hints in the search pattern prompt when the new
- user option 'el-search-display-mb-hints' is non-nil (the default).
- This includes pointing to errors in the input and showing a match
- count preview.
-
-Version: 1.9.7
-
- Changed default binding schemes: For reasons of harmonization, in
- both searches and in el-search-occur both of basic keys s, r and n, p
- now move to the next or previous match.
-
- The default binding of 'el-search-continue-in-next-buffer' therefore
- has been moved from n to x respectively.
-
-Version: 1.9.5
-
- 'string' and derived pattern types now support expressions evaluting
- to regexps as arguments. This means you can use 'rx' to construct
- regexps in 'string' patterns, for example.
-
-Version: 1.9.0
-
- This version adds some help commands available through the C-h help
- prefix.
-
-Version: 1.8.4
-
- Quitting (C-g) while el-searching now brings you back to the
- starting point like in isearch.
-
-Version: 1.8.3
-
- `el-search-query-replace' now adds undo boundaries for each manual
- replacement so that afterwards `undo' undoes replacements
- step-by-step similar to vanilla `query-replace'.
-
-Version: 1.8
-
- Several improvements in `el-search-query-replace':
-
- It's now possible to edit the replacement in a separate buffer
- without interrupting `el-search-query-replace', and to ediff the
- current replacement with the current match (new keys 'o' and 'e').
-
- Hitting the 'r' key now toggles between replacing a match without
- moving and restoring the match.
-
- After replacing a match with 'r', the key to go to the next match
- changed from 'n' to 'y' which should feel more natural.
-
- Depending on the value of the new user option
- `el-search-query-replace-stop-for-comments',
- `el-search-query-replace' can now interrupt automatic replacement
- when it's not able to unumbigously assign comments in the current
- match to the replacement.
-
-Version: 1.7.15
-
- *El Occur* buffers are now initially unfolded.
-
-Version: 1.7.8
-
- Similar to isearch, el-search now opens invisible text.
-
-Version: 1.7.7
-
- The new scroll commands `el-search-scroll-down' and
- `el-search-scroll-up', bound to C-S-next and C-S-prior, or v and V
- respectively, perform by-match scrolling: `el-search-scroll-down'
- scrolls the next matches after `window-end' into view, i.e. it
- selects the first match after `window-end'. Likewise,
- `el-search-scroll-up' selects the last match before `window-start'.
-
- You can now explicitly terminate (pause) search and query-replace
- sessions by hitting RET.
-
-Version: 1.7.5
-
- The meaning of the prefix argument of
- `el-search-jump-to-search-head' (C-J or M-s e j with the default
- bindings) has been extended: A numeric prefix N jumps to the Nth
- match after `window-start', while a negative prefix -N jumps to the
- Nth match before `window-end'. Prefix 0 jumps to the match
- following point, which is also useful to resume the current search
- from any buffer position. A former search can now be made current
- with a plain C-u prefix arg.
-
-
-Version: 1.7.3
-
- Match highlighting faces have been improved to look better on text
- terminals. Matches in *El Occur* buffers are now highlighted with a
- separate face.
-
-Version: 1.7
-
- Signature and semantics of non-interactive function
- `el-search-forward' have been further adapted to that of the vanilla
- search function `search-forward'. The counterpart
- `el-search-backward' has been added.
-
- The new key bindings < and > let you directly jump to the first and
- to the last match in a buffer.
-
-Version: 1.6.5
-
- When the new user option `el-search-allow-scroll' is enabled (the
- default), scrolling doesn't deactivate the current el-search.
- Unlike isearch you can scroll the current match offscreen - use
- `el-search-jump-to-search-head' (C-J or M-s e j when using the
- suggested key bindings) to jump back to the current match.
-
-Version: 1.6.1
-
- New function `el-search-looking-at', the el-search version of
- `looking-at'.
-
-Version: 1.5.2
-
- The new command `el-search-to-register' allows to save the current
- search (including its state) to a register and later make that
- search current again with `jump-to-register' (C-x r j).
-
-Version: 1.5.1
-
- The new command `el-search-ibuffer-marked-buffers' el-searches the
- marked buffers in *Ibuffer*.
-
-Version: 1.5
-
- The new function `el-search-install-bindings-under-prefix' can be
- used to install repeatable versions of the el-search commands under
- a prefix key.
-
-Version: 1.4.0.15
-
- The new option value 'ask-multi for el-search-auto-save-buffers,
- which is also the new default, makes el-search only prompt for
- whether to save buffers for multi-buffer query-replace sessions.
- For single buffer sessions, no prompt, and you can/should save
- yourself. I find that behavior slightly more convenient than 'ask
- in most cases.
-
diff --git a/packages/el-search/el-search-x.el
b/packages/el-search/el-search-x.el
deleted file mode 100644
index 9840a77..0000000
--- a/packages/el-search/el-search-x.el
+++ /dev/null
@@ -1,571 +0,0 @@
-;;; el-search-x.el --- Additional pattern definitions for el-search -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2016-2020 Free Software Foundation, Inc
-
-;; Author: Michael Heerdegen <michael_heerdegen@web.de>
-;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
-;; Created: 2016_08_03
-;; Keywords: lisp
-
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; This file contains additional definitions of el-search patterns.
-;; You can just `require' this file, but doing so is not mandatory for
-;; using el-search.
-
-
-
-;;; Code:
-
-(eval-when-compile
- (require 'subr-x))
-(require 'thunk)
-(require 'el-search)
-
-
-(el-search-defpattern string-lines (pattern)
- "Matches any string whose line count is matched by PATTERN.
-
-Examples: (string-lines 1) matches one-line strings.
-\(string-lines (pred (>= 5))\) matches strings consisting of not
-more than 5 lines."
- (let ((string (make-symbol "string")))
- `(and (string)
- ,string
- (let ,pattern
- (with-temp-buffer
- (insert ,string)
- (count-lines (point-min) (point-max)))))))
-
-;;;; `append and `l'
-
-(defun el-search--split (matcher1 matcher2 list)
- "Helper for the \"append\" pattern type.
-
-When a splitting of LIST into two lists L1, L2 exist so that Li
-is matched by MATCHERi, return (L1 L2) for such Li, else return
-nil."
- (let ((try-match (lambda (list1 list2)
- (when (and (el-search--match-p matcher1 list1)
- (el-search--match-p matcher2 list2))
- (list list1 list2))))
- (list1 list) (list2 '()) (match nil))
- ;; don't use recursion, this could hit `max-lisp-eval-depth'
- (while (and (not (setq match (funcall try-match list1 list2)))
- (consp list1))
- (let ((last-list1 (last list1)))
- (if-let ((cdr-last-list1 (cdr last-list1)))
- ;; list1 is a dotted list. Then list2 must be empty.
- (progn (setcdr last-list1 nil)
- (setq list2 cdr-last-list1))
- (setq list1 (butlast list1 1)
- list2 (cons (car last-list1) list2)))))
- match))
-
-(el-search-defpattern append (&rest patterns)
- "Matches any list factorable into lists matched by PATTERNS in order.
-
-PATTERNS is a list of patterns P1..Pn. Match any list L for that
-lists L1..Ln exist that are matched by P1..Pn in order and L is
-equal to the concatenation of L1..Ln. Ln is allowed to be no
-list.
-
-When different ways of matching are possible, it is unspecified
-which one is chosen.
-
-Example: the pattern
-
- (append '(1 2 3) x (app car-safe 7))
-
-matches the list (1 2 3 4 5 6 7 8 9), binding `x' to (4 5 6)."
- (cond
- ((null patterns) '(pred null))
- ((equal patterns '(_)) '(pred listp))
- (t
- (pcase-let ((`(,pattern . ,more-patterns) patterns))
- (cond
- ((null more-patterns) pattern)
- ((null (cdr more-patterns))
- `(and (pred listp)
- (app ,(apply-partially #'el-search--split
- (el-search-make-matcher pattern)
- (el-search-make-matcher (car
more-patterns)))
- `(,,pattern ,,(car more-patterns)))))
- (t `(append ,pattern (append ,@more-patterns))))))))
-
-(defcustom el-search-lazy-l t
- "Whether to interpret symbols and strings specially in `l'.
-
-When non-nil, the default, `l' based pattern types interpret
-symbols and strings as special LPATS: a SYMBOL matches any symbol
-S matched by SYMBOL's name interpreted as a regexp, and a STRING
-matches any string matched by the STRING interpreted as a regexp.
-
-When nil, symbols and strings act as standard `pcase' patterns."
- :group 'el-search :type 'boolean)
-
-(defun el-search--transform-nontrivial-lpat (expr)
- (if el-search-lazy-l
- (pcase expr
- ((and (pred symbolp) (let symbol-name (symbol-name expr)))
- `(symbol ,symbol-name))
- ((pred stringp) `(string ,expr))
- (_ expr))
- expr))
-
-(el-search-defpattern l (&rest lpats)
- "Alternative pattern type for matching lists.
-Match any list with subsequent elements matched by all LPATS in
-order.
-
-The idea is to be able to search for pieces of code (i.e. lists)
-with very brief input by using a specialized syntax.
-
-An LPAT can take the following forms (the special interpretation
-of symbols and strings can be turned off by binding or
-customizing `el-search-lazy-l' to nil):
-
-SYMBOL Matches any symbol S matched by SYMBOL's name interpreted
- as a regexp.
-'SYMBOL Matches the SYMBOL.
-STRING Matches any string matched by STRING interpreted as a
- regexp.
-_ Matches any list element.
-__ Matches any number (including zero) of list elements.
-^ Matches zero elements, but only at the beginning of a list.
- Only allowed as the first of the LPATS.
-$ Matches zero elements, but only at the end of a list.
- Only allowed as the last of the LPATS.
-PAT Anything else is interpreted as a standard pattern and
- matches one list element matched by it. Note: If
- matching PAT binds any symbols, occurrences in any
- following patterns are not turned into equivalence tests;
- the scope of symbol bindings is limited to the PAT
- itself.
-
-Example: To match defuns that contain \"hl\" in the defined name
-and have at least one mandatory, but also optional arguments, you
-could use this pattern:
-
- (l ^ 'defun hl (l _ &optional))"
- ;; We don't allow PATs in `l' to create bindings because to make this
- ;; work as expected we would need some kind of backtracking
- (declare
- (heuristic-matcher
- (lambda (&rest lpats)
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-every
- (lambda (lpat)
- (pcase lpat
- ((or '__ '_ '_? '^ '$) t)
- (_ (funcall (el-search-heuristic-matcher
(el-search--transform-nontrivial-lpat lpat))
- file-name-or-buffer atoms-thunk))))
- lpats)))))
- (let ((match-start nil) (match-end nil))
- (when (eq (car-safe lpats) '^)
- (setq match-start t)
- (cl-callf cdr lpats))
- (when (eq (car-safe (last lpats)) '$)
- (setq match-end t)
- (cl-callf butlast lpats 1))
- `(append ,@(if match-start '() '(_))
- ,@(mapcar
- (lambda (elt)
- (pcase elt
- ('__ '_)
- ('_ '`(,_))
- ('_? '(or '() `(,_))) ;FIXME: useful - document? or should
we provide a (? PAT)
- ;thing?
- (_ ``(,,(el-search--transform-nontrivial-lpat elt)))))
- lpats)
- ,@(if match-end '() '(_)))))
-
-
-;;;; `change', `changed'
-
-(defvar diff-hl-reference-revision)
-(declare-function diff-hl-changes "diff-hl")
-(defvar-local el-search--cached-changes nil)
-
-
-(defcustom el-search-change-revision-transformer-function nil
- "Transformer function for the REVISION argument of `change' and `changed'.
-
-When specified, this function is called with two arguments - the
-REVISION argument passed to `change' or `changed' and the current
-file name - and the return value is used as REVISION argument for
-these patterns.
-
-The default value is nil."
- :group 'el-search
- :type '(choice (const :tag "No transformer" nil)
- (function :tag "User specified function")))
-
-(defalias 'el-search--file-truename-wstm
- ;; We call `file-truename' very often and it's quite slow
- (el-search-with-short-term-memory #'file-truename))
-
-(defun el-search--changed-files-in-repo (repo-root-dir &optional commit)
- "Return a list of files that changed relative to COMMIT.
-COMMIT defaults to HEAD."
- (cl-callf or commit "HEAD")
- (let ((default-directory repo-root-dir)
- (message-log-max nil)
- (current-message (current-message)))
- (with-temp-message (concat current-message " [Calling VCS...]")
- (mapcar #'expand-file-name
- (cl-nintersection
- (split-string
- (shell-command-to-string
- (format "git diff -z --name-only %s --" (shell-quote-argument
commit)))
- "\0" t)
- (split-string
- (shell-command-to-string
- (format "git diff -z --name-only
4b825dc642cb6eb9a060e54bf8d69288fbee4904 %s --"
- (shell-quote-argument commit)))
- "\0" t)
- :test #'equal)))))
-
-(defvar vc-git-diff-switches)
-(defun el-search--file-changed-p (file revision)
- "Return non-nil when FILE has changed relative to REVISION."
- (cl-callf el-search--file-truename-wstm file)
- (when-let ((backend (vc-backend file)))
- (let ((default-directory (file-name-directory file)))
- (and
- (with-temp-buffer
- (= 1 (vc-call-backend backend 'diff (list file) nil revision
(current-buffer))))
- (with-temp-buffer
- (= 1 (vc-call-backend backend 'diff (list file) revision nil
(current-buffer))))))))
-
-(defun el-search--changes-from-diff-hl (revision)
- "Return the changed regions in the current buffer's file.
-The return value is a list of conses (START . END) of all changes
-relative to REVISION.
-
-Uses variable `el-search--cached-changes' for caching."
- (let ((buffer-file-name (el-search--file-truename-wstm buffer-file-name)))
;shouldn't be necessary, but it is...
- (if (and (consp el-search--cached-changes)
- (equal (car el-search--cached-changes)
- (list revision (visited-file-modtime))))
- (cdr el-search--cached-changes)
- (when (buffer-modified-p)
- (user-error "Buffer is modified - please save"))
- (require 'vc)
- (require 'diff-hl)
- ;; `diff-hl-changes' returns line numbers. We must convert them into
positions.
- (save-restriction
- (widen)
- (save-excursion
- (let ((diff-hl-reference-revision
- (if el-search-change-revision-transformer-function
- (funcall el-search-change-revision-transformer-function
- revision
- buffer-file-name)
- revision))
- (current-line-nbr 1) change-beg)
- (goto-char 1)
- (cdr (setq el-search--cached-changes
- (cons (list revision (visited-file-modtime))
- (and (el-search--file-changed-p
- buffer-file-name diff-hl-reference-revision)
- (delq nil
- (mapcar (pcase-lambda (`(,start-line
,nbr-lines ,kind))
- (if (eq kind 'delete) nil
- (forward-line (-
start-line current-line-nbr))
- (setq change-beg (point))
- (forward-line (1-
nbr-lines))
- (setq current-line-nbr (+
start-line nbr-lines -1))
- (cons (copy-marker
change-beg)
- (copy-marker
(line-end-position)))))
- (ignore-errors
- (let ((default-directory
- (file-name-directory
buffer-file-name)))
-
(diff-hl-changes)))))))))))))))
-
-(defun el-search--change-p (posn revision)
- ;; Non-nil when sexp after POSN is part of a change
- (if (buffer-modified-p)
- (if (eq this-command 'el-search-pattern)
- (user-error "Buffer is modified - please save")
- nil)
- (save-restriction
- (widen)
- (let ((changes (el-search--changes-from-diff-hl revision))
- (sexp-end (el-search--end-of-sexp posn))
- (atomic? (thunk-delay (el-search--atomic-p
- (save-excursion (goto-char posn)
- (el-search-read
(current-buffer)))))))
- (while (and changes (or (< (cdar changes) posn)
- (and
- ;; a string spanning multiple lines is a
change even when not all
- ;; lines are changed
- (< (cdar changes) sexp-end)
- (not (thunk-force atomic?)))))
- (pop changes))
- (and changes (or (<= (caar changes) posn)
- (and (thunk-force atomic?)
- (<= (caar changes) sexp-end))))))))
-
-(defun el-search--changed-p (posn revision)
- ;; Non-nil when sexp after POSN contains a change
- (if (buffer-modified-p)
- (if (eq this-command 'el-search-pattern)
- (user-error "Buffer is modified - please save")
- nil)
- (save-restriction
- (widen)
- (let ((changes (el-search--changes-from-diff-hl revision)))
- (while (and changes (<= (cdar changes) posn))
- (pop changes))
- (and changes
- (< (caar changes) (el-search--end-of-sexp posn)))))))
-
-(defun el-search-change--heuristic-matcher (&optional revision)
- (let* ((revision (or revision "HEAD"))
- (get-changed-files-in-repo
- (el-search-with-short-term-memory
#'el-search--changed-files-in-repo))
- (file-changed-p (el-search-with-short-term-memory
- (lambda (file-name-or-buffer)
- (require 'vc)
- (when-let ((file (if (stringp file-name-or-buffer)
- file-name-or-buffer
- (buffer-file-name
file-name-or-buffer))))
- (cl-callf el-search--file-truename-wstm file)
- (let ((default-directory (file-name-directory
file)))
- (when-let ((backend (vc-backend file))
- (root-dir
- (condition-case err
- (vc-call-backend backend 'root
default-directory)
- ;; Same handler as in
`vc-root-dir'
- (vc-not-supported
- (unless (eq (cadr err) 'root)
- (signal (car err) (cdr err)))
- nil))))
- (cl-some
- (apply-partially #'file-equal-p file)
- (funcall get-changed-files-in-repo
- root-dir
- (funcall (or
el-search-change-revision-transformer-function
- (lambda (rev _) rev))
- revision file))))))))))
- (lambda (file-name-or-buffer _) (funcall file-changed-p
file-name-or-buffer))))
-
-(el-search-defpattern change--1 (&optional revision)
- (declare (heuristic-matcher #'el-search-change--heuristic-matcher))
- `(guard (el-search--change-p (point) ,(or revision "HEAD"))))
-
-(el-search-defpattern change (&optional revision)
- "Matches the object if its text is part of a file change.
-
-Matches anything that changed relative to REVISION.
-Never matches in a modified buffer.
-
-Requires library \"diff-hl\". REVISION defaults to the file's
-repository's HEAD commit and is a revision string. Customize
-`el-search-change-revision-transformer-function' to control how
-REVISION is interpreted.
-
-This pattern-type does currently only work for git versioned
-files."
- `(and (filename) (change--1 ,revision)))
-
-(el-search-defpattern changed--1 (&optional revision)
- (declare (heuristic-matcher #'el-search-change--heuristic-matcher))
- `(guard (el-search--changed-p (point) ,(or revision "HEAD"))))
-
-(el-search-defpattern changed (&optional revision)
- "Matches the object if its text contains a file change.
-
-Matches anything that textually contains a change relative to
-REVISION. Never matches in a modified buffer.
-
-Requires library \"diff-hl\". REVISION defaults to the file's
-repository's HEAD commit and is a revision string. Customize
-`el-search-change-revision-transformer-function' to control how
-REVISION is interpreted.
-
-This pattern-type does currently only work for git versioned
-files."
- `(and (filename) (changed--1 ,revision)))
-
-
-;;;; `outermost' and `top-level'
-
-(el-search-defpattern outermost (pattern &optional not-pattern)
- "Matches when PATTERN matches but the parent sexp does not.
-For toplevel expressions, this is equivalent to PATTERN.
-
-Optional NOT-PATTERN defaults to PATTERN; when given, match when
-PATTERN matches but the parent sexp is not matched by
-NOT-PATTERN.
-
-
-This pattern is useful to match only the outermost expression
-when subexpressions would match recursively. For
-example, (outermost _) matches only top-level expressions.
-Another example: For the `change' pattern, any subexpression of a
-match is typically also an according change. Wrapping the
-`change' pattern into `outermost' prevents el-search from
-descending into any found expression - only the outermost
-expression matching the `change' pattern will be matched."
- `(and ,pattern
- (not (guard (save-excursion
- (condition-case nil
- (progn
- (backward-up-list)
- (el-search--match-p
- ',(el-search-make-matcher (or not-pattern
pattern))
- (save-excursion (el-search-read
(current-buffer)))))
- (scan-error)))))))
-
-(el-search-defpattern top-level ()
- "Matches any toplevel expression."
- '(outermost _))
-
-
-;;; Sloppy pattern types for quick navigation
-
-;;;; `keys'
-
-(defun el-search--match-key-sequence (keys expr)
- (when-let ((expr-keys (pcase expr
- ((or (pred stringp) (pred vectorp)) expr)
- (`(kbd ,(and (pred stringp) string)) (ignore-errors
(kbd string))))))
- (apply #'equal
- (mapcar (lambda (keys) (ignore-errors (key-description keys)))
- (list keys expr-keys)))))
-
-(el-search-defpattern keys (key-sequence)
- "Matches descriptions of the KEY-SEQUENCE.
-KEY-SEQUENCE is a string or vector representing a key sequence,
-or an expression of the form (kbd STRING).
-
-Match any description of the same key sequence in any of these
-formats.
-
-Example: the pattern
-
- (keys (kbd \"C-s\"))
-
-matches any of these expressions:
-
- \"\\C-s\"
- \"\C-s\"
- (kbd \"C-s\")
- [(control ?s)]"
- (when (eq (car-safe key-sequence) 'kbd)
- (setq key-sequence (kbd (cadr key-sequence))))
- (el-search-defpattern--check-args
- "keys" (list key-sequence)
- (lambda (x) (or (stringp x) (vectorp x))) "argument not a string or vector")
- `(pred (el-search--match-key-sequence ,key-sequence)))
-
-
-
-;;; Patterns for stylistic rewriting and syntactical simplification
-
-;;; de Morgan
-
-(el-search-defpattern de-morgan (&optional replacement)
- "Matches forms that can be simplified by applying de Morgan.
-Matched are all expressions of the form
-
- (or (not A1) (not A2) ...)
-
-and
-
- (and (not B1) (not B2) ...)
-
-where at least two `not' expressions are present.
-
-REPLACEMENT, when specified, should be a variable, and will be
-bound to a semantically equivalent expression with de Morgan's
-law been applied, namely
-
- (not (and A1 A2 ...))
-
-or
-
- (not (or B1 B2 ...))
-
-respectively.
-
-Note that when `el-search-query-replace'ing with this pattern
-type, it's possible that de Morgan can be applied again, so you
-may want to check that."
- (let ((functor (make-symbol "functor"))
- (nots (make-symbol "nots"))
- (arg (make-symbol "arg")))
- `(and `(,(and (or 'or 'and) ,functor) . ,,nots)
- (guard (and (consp ,nots) (not (cdr (last ,nots))))) ;check for a
proper non-empty list
- (guard (cl-every (lambda (,arg) (pcase ,arg (`(not ,_) t))) ,nots))
- (let (pred identity) (cdr ,nots))
- ,@(and replacement
- (not (eq '_ replacement))
- `((let ,replacement `(not (,(if (eq ,functor 'or) 'and 'or)
- ,@(mapcar #'cadr ,nots)))))))))
-
-;;;; Iffy `if's
-
-(defun el-search--nested-if-1 (expr)
- ;; EXPR is a (potentially nested) `if' expression. Return a list L so
- ;; that (cond . L) is semantically equivalent to EXPR. For example,
- ;; when EXPR == (if x 1 (if y 2 3)), return ((x 1) (y 2) (t 3))
- (pcase-exhaustive expr
- (`(if ,condition ,then ,(and `(if . ,_) inner-if))
- `((,condition ,then) ,@(el-search--nested-if-1 inner-if)))
- (`(if ,condition ,then)
- `((,condition ,then)))
- (`(if ,condition ,then . ,else)
- `((,condition ,then)
- (t . ,else)))))
-
-(el-search-defpattern -nested-if (&optional var)
- (let ((test-pattern '`(if ,_ ,_ (if ,_ ,_ ,_ . ,_))))
- (if (not var) test-pattern
- (let ((cases (make-symbol "cases")))
- `(and ,test-pattern
- (app el-search--nested-if-1 ,cases)
- (let ,var `(cond . ,,cases)))))))
-
-(el-search-defpattern iffy-if (&optional var)
- "Matches `if'-clauses that could be replaced with a more suitable form.
-
-Match `if' clauses that would fit better into either `cond',
-`when' or `unless'. With symbol VAR given, bind that to such a
-semantically equivalent expression suitable to replace the
-current match."
- (cl-callf or var '_)
- (let ((condition (make-symbol "condition"))
- (then (make-symbol "then"))
- (clauses (make-symbol "clauses")))
- `(or (-nested-if ,var)
- (and `(if (not ,,condition) ,,then)
- (let ,var `(unless ,,condition ,,then)))
- (and `(if ,,condition ,,then)
- (let ,var `(when ,,condition ,,then)))
- (and `(if ,,condition ,,then (cond . ,,clauses))
- (let ,var `(cond (,,condition ,,then) . ,,clauses))))))
-
-
-(provide 'el-search-x)
-
-;;; el-search-x.el ends here
diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el
deleted file mode 100644
index 89271fd..0000000
--- a/packages/el-search/el-search.el
+++ /dev/null
@@ -1,5267 +0,0 @@
-;;; el-search.el --- Expression based interactive search for Emacs Lisp -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2015-2020 Free Software Foundation, Inc
-
-;; Author: Michael Heerdegen <michael_heerdegen@web.de>
-;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
-;; Created: 29 Jul 2015
-;; Keywords: lisp
-;; Compatibility: GNU Emacs 25
-;; Version: 1.12.6.1
-;; Package-Requires: ((emacs "25") (stream "2.2.4") (cl-print "1.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 <http://www.gnu.org/licenses/>.
-
-
-;; Dedicated to my Grandfather Fritz
-
-
-;;; Commentary:
-
-;; This package implements an expression based interactive search tool
-;; for Emacs Lisp files and buffers. The pattern language used is a
-;; superset of `pcase' patterns.
-;;
-;; "el-search" is multi file/buffer search capable. It is designed to
-;; be fast and easy to use. It offers an occur-like overview of
-;; matches and can do query-replace based on the same set of patterns.
-;; All searches are added to a history and can be resumed or restarted
-;; later. Finally, it allows you to define your own kinds of search
-;; patterns and your own multi-search commands.
-;;
-;;
-;; Key bindings
-;; ============
-;;
-;; Loading this file doesn't install any key bindings - but you maybe
-;; want some. There are two predefined installable schemes of key
-;; bindings. The first scheme defines bindings mostly of the form
-;; "Control-Shift-Letter", e.g. C-S, C-R, C-% etc. These can be
-;; installed by calling (el-search-install-shift-bindings) - typically
-;; from your init file. For console users (and others), the function
-;; `el-search-install-bindings-under-prefix' installs bindings of the
-;; form PREFIX LETTER. If you call
-;;
-;; (el-search-install-bindings-under-prefix [(meta ?s) ?e])
-;;
-;; you install bindings M-s e s, M-s e r, M-s e % etc. When using
-;; this function to install key bindings, installed bindings are
-;; "repeatable" where it makes sense so that you can for example hit
-;; M-s e j s s s a % to reactive the last search, go to the next match
-;; three times, then go back to the first match in the current buffer,
-;; and finally invoke `el-search-query-replace'.
-;;
-;; It follows a complete list of key bindings installed when
-;; you call
-;;
-;; (el-search-install-shift-bindings)
-;;
-;; or
-;;
-;; (el-search-install-bindings-under-prefix [(meta ?s) ?e])
-;;
-;; respectively. If you don't want to install any key bindings, you
-;; want to remember the command name "el-search-pattern" or its alias
-;; "el-search" to get a start, and that after starting a search C-h
-;; will give you access to some help commands; among other things C-h
-;; b listing the relevant key bindings for controlling a search.
-;;
-;; C-S, M-s e s (`el-search-pattern')
-;; Start a search in the current buffer/go to the next match.
-;;
-;; While searching, the searched buffer is current (not the
-;; minibuffer). All commands that are not search or scrolling
-;; commands terminate the search, while the state of the search is
-;; always automatically saved. Like in isearch you can also just
-;; hit RET to exit or C-g to abort and jump back to where you
-;; started.
-;;
-;; By using the prefix arg this command can be used to reactivate
-;; the last or a former search and to restart searches from the
-;; beginning.
-;;
-;; C-h (aka the `help-char')
-;;
-;; C-h offers access to some help commands special to el-search
-;; when a search is active. Among other things C-h b (or ?) gives
-;; you a list of bindings to control the search.
-;;
-;; C-R, M-s e r (`el-search-pattern-backward')
-;; Search backward.
-;;
-;; C-%, M-s e % (`el-search-query-replace')
-;; Start a query-replace session. Resume or restart sessions with
-;; prefix arg.
-;;
-;; M-x el-search-directory
-;; Prompt for a directory name and start a multi el-search for all
-;; Emacs-Lisp files in that directory. With prefix arg,
-;; recursively search files in subdirectories.
-;;
-;; C-S, M-s e s in Dired (`el-search-dired-marked-files')
-;; Like above but uses the marked files and directories.
-;;
-;; C-S, M-s e s in Ibuffer (`el-search-ibuffer-marked-buffers')
-;; Search marked buffers in *Ibuffer*.
-;;
-;; C-O, M-s e o (`el-search-occur')
-;; Pop up an occur buffer for the current search.
-;;
-;; C-O or M-RET (from a search pattern prompt)
-;; Execute this search command as occur.
-;;
-;; C-X, M-s e x (`el-search-continue-in-next-buffer')
-;; Skip over current buffer or file.
-;;
-;; C-D, M-s e d (`el-search-skip-directory')
-;; Prompt for a directory name and skip all subsequent files
-;; located under this directory.
-;;
-;; C-A, M-s e a, M-s e < (`el-search-from-beginning')
-;; Go back to the first match in this buffer.
-;; With prefix arg or with M-s e >, go to the last match in
-;; the current buffer.
-;;
-;; C-J, M-s e j (`el-search-jump')
-;; Convenience command to move by matches. Resumes the last
-;; search if necessary.
-;; Without prefix arg, jump (back) to the current match.
-;; With prefix arg 0, resume from the position of the match
-;; following point instead.
-;; With prefix arg 1 or -1, jump to the first or last match
-;; visible in the selected window.
-;;
-;; C-S-next, v when search is active (`el-search-scroll-down')
-;; C-S-prior, V when search is active (`el-search-scroll-up')
-;; Scrolling by matches: Select the first match after
-;; `window-end', or select the first match before `window-start',
-;; respectively.
-;;
-;; C-H, M-s e h (`el-search-this-sexp')
-;; Grab the symbol or sexp under point and initiate an el-search
-;; for other occurrences.
-;;
-;; M-x el-search-to-register
-;; M-x el-search-query-replace-to-register
-;; Save the current el-search or el-search-query-replace session
-;; to an Emacs register. Use `jump-to-register' (C-x r j) to
-;; continue that search or query-replace session.
-;;
-;;
-;; The setup you need for your init file is trivial: you only need to
-;; install key bindings if you want some (see above). All important
-;; commands are autoloaded.
-;;
-;;
-;; Usage
-;; =====
-;;
-;; The main user entry point `el-search-pattern' (C-S or M-s e s) is
-;; analogue to `isearch-forward'. You are prompted for a
-;; `pcase'-style search pattern using an `emacs-lisp-mode' minibuffer.
-;; After hitting RET it searches the current buffer from point for
-;; matching expressions. For any match, point is put at the beginning
-;; of the expression found (unlike isearch which puts point at the end
-;; of matches). Hit C-S or s again to go to the next match etc.
-;;
-;; Syntax and semantics of search patterns are identical to that of
-;; `pcase' patterns, plus additionally defined pattern types
-;; especially useful for matching parts of programs.
-;;
-;; It doesn't matter how code is formatted. Comments are
-;; ignored, and strings are treated as atomic objects (their contents
-;; are not being searched).
-;;
-;;
-;; Example 1: if you enter
-;;
-;; 97
-;;
-;; at the prompt, el-search will find any occurrence of the integer 97
-;; in the code, but not 97.0 or 977 or (+ 90 7) or "My string
-;; containing 97" or symbol_97. OTOH it will find any printed
-;; representation of 97, e.g. #x61 or ?a.
-;;
-;;
-;; Example 2: If you enter the pattern
-;;
-;; `(defvar ,_)
-;;
-;; you search for all `defvar' forms that don't specify an init value.
-;;
-;; The following pattern will search for `defvar's with a docstring
-;; whose first line is longer than 70 characters:
-;;
-;; `(defvar ,_ ,_
-;; ,(and (pred stringp)
-;; s
-;; (guard (< 70 (length (car (split-string s "\n")))))))
-;;
-;; Put simply, el-search is a tool for matching representations of
-;; symbolic expressions written in a buffer or file. Most of the
-;; time, but not necessarily, this is Elisp code. El-search has no
-;; semantic understanding of the meaning of these s-exps as a program
-;; per se. If you define a macro `my-defvar' that expands to `defvar'
-;; forms, the pattern `(defvar ,_) will not match any equivalent
-;; `my-defvar' form, it just matches any lists of two elements with
-;; the first element being the symbol `defvar'.
-;;
-;; You can define your own pattern types with macro
-;; `el-search-defpattern' which is analogue to `defmacro' (and
-;; `pcase-defmacro'). See C-h f `el-search-defined-patterns' for a
-;; list of predefined additional pattern types, and C-h f pcase for
-;; the basic pcase patterns.
-;;
-;; Some additional pattern definitions can be found in the file
-;; "el-search-x.el" which is part of this package but not
-;; automatically loaded.
-;;
-;;
-;; Multi Searching
-;; ===============
-;;
-;; "el-search" is capable of performing "multi searches" - searches
-;; spanning multiple files or buffers. When no more matches can be
-;; found in the current file or buffer, the search automatically
-;; switches to the next one. Examples for search commands that start
-;; a multi search are `el-search-buffers' (search all live elisp mode
-;; buffers), `el-search-directory' (search all elisp files in a
-;; specified directory), `el-search-emacs-elisp-sources',
-;; `el-search-dired-marked-files' and `el-search-repository'.
-;; Actually, every search is internally a multi search.
-;;
-;; You can pause any search by just doing something different (no
-;; explicit quitting needed); the state of the search is automatically
-;; saved. You can later continue searching by calling
-;; `el-search-pattern' (C-S; M-s e s) with a prefix arg.
-;;
-;; `el-search-continue-in-next-buffer' (C-X; x) skips all remaining
-;; matches in the current buffer and continues searching in the next
-;; buffer. `el-search-skip-directory' (C-D; d) even skips all
-;; subsequent files under a specified directory.
-;;
-;;
-;; El-Occur
-;; ========
-;;
-;; To get an occur-like overview you can use the usual commands. You
-;; can either hit C-O or M-RET from the pattern prompt instead of RET
-;; to confirm your input and start the search as noninteractive occur
-;; search in the first place. Alternatively, you can always call
-;; `el-search-occur' (C-O or o) to start an occur for the latest
-;; started search.
-;;
-;; The *El Occur* buffer uses an adjusted emacs-lisp-mode. RET on a
-;; match gives you a pop-up window displaying the position of the
-;; match in that buffer or file. With S-tab you can (un)collapse all
-;; file sections like in `org-mode' to see only file names and the
-;; number of matches, or everything. Tab folds and unfolds
-;; expressions (this uses hideshow) and also sections at the beginning
-;; of headlines.
-;;
-;;
-;; Multiple multi searches
-;; =======================
-;;
-;; Every search is stored in a history. You can resume older searches
-;; from the position of the last match by calling `el-search-pattern'
-;; (C-S; M-s e s) with a prefix argument. That let's you select an
-;; older search to resume and switches to the buffer and position
-;; where this search had been suspended.
-;;
-;;
-;; Query-replace
-;; =============
-;;
-;; You can replace expressions with command `el-search-query-replace'.
-;; You are queried for a pattern and a replacement expression. For
-;; each match of the pattern, the replacement expression is evaluated
-;; with the bindings created by pattern matching in effect and printed
-;; to a string to produce the replacement.
-;;
-;; Example: In some buffer you want to swap the two expressions at the
-;; places of the first two arguments in all calls of function `foo',
-;; so that e.g.
-;;
-;; (foo 'a (* 2 (+ 3 4)) t)
-;;
-;; becomes
-;;
-;; (foo (* 2 (+ 3 4)) 'a t).
-;;
-;; This will do it:
-;;
-;; C-% (or M-s e %)
-;; `(foo ,a ,b . ,rest) RET
-;; `(foo ,b ,a . ,rest) RET
-;;
-;; Type y to replace a match and go to the next one, r to replace
-;; without moving (hitting r again restores that match), n to go to
-;; the next match without replacing and ! to replace all remaining
-;; matches automatically. q quits. ? shows a quick help summarizing
-;; all of these keys.
-;;
-;; It is possible to replace a match with an arbitrary number of
-;; expressions using "splicing mode". When it is active, the
-;; replacement expression must evaluate to a list, and this list is
-;; spliced into the buffer for any match. Hit s from the prompt to
-;; toggle splicing mode in an `el-search-query-replace' session.
-;;
-;; Much like `el-search' sessions, `el-search-query-replace' sessions
-;; are also internally represented as objects with state, and are also
-;; collected in a history. That means you can pause, resume and
-;; restart query-replace sessions, store them in registers, etc.
-;;
-;; There are two ways to edit replacements directly while performing
-;; an el-search-query-replace:
-;;
-;; (1) Without suspending the search: hit e at the prompt to show the
-;; replacement of the current match in a separate buffer. You can
-;; edit the replacement in this buffer. Confirming with C-c C-c will
-;; make el-search replace the current match with this buffer's
-;; contents.
-;;
-;; (2) At any time you can interrupt a query-replace session by
-;; hitting RET. You can resume the query-replace session by calling
-;; `el-search-query-replace' with a prefix argument.
-;;
-;;
-;; Multi query-replace
-;; ===================
-;;
-;; To query-replace in multiple files or buffers at once, call
-;; `el-search-query-replace' directly after starting a search whose
-;; search domain is the set of files and buffers you want to treat.
-;; Answer "yes" to the prompt asking whether you want the started
-;; search to drive the query-replace. The user interface is
-;; self-explanatory.
-;;
-;;
-;; Advanced usage: Replacement rules for semi-automatic code rewriting
-;; ===================================================================
-;;
-;; When you want to rewrite larger code parts programmatically, it can
-;; often be useful to define a dedicated pattern type to perform the
-;; replacement. Here is an example:
-;;
-;; You heard that in many situations, `dolist' is faster than an
-;; equivalent `mapc'. You use `mapc' quite often in your code and
-;; want to query-replace many occurrences in your stuff. Instead of
-;; using an ad hoc replacing rule, it's cleaner to define a dedicated
-;; named pattern type using `el-search-defpattern'. Make this pattern
-;; accept an argument and use it to bind a replacement expression to a
-;; variable you specify. In query-replace, specify that variable as
-;; replacement expression.
-;;
-;; In our case, the pattern could look like this:
-;;
-;; (el-search-defpattern el-search-mapc->dolist (new)
-;; (let ((var (make-symbol "var"))
-;; (body (make-symbol "body"))
-;; (list (make-symbol "list")))
-;; `(and `(mapc (lambda (,,var) . ,,body) ,,list)
-;; (let ,new `(dolist (,,var ,,list) . ,,body)))))
-;;
-;; The first condition in the `and' performs the matching and binds
-;; the essential parts of the `mapc' form to helper variables. The
-;; second, the `let', part, binds the specified variable NEW to the
-;; rewritten expression - in our case, a `dolist' form is constructed
-;; with the remembered code parts filled in.
-;;
-;; Now after this preparatory work, for `el-search-query-replace' you
-;; can simply specify (literally!) the following rule:
-;;
-;; (el-search-mapc->dolist repl) -> repl
-;;
-;;
-;; Acknowledgments
-;; ===============
-;;
-;; Thanks to Manuela for our review sessions.
-;; Thanks to Stefan Monnier for corrections and advice.
-;;
-;;
-;; Known Limitations and Bugs
-;; ==========================
-;;
-;; - Replacing: in some cases the read syntax of forms is changing due
-;; to reading-printing. "Some" because we can handle this problem
-;; in most cases.
-;;
-;; - Something like (1 #1#) is unmatchable (because it is un`read'able
-;; without context).
-;;
-;; - In el-search-query-replace, replacements are not allowed to
-;; contain uninterned symbols.
-;;
-;; - The `l' pattern type is very slow for very long lists.
-;; E.g. C-S-e (l "test")
-;;
-;; - Emacs bug#30132: 27.0.50; "scan-sexps and ##": Occurrences of the
-;; syntax "##" (a syntax for an interned symbol whose name is the
-;; empty string) can lead to errors while searching.
-;;
-;;
-;; TODO:
-;;
-;; - Add org and/or Info documentation
-;;
-;; - Could we profit from the edebug-read-storing-offsets reader?
-;;
-;; - Make currently hardcoded bindings in
-;; `el-search-loop-over-bindings' configurable
-;;
-;; - When reading input, bind up and down to
-;; next-line-or-history-element and
-;; previous-line-or-history-element?
-;;
-;; - Make searching work in comments, too? (->
-;; `parse-sexp-ignore-comments'). Related: should the pattern
-;; `symbol' also match strings that contain matches for a symbol so
-;; that it's possible to replace occurrences of a symbol in
-;; docstrings?
-;;
-;; - Port this package to non Emacs Lisp modes? How? Would it
-;; already suffice using only syntax tables, sexp scanning and
-;; font-lock?
-;;
-;; - There could be something much better than pp to format the
-;; replacement, or pp should be improved.
-;;
-;;
-;; NEWS:
-;;
-;; NEWS are listed in the separate NEWS file.
-
-
-
-;;; Code:
-
-;;;; Requirements
-
-(eval-when-compile (require 'subr-x))
-(eval-when-compile (require 'help-macro)) ;make-help-screen
-(unless (require 'rmc nil t) ;read-multiple-choice
- (require 'subr-x))
-
-(require 'cl-lib)
-(require 'pcase) ;we want to bind `pcase--dontwarn-upats' before pcase is
autoloaded
-(require 'cl-print)
-(require 'elisp-mode)
-(require 'thingatpt)
-(require 'thunk)
-(require 'seq)
-(require 'stream)
-(require 'stream-x)
-(require 'help-fns) ;el-search--make-docstring
-(require 'ring) ;el-search-history
-(require 'hideshow) ;folding in *El Occur*
-(require 'outline) ;folding in *El Occur*
-(eval-when-compile (require 'easymenu))
-
-
-;;;; Configuration stuff
-
-(defgroup el-search nil
- "Expression based search and replace for Emacs Lisp."
- :group 'lisp)
-
-(defcustom el-search-display-mb-hints t
- "Whether to show hints in the search pattern prompt."
- :type 'boolean)
-
-(defcustom el-search-mb-hints-delay 0.8
- "Time before displaying minibuffer hints.
-
-Setting this has only an effect if `el-search-display-mb-hints'
-is non-nil."
- :type 'number)
-
-(defcustom el-search-mb-hints-timeout 15
- "How long to display minibuffer hints."
- :type 'number)
-
-(defface el-search-match '((((class color) (min-colors 88) (background dark))
- (:background "#600000"))
- (((class color) (min-colors 88) (background light))
- (:background "DarkSlateGray3"))
- (t (:background "red")))
- "Face for highlighting the current match.")
-
-(defface el-search-other-match '((((class color) (min-colors 88) (background
dark))
- (:background "#603030"))
- (((class color) (min-colors 88) (background
light))
- (:background "DarkSlateGray1"))
- (t (:background "red")))
- "Face for highlighting the other matches.")
-
-(defface el-search-occur-match '((((class color) (min-colors 88) (background
dark))
- (:background "#000060"))
- (((class color) (min-colors 88) (background
light))
- (:background "GreenYellow"))
- (t (:background "blue")))
- "Face for highlighting matches in *El Occur*.")
-
-(defface el-search-highlight-in-prompt-face '((t (:inherit warning)))
- "Face for highlighting important parts in prompts.")
-
-(defcustom el-search-display-buffer-popup-action
- '((display-buffer-reuse-window display-buffer-same-window)
- (reusable-frames . visible))
- "`display-buffer' action used to display pop-up windows."
- :type display-buffer--action-custom-type)
-
-(defcustom el-search-display-next-buffer-action
- '((display-buffer-reuse-window
- display-buffer-same-window)
- (reusable-frames . visible)
- (inhibit-same-window . nil))
- "Action used to display the next buffer in multi searches."
- :type display-buffer--action-custom-type)
-
-(defcustom el-search-ignored-directory-regexps
- (mapcar
- (lambda (name) (format "\\`%s\\'" (regexp-quote name)))
- ;; this is just the default value of `grep-find-ignored-directories':
- '("SCCS" "RCS" "CVS" "MCVS" ".src" ".svn" ".git" ".hg" ".bzr" "_MTN"
"_darcs" "{arch}"))
- "List of regexps defining directories that el-search should ignore.
-
-The value influences the behavior of the commands that
-perform directory searches like `el-search-directory' or
-`el-search-dired-marked-files'. It is consulted by all streams
-`el-search-stream-of-directory-files' returns.
-
-The `file-name-nondirectory' of the directory file names is
-tested. "
- :type '(choice (repeat :tag "Regexps for ignored directories" regexp)
- (const :tag "No ignored directories" nil)))
-
-(defcustom el-search-auto-save-buffers 'ask-multi
- "Whether to automatically save modified buffers.
-When non-nil, save modified file buffers when query-replace is
-finished there.
-
-If the non-nil value is the symbol ask, ask for confirmation for
-each modified file buffer. You can still let all following
-buffers automatically be saved or left unsaved from the prompt.
-
-ask-multi is like ask, but don't ask and don't save for
-single-buffer sessions.
-
-Save automatically for any other non-nil value.
-
-The default value is ask-multi."
- :type '(choice (const :tag "Off" nil)
- (const :tag "On" t)
- (const :tag "Ask" ask)
- (const :tag "Ask when multibuffer" ask-multi)))
-
-(defcustom el-search-query-replace-stop-for-comments 'ask
- "Whether `el-search-query-replace' should stop for problematic comments.
-
-It's not always clear how comments in a match should be mapped to
-the replacement. If it can't be done automatically, the value of this
-option decides how to proceed.
-
-When nil, comments will likely be messed up or lost. You should
-then check the results after finishing `el-search-query-replace'.
-
-A non-nil value means to interrupt when encountering problematic
-comments. When the non-nil value is the symbol ask (that's the
-default), a prompt will appear that will ask how to proceed for
-the current match. You may then choose to edit the replacement
-manually, or ignore the problem for this case to fix it later.
-
-Any other non-nil value will not prompt and just directly pop to
-a buffer where you can edit the replacement to adjust the
-comments.
-
-When the value is ask, you can still choose the answer for all
-following cases from the prompt."
- :type '(choice (const :tag "Off" nil)
- (const :tag "On" t)
- (const :tag "Ask" ask)))
-
-(defvar el-search-use-transient-map t
- "Whether el-search should make commands repeatable."
- ;; I originally wanted to make commands repeatable by looking at the
- ;; command keys. But that got overly complicated: It interfered with
- ;; user interaction: we must remember in a flag if the current command
- ;; invocation was repeatable. Obviously, we must reset that flag in
- ;; post-command-hook. But we must avoid resetting in
- ;; post-command-hook when the command itself required user input, etc.
- ;; And it can't even work when we use a button or a register to resume
- ;; a search. So let's simply use this flag.
- )
-
-(defvar el-search-keep-transient-map-commands
- ;; Commands that may read input (`el-search-jump',
- ;; `el-search-skip-directory') need to be omitted here and should
- ;; explicitly install the transient map themselves.
- '(el-search-pattern
- el-search-pattern-backward
- el-search-help-list-bindings
- el-search-help-for-help
- describe-key
- el-search-from-beginning
- el-search-last-buffer-match
- el-search-continue-in-next-buffer
- el-search-scroll-down
- el-search-scroll-up
- universal-argument universal-argument-more
- digit-argument negative-argument)
- "List of commands that don't end repeatability of el-search commands.
-
-When `el-search-use-transient-map' is non-nil, when any
-\"repeatable\" el-search command had been invoked, executing any
-of these commands will keep the
-`el-search-prefix-key-transient-map' further in effect.")
-
-(defcustom el-search-allow-scroll t
- "Whether scrolling is allowed during el-search.
-When non-nil, scrolling commands don't deactivate the current
-search. Unlike isearch, it's possible to scroll the current
-match offscreen. Use `el-search-jump' (\\[el-search-jump])
-to go back to the position of the current match.
-
-When nil, scrolling commands deactivate the search (like any
-other command that doesn't continue el-searching)."
- :type 'boolean)
-
-(defcustom el-search-fancy-scrolling t
- "Whether to enable fancy scrolling in el-search.
-When active, el-search tries to scroll the selected window in a
-way to make the current match better visible. When off, only the
-default scrolling done by Emacs is used. Since el-search puts point
-at the beginning of each match, this means that the end of each match
-can still be after `window-end'. Fancy scrolling tries to make the
-whole match visible whenever possible."
- :type 'boolean)
-
-(defvar el-search-read-expression-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map read-expression-map)
- (define-key map "\C-g" #'abort-recursive-edit)
- (define-key map [up] nil)
- (define-key map [down] nil)
- (define-key map "\C-j" #'newline)
- (define-key map (kbd "M-RET") #'el-search-set-occur-flag-exit-minibuffer)
- map)
- "Keymap for reading input with `el-search-read-expression'.")
-
-(defcustom el-search-respect-nosearch t
- "Whether to disregard directories containing a .nosearch file.
-
-When turned on, directory searches skip directories containing a
-file named \".nosearch\".
-
-Setting this has an effect on commands that perform searches in
-directories, like `el-search-directory' or
-`el-search-dired-marked-files'. The value of this variable is
-consulted by all streams `el-search-stream-of-directory-files'
-returns."
- :type 'boolean)
-
-(defvar el-search-open-invisible t
- ;; Not an option because I don't know if a nil value is useful to
- ;; anyone.
- "Whether el-search should open invisible text.
-When non-nil, el-search automatically opens text hidden by
-\"outline.el\" or \"hideshow.el\" to make the current match
-visible, like isearch does by default. See also
-`el-search-hide-immediately'.
-
-Note that el-search always matches invisible text, this option
-only controls whether matches are made visible.")
-
-(defcustom el-search-hide-immediately t
- "If non-nil, re-hide an invisible match right away.
-This is the exact counterpart of `isearch-hide-immediately': it
-controls whether opened invisible text is re-hidden already while
-searching after leaving the opened area, or only after exiting
-the search. The last successful match is never hidden."
- :type 'boolean)
-
-
-;;;; Helpers and Definitions
-
-(defvar el-search-optimized-search t
- "Whether to use optimized searching.
-When turned on, use a fast pre-processing algorithm to sort out
-buffers that can be proved to not contain a match.
-
-Setting this to nil should not have any effect apart from making
-multi-buffer searching much slower in most cases, so this is only
-useful for debugging.")
-
-(defvar el-search--current-search nil
- "The currently active search, an `el-search-object', or nil.")
-
-(defvar el-search--search-origin nil)
-
-(defvar el-search--current-query-replace nil)
-
-(defvar-local el-search--temp-buffer-flag nil
- "Non-nil tags file visiting buffers as temporarily opened for searching.")
-
-(defvar-local el-search--temp-file-buffer-flag nil
- "Non-nil tags (file) buffers that should not be presented to the user.
-Buffers flagged this way contain the contents of a file but were
-not created with `find-file-noselect'.")
-
-(defvar el-search--success nil
- "Non-nil when last search command was successful.")
-
-(defvar el-search--wrap-flag nil
- "Non-nil when next search command should wrap the search.
-The non-nil value should be one of the symbols `forward' and
-`backward'.")
-
-(defvar el-search-occur-flag nil
- "Non-nil when next search should be performed as occur.")
-
-(defvar-local el-search--get-buffer-fun nil
- "How to recreate current buffer when non-nil.
-
-This buffer-local helper variable can be set in buffers that the
-get-buffer-stream method of el-search-objects returns to specify
-how to recreate that buffer. This is useful when the search
-domain contains places that are neither buffers nor files -
-former revisions of files for example. In this case
-`el-search-occur' can remember the value of this variable in
-the (temporary) buffers to implement to-match jumping after these
-buffers have been killed.")
-
-(defun el-search-true (&rest _args)
- "Ignore the arguments and return t."
- t)
-
-(defun el-search--entering-prefix-arg-p ()
- "Non-nil while a prefix arg is entered."
- (memq universal-argument-map overriding-terminal-local-map))
-
-(defun el-search--bounds-of-defun (&optional pos)
- "Return (BEG . END) of the top level s-exp covering POS.
-POS defaults to point. If no sexp is covering POS, return
-nil."
- (cl-callf or pos (point))
- (save-restriction
- (widen)
- (let (defun-beg defun-end)
- (cl-flet ((top-level-paren-start
- (pos)
- (save-excursion
- (let ((syntax-at-pos (syntax-ppss pos)))
- (and (not (zerop (nth 0 syntax-at-pos)))
- (syntax-ppss-toplevel-pos syntax-at-pos))))))
- (if (setq defun-beg
- (or
- ;; Iff inside a top-level paren group, this returns the
defun beginning
- (top-level-paren-start pos)
- ;; Iff at the beginning top-level paren group, this
succeeds and returns point
- (and (not (eobp)) (top-level-paren-start (1+ pos)))))
- (cons defun-beg (el-search--end-of-sexp defun-beg))
- ;; This corner case (not inside any s-exp or current top level s-exp
- ;; not a list) is a bit hairy to do with syntax stuff, so let's just
- ;; use el-search:
- (save-excursion
- (goto-char (point-min))
- (setq defun-beg (point-min))
- (setq defun-end (point-min))
- (while (and (<= defun-end pos)
- (el-search-forward '_ nil t))
- (setq defun-beg (point))
- (goto-char (setq defun-end (el-search--end-of-sexp))))
- (if (<= defun-beg pos defun-end)
- (cons defun-beg defun-end)
- nil)))))))
-
-(defun el-search-unhide-invisible (&optional beg end)
- (when el-search-open-invisible
- (cl-callf or beg (point))
- (let ((isearch-hide-immediately el-search-hide-immediately)
- (search-invisible 'open)
- (isearch-old-opened-overlays (copy-sequence
isearch-opened-overlays)))
- (isearch-range-invisible beg (or end (1+ beg)))
- (when (cl-set-difference
- ;; Closing overlays may make additional text visible
- isearch-old-opened-overlays isearch-opened-overlays)
- (el-search--after-scroll nil (window-start))))))
-
-(defun el-search-rehide-invisible ()
- (when el-search-open-invisible
- (isearch-clean-overlays)))
-
-(defun el-search-with-short-term-memory (function)
- "Wrap FUNCTION to cache the last arguments/result pair."
- (let ((cached nil))
- (lambda (&rest args)
- (pcase cached
- (`(,(pred (equal args)) . ,result) result)
- (_ (cdr (setq cached (cons args (apply function args)))))))))
-
-;; (defun el-search-with-long-term-memory (function &optional predicate)
-;; "Wrap FUNCTION to cache all calls.
-;; With PREDICATE given, only cache calls where the arguments
-;; fulfill PREDICATE. In this case, the last call is always
-;; remembered as in `el-search-with-short-term-memory'."
-;; (let ((cached (make-hash-table :test #'equal)))
-;; (el-search-with-short-term-memory
-;; (lambda (&rest args)
-;; (if-let ((cache-entry (gethash args cached)))
-;; (cdr cache-entry)
-;; (let ((result (apply function args)))
-;; (when (or (not predicate)
-;; (apply predicate args))
-;; (puthash args (cons t result) cached))
-;; result))))))
-
-(defmacro el-search-when-unwind (body-form &rest unwindforms)
- "Like `unwind-protect' but eval the UNWINDFORMS only if unwinding."
- (declare (indent 1))
- (let ((done (make-symbol "done")))
- `(let ((,done nil))
- (unwind-protect
- (prog1 ,body-form
- (setq ,done t))
- (unless ,done
- ,@unwindforms)))))
-
-(defvar el-search--last-message nil
- "Internal var helping to avoid echo area stuttering ")
-
-(defun el-search--message-no-log (format-string &rest args)
- "Like `message' but with `message-log-max' bound to nil."
- (let ((message-log-max nil))
- (apply #'message format-string args)))
-
-(defun el-search--byte-compile (form)
- (let ((byte-compile-log-warning-function #'ignore))
- (byte-compile form)))
-
-(defun el-search--set-this-command-refresh-message-maybe ()
- (when (eq (setq this-command 'el-search-pattern) last-command)
- (message "%s" el-search--last-message)))
-
-(defalias 'el-search-read
- (if (boundp 'force-new-style-backquotes)
- (lambda (&optional stream)
- "Like `read' but bind `force-new-style-backquotes' to t."
- (defvar force-new-style-backquotes)
- (let ((force-new-style-backquotes t))
- (read stream)))
- #'read))
-
-(defun el-search--pp-to-string (expr)
- (let ((print-length nil)
- (print-level nil)
- (print-circle nil))
- (string-trim-right (pp-to-string expr))))
-
-(defun el-search--setup-minibuffer ()
- (let ((inhibit-read-only t))
- (put-text-property 1 (minibuffer-prompt-end) 'font-lock-face
'minibuffer-prompt))
- (emacs-lisp-mode)
- (use-local-map el-search-read-expression-map)
- (setq font-lock-mode t)
- (funcall font-lock-function 1)
- (goto-char (minibuffer-prompt-end))
- (when (looking-at ".*\n")
- (indent-sexp))
- (goto-char (point-max))
- (when-let ((this-sexp (with-current-buffer (window-buffer
(minibuffer-selected-window))
- (thing-at-point 'sexp))))
- (let ((more-defaults (list (concat "'" this-sexp))))
- (setq-local minibuffer-default-add-function
- (lambda () (if (listp minibuffer-default)
- (append minibuffer-default more-defaults)
- (cons minibuffer-default more-defaults)))))))
-
-(defun el-search-read-expression (prompt &optional initial-contents hist
default read)
- "Read an expression from the minibuffer."
- (minibuffer-with-setup-hook #'el-search--setup-minibuffer
- (read-from-minibuffer prompt initial-contents
el-search-read-expression-map read
- (or hist 'read-expression-history) default)))
-
-(defvar el-search-pattern-history ()
- "History of search pattern input strings.")
-
-(defvar el-search-history (make-ring 15) ;FIXME: Make `15' customizable?
- "History of previous searches.")
-
-(defvar el-search-query-replace-history ()
- "History of input strings from `el-search-query-replace'.")
-
-(defun el-search--read-history-entry (hist-ring description-fun)
- (let ((l (ring-length hist-ring)))
- (ring-ref hist-ring
- (let ((input
- (completing-read
- "Resume previous session: "
- (mapcar
- (lambda (n) (format (format "%%0%dd - %%s" (1+ (floor
(log l 10))))
- n
- (funcall description-fun
- (ring-ref hist-ring (1- n))
- 'verbose)))
- (number-sequence 1 l)))))
- (string-match (rx bos (group (1+ (any "0-9"))) " - ") input)
- (1- (string-to-number (match-string 1 input)))))))
-
-(defvar el-search--initial-mb-contents nil)
-
-(defvar el-search-query-replace-object-history (make-ring 15)
- "History of previous `el-search-query-replace' sessions.")
-
-(defun el-search--pushnew-to-history (input histvar)
- ;; Push string INPUT to HISTVAR unless empty or equal to the head
- ;; element modulo `read'. Reindent INPUT when multiline.
- (let ((hist-head (car (symbol-value histvar))))
- (unless (or (string-match-p (rx bos eos) input)
- (and (stringp hist-head)
- (or (string= input hist-head)
- (ignore-errors (equal (el-search-read input)
(el-search-read hist-head))))))
- (push (if (string-match-p (rx bos (+ nonl) "\n") input)
- (with-temp-buffer
- (emacs-lisp-mode)
- (insert "\n")
- (insert input)
- (indent-region 1 (point))
- (buffer-string))
- input)
- (symbol-value histvar)))))
-
-(defun el-search--pattern-is-unquoted-symbol-p (pattern)
- (when (and (symbolp pattern)
- (not (eq pattern '_))
- (not (keywordp pattern)))
- (if (eq pattern 't)
- "t is a catchall pattern - did you mean 't?"
- (format "Free variable `%S' (missing a quote?)" pattern))))
-
-(defun el-search--maybe-warn-about-unquoted-symbol (pattern)
- (when-let ((msg (el-search--pattern-is-unquoted-symbol-p pattern)))
- (message "%s" msg)
- (sit-for 2.)))
-
-(defun el-search--read-pattern (prompt &optional default histvar)
- (cl-callf or histvar 'el-search-pattern-history)
- (let ((input (el-search-read-expression prompt
el-search--initial-mb-contents histvar default)))
- (el-search--pushnew-to-history input histvar)
- (if (not (string= input "")) input (car (symbol-value histvar)))))
-
-(defvar el-search--display-match-count-in-prompt nil)
-(defvar el-search--mb-hints-timer nil)
-(defvar el-search--reading-input-for-query-replace nil)
-
-(defun el-search-read-pattern-trigger-mb-hints ()
- (if (not (timerp el-search--mb-hints-timer))
- (setq el-search--mb-hints-timer (run-at-time 3 nil
#'el-search-read-display-mb-hints))
- (timer-set-time el-search--mb-hints-timer (time-add (current-time)
el-search-mb-hints-delay))
- (timer-activate el-search--mb-hints-timer)))
-
-(defun el-search-eldoc-documentation-function ()
- (when (catch 'result
- (save-excursion
- (while (condition-case nil
- (progn (backward-up-list)
- (if (el-search-looking-at '`(,(or 'pred 'guard)
. ,_))
- (throw 'result nil)
- t))
- (scan-error nil)))
- t))
- (pcase-let (((and current-fsym `(,fnsym ,index))
- (elisp--fnsym-in-current-sexp)))
- (defvar el-search--pcase-macros) ;defined later
- (let (pattern-def help)
- (and fnsym
- (setq pattern-def (cdr (assoc fnsym el-search--pcase-macros)))
- ;; This is what `elisp-get-fnsym-args-string' (which we can't
use) does
- (setq help (if-let* ((docstring (documentation pattern-def))
- (from-docstring (help-split-fundoc docstring
fnsym)))
- (elisp-function-argstring (car from-docstring))
- (prin1-to-string (help-function-arglist
pattern-def))))
- (elisp--highlight-function-argument
- current-fsym help index (concat (symbol-name fnsym) ": ")))))))
-
-(defvar el-search--this-session-match-count-data nil)
-
-(defun el-search-read-pattern-setup-mb ()
- ;; This is for minibuffer-setup-hook.
- ;; Note: this doesn't care about stopping the
- ;; 'el-search--mb-hints-timer'.
- (when el-search-display-mb-hints
- (setq el-search--this-session-match-count-data nil)
- (when (timerp el-search--mb-hints-timer) (cancel-timer
el-search--mb-hints-timer))
- (setq el-search--mb-hints-timer nil)
- (add-hook 'post-command-hook #'el-search-read-pattern-trigger-mb-hints t
t))
- (add-function :before-until (local 'eldoc-documentation-function)
- #'el-search-eldoc-documentation-function))
-
-(defvar el-search--search-pattern-1-do-fun nil)
-(defvar el-search--busy-animation
- ;; '("." "o" "O" "o" "." " ")
- ;; '("|" "/" "-" "\\")
- '("* " " * " " * " " *" " * " " * "))
-(defvar el-search-mb-anim-time .33)
-
-(defun el-search--make-display-animation-function (display-fun)
- (let ((last-update (seconds-to-time 0))
- (anim (copy-sequence el-search--busy-animation)))
- (setcdr (last anim) anim)
- (lambda ()
- (let ((now (current-time)))
- (when (< el-search-mb-anim-time (float-time (time-subtract now
last-update)))
- (setq last-update now)
- (funcall display-fun (pop anim)))))))
-
-(defun el-search-read-display-mb-hints ()
- (when (minibufferp)
- (let (err)
- (cl-macrolet ((try (&rest body)
- (let ((err-data (make-symbol "err-data")))
- `(condition-case ,err-data
- (progn ,@body)
- (error (setq err ,err-data)
- nil)))))
- (let* ((input (minibuffer-contents))
- (pattern (pcase (ignore-errors (read-from-string input))
- (`(,expr . ,(or (guard
el-search--reading-input-for-query-replace)
- (pred (= (length input)))))
- expr)))
- (matcher (and pattern (try (el-search-make-matcher pattern)))))
- (let* ((base-win (minibuffer-selected-window))
- (buf (window-buffer base-win)))
- (if (and el-search--display-match-count-in-prompt matcher)
- (progn (with-current-buffer buf
- (setq el-search--current-search
- (el-search-make-search
- pattern
- (let ((b (current-buffer)))
- (lambda () (stream (list b)))))))
- (let ((ol (make-overlay (point-max) (point-max) nil t
t)))
- (unwind-protect
- (cl-flet ((display-message
- (lambda (message &rest args)
- (setq message
- (propertize (apply #'format
message args)
- 'face 'shadow))
- (put-text-property 0 1 'cursor t
message)
- (overlay-put ol 'after-string
message)
- (redisplay))))
- (when-let ((msg
(el-search--pattern-is-unquoted-symbol-p pattern)))
- ;; A very common mistake: input "foo" instead
of "'foo"
- (display-message " [%s]" msg)
- (sit-for 2))
- (let ((count
- (try (with-current-buffer buf
- (cl-letf (((point) (window-point
base-win)))
- (el-search-display-match-count
- 'dont-message
-
(el-search--make-display-animation-function
- (lambda (icon)
- (display-message (concat "
" icon))))))))))
- (when (eq count t) (setq count nil))
- (when-let ((show-this (or count err)))
- (display-message " %-12s" show-this)
- (sit-for el-search-mb-hints-timeout))))
- (delete-overlay ol))))
- (unless (string= input "")
- (catch 'no-message
- (let ((minibuffer-message-timeout
el-search-mb-hints-timeout))
- (minibuffer-message
- (propertize
- (format " [%s]"
- (cond
- ((not pattern) "invalid")
- (err (error-message-string err))
- (el-search--display-match-count-in-prompt "No
match")
- (t (throw 'no-message t))))
- 'face 'shadow))))))))))
- (when quit-flag
- ;; When `quit-flag' is bound here, it had been set by `while-no-input'
- ;; meaning the user explicitly quit. This means we must:
- (funcall (key-binding [(control ?g)])))))
-
-(defun el-search-read-pattern-for-interactive (&optional prompt
display-match-count)
- "Read an \"el-search\" pattern from the minibuffer, prompting with PROMPT.
-
-This function is designed to be used in the interactive form of
-\"el-search\" commands that need to prompt for a pattern. Apart
-from reading the pattern it also sets `this-command' to
-`el-search-pattern' and adds the given input to
-`el-search-pattern-history' and `el-search-query-replace-history'.
-
-PROMPT defaults to \"El-search pattern: \". The return value is the
-`read' input pattern.
-
-With optional argument DISPLAY-MATCH-COUNT non-nil display a
-match count for the current buffer."
- (let* ((input
- (unwind-protect (minibuffer-with-setup-hook
#'el-search-read-pattern-setup-mb
- (let ((el-search--display-match-count-in-prompt
display-match-count))
- (el-search--read-pattern (or prompt "El-search
pattern: ")
- (car
el-search-pattern-history))))
- (when (timerp el-search--mb-hints-timer)
- (cancel-timer el-search--mb-hints-timer))))
- (pattern (el-search-read input)))
- (setq this-command 'el-search-pattern) ;in case we come from isearch
- ;; Make input available also in query-replace history
- (el-search--pushnew-to-history input 'el-search-query-replace-history)
- pattern))
-
-
-(defun el-search--end-of-sexp (&optional pos)
- "Return the value of point at the end of this sexp.
-Point should be at a sexp beginning.
-
-With POS, a sexp-beginning position, return value of point at the end
-of this sexp."
- (save-excursion
- (when pos (goto-char pos))
- (if (eql (char-after) ?@) ;bug#24542 "The symbol `@' and sexp scanning"
- (progn
- (ignore (el-search-read (current-buffer)))
- (point))
- (or (scan-sexps (point) 1) (point-max)))))
-
-(defun el-search--skip-expression (expression &optional read)
- ;; Move forward at least one character. Don't move into a string or
- ;; comment. Don't move further than the beginning of the next sexp.
- ;; Try to move as far as possible under these conditions. Point must
- ;; be at the beginning of an expression. If there are positions where
- ;; `read' would succeed, but that do not represent a valid sexp start,
- ;; move past them (e.g. when before "#'" move past both characters).
- ;;
- ;; EXPRESSION must equal the (read) expression at point, but with READ
- ;; non-nil, ignore the first argument and use the read expression at
- ;; point instead.
- (when read (setq expression (save-excursion (el-search-read
(current-buffer)))))
- (cond
- ((or (null expression)
- (equal [] expression)
- (not (or (listp expression) (vectorp expression))))
- (goto-char (el-search--end-of-sexp)))
- ((looking-at (rx (or ",@" "," "#'" "'")))
- (goto-char (match-end 0)))
- (t (forward-char))))
-
-(defun el-search--ensure-sexp-start ()
- "Move point to the next sexp beginning position.
-Do nothing if already at beginning of a sexp. `read' the
-expression starting at that position and return it. Point must
-not be inside a string or comment.
-Subsexps of sexps containing shared parts may be skipped (when
-not `read'able without context).
-
-When there is no sexp after point, signal an end-of-buffer
-error."
- (let ((not-done t) res)
- (while not-done
- (let ((stop-here nil)
- (looking-at-from-back (lambda (regexp n)
- (and (<= n (- (point) (point-min)))
- (save-excursion
- (backward-char n)
- (looking-at regexp))))))
- (while (not stop-here)
- (cond
- ((eobp) (signal 'end-of-buffer nil))
- ((looking-at (rx (and (* space) ";"))) (forward-line))
- ((looking-at (rx (+ (or space "\n")))) (goto-char (match-end 0)))
-
- ;; FIXME: can the rest be done more generically?
- ((and (looking-at (rx (or (syntax symbol) (syntax word))))
- (not (looking-at (rx symbol-start)))
- (not (funcall looking-at-from-back ",@" 2)))
- (forward-symbol 1))
- ((or (and (looking-at "'") (funcall looking-at-from-back "#" 1))
- (and (looking-at "@") (funcall looking-at-from-back "," 1)))
- (forward-char))
- (;; Skip over #N= and #N# read syntax
- (or (looking-at "['#`,@]*#[0-9]+=")
- (looking-at "['#`,@]*#[0-9]+#"))
- (goto-char (match-end 0)))
- (t (setq stop-here t)))))
- (condition-case nil
- (progn
- (setq res (save-excursion (el-search-read (current-buffer))))
- (setq not-done nil))
- (error (forward-char))))
- res))
-
-
-(defvar el-search--pcase-macros '()
- "Alist of additional \"el-search\" pcase macros.
-Keys are pattern names (i.e. symbols) and values the associated
-expander functions.")
-
-(defun el-search-defined-patterns ()
- "Return a list of defined el-search patterns."
- (mapcar #'car el-search--pcase-macros))
-
-(put 'el-search-defined-patterns 'function-documentation
- '(el-search--make-docstring 'el-search-defined-patterns))
-
-;;;###autoload
-(defun el-search-list-defined-patterns ()
- "Pop up a help buffer listing defined el-search pattern types."
- (interactive)
- (describe-function 'el-search-defined-patterns))
-
-(defun el-search--make-docstring (name)
- ;; Code mainly from `pcase--make-docstring'
- (let* ((main (documentation (symbol-function name) 'raw))
- (ud (help-split-fundoc main name)))
- (with-temp-buffer
- (insert (or (cdr ud) main)
- "\n\n\
-In addition to the standard `pcase' patterns the following
-pattern types are defined:")
- (mapc
- (pcase-lambda (`(,symbol . ,fun))
- (unless (string-match-p (rx (or (seq bos (any "-" "_")) "--")) ;Let's
consider these "internal"
- (symbol-name symbol))
- (when-let ((doc (documentation fun)))
- (insert "\n\n\n-- ")
- (setq doc (help-fns--signature symbol doc fun fun nil))
- (insert "\n" (or doc "Not documented.")))))
- (reverse el-search--pcase-macros))
- (let ((combined-doc (buffer-string)))
- (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
-
-(defvar el-search--heuristic-matchers ()
- "Alist of heuristic matchers.
-Keys are pattern names (i.e. symbols), and values the associated
-heuristic matcher functions.")
-
-(defvar el-search--inverse-heuristic-matchers ())
-
-(defmacro el-search-defpattern (name args &rest body)
- "Like `pcase-defmacro', but for defining el-search patterns.
-
-The semantics is very similar to that of `pcase-defmacro' but the
-scope of the definitions is limited to \"el-search\", using a
-separate name space. The expansion is allowed to use any defined
-`pcase' pattern as well as any defined el-search pattern.
-
-The docstring may be followed by a `defun' style declaration list
-DECL. There is currently only one respected specification, it
-has the form
-
- \(heuristic-matcher MATCHER-FUNCTION\)
-
-and specifies a heuristic MATCHER-FUNCTION to be associated with
-the defined pattern type NAME. See `el-search-heuristic-matcher'
-for details.
-
-\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
- (declare (indent 2) (debug defun) (doc-string 3))
- (let ((doc nil) (declaration-list ()))
- (when (stringp (car body))
- (setq doc (car body)
- body (cdr body)))
- (pcase (car body)
- (`(declare . ,declarations)
- (setq body (cdr body)
- declaration-list declarations)))
- `(progn
- (setf (alist-get ',name el-search--heuristic-matchers)
- ,(car (alist-get 'heuristic-matcher declaration-list)))
- (setf (alist-get ',name el-search--inverse-heuristic-matchers) ;not
official
- ,(car (alist-get 'inverse-heuristic-matcher declaration-list)))
- (setf (alist-get ',name el-search--pcase-macros)
- (lambda ,args ,@(and doc `(,doc)) ,@body)))))
-
-(defmacro el-search--with-additional-pcase-macros (&rest body)
- (let ((saved (make-symbol "saved")))
- `(let ((,saved nil))
- (unwind-protect
- (progn
- (pcase-dolist (`(,symbol . ,fun) el-search--pcase-macros)
- (push (cons symbol (get symbol 'pcase-macroexpander)) ,saved)
- (put symbol 'pcase-macroexpander fun))
- ,@body)
- (pcase-dolist (`(,symbol . ,fun) ,saved)
- (put symbol 'pcase-macroexpander fun))))))
-
-(defun el-search--macroexpand-1 (pattern &optional n)
- "Expand el-search PATTERN.
-This is like `pcase--macroexpand' but expands only patterns
-defined with `el-search-defpattern' and performs only one
-expansion step. If no entry for this pattern type exists in
-`el-search--pcase-macros', PATTERN is returned.
-
-With optional integer argument N given, successively macroexpand
-N times."
- (cl-callf or n 1)
- (if-let ((expander (alist-get (car-safe pattern) el-search--pcase-macros)))
- (let ((expanded (apply expander (cdr pattern))))
- (if (<= n 1) expanded
- (el-search--macroexpand-1 expanded (1- n))))
- pattern))
-
-(defun el-search--macroexpand (pattern)
- "Like `pcase--macroexpand' but also expanding \"el-search\" patterns."
- (el-search--with-additional-pcase-macros (pcase--macroexpand pattern)))
-
-(cl-defun el-search-make-matcher (pattern &optional (result-expr nil
result-specified))
- (let ((expression (make-symbol "expression")))
- (el-search--with-additional-pcase-macros
- (defvar warning-suppress-log-types)
- (let ((byte-compile-debug t) ;make undefined pattern types raise an error
- (warning-suppress-log-types '((bytecomp)))
- (pattern-is-catchall (memq pattern '(_ t)))
- (pattern-is-symbol (and (symbolp pattern)
- (not (or (keywordp pattern)
- (null pattern))))))
- (el-search--byte-compile
- `(lambda (,(if pattern-is-catchall '_ expression))
- ,(cond
- (pattern-is-catchall (if result-specified result-expr t))
- ((and pattern-is-symbol (not result-specified)) t)
- (t `(pcase ,expression
- (,pattern ,(if result-specified result-expr t)))))))))))
-
-(defun el-search--match-p (matcher expression)
- (funcall matcher expression))
-
-
-(defun el-search--search-pattern-1 (matcher &optional noerror bound
heuristic-matcher count)
- "Like `el-search-forward' but accepts a matcher as first argument.
-In addition, a HEURISTIC-MATCHER corresponding to the MATCHER can
-be specified as fourth argument, and COUNT becomes the fifth argument."
- (cond
- ((not (derived-mode-p 'emacs-lisp-mode))
- (if noerror nil (error "Buffer not in emacs-lisp-mode: %s" (buffer-name))))
- ((and count (not (integerp count)))
- (signal 'wrong-type-argument (list 'integerp count)))
- ((and count (< count 0))
- (el-search--search-backward-1 matcher noerror bound heuristic-matcher (-
count)))
- ((and bound (< bound (point)))
- (error "Invalid search bound (wrong side of point)"))
- (t
- (let* ((opoint (point))
- (fail (lambda ()
- (goto-char
- (if (not (memq noerror '(nil t)))
- (or bound (point-max))
- opoint))
- (if noerror nil (signal 'search-failed nil)))))
-
- ;; when inside a string or comment, move past it
- (let ((syntax-here (syntax-ppss)))
- (when (nth 3 syntax-here) ;inside a string
- (goto-char (nth 8 syntax-here))
- (forward-sexp))
- (when (nth 4 syntax-here) ;inside a comment
- (forward-line 1)
- (while (and (not (eobp)) (looking-at (rx (and (* space) ";"))))
- (forward-line 1))))
- (if count
- (cond
- ((= count 0) (point)) ;this is what the vanilla search functions do
- ((catch 'success
- (while (< 0 count)
- (cond
- ((not (el-search--search-pattern-1 matcher t bound
heuristic-matcher))
- (throw 'success nil))
- ((= 1 count)
- (throw 'success t))
- (t
- (cl-decf count)
- (el-search--skip-expression nil t)))))
- (point))
- (t (funcall fail)))
- (let ((match-beg nil) current-expr)
- (if (catch 'no-match
- (while (not match-beg)
- (when el-search--search-pattern-1-do-fun
- (funcall el-search--search-pattern-1-do-fun))
- (condition-case nil
- (setq current-expr (el-search--ensure-sexp-start))
- (end-of-buffer (throw 'no-match t)))
- (let ((end-of-defun nil))
- (cond
- ((and el-search-optimized-search
- heuristic-matcher
- (looking-at "^(")
- (zerop (car (syntax-ppss)))
- (not (funcall heuristic-matcher
- (current-buffer)
- (thunk-delay
- (el-search--flatten-tree
- (save-excursion
- (prog1 (el-search-read
(current-buffer))
- (setq end-of-defun
(point)))))))))
- (goto-char (or end-of-defun
- ;; the thunk hasn't been forced
- (scan-lists (point) 1 0))))
- ((el-search--match-p matcher current-expr)
- (if (or (not bound)
- (<= (el-search--end-of-sexp match-beg) bound))
- (setq match-beg (point))
- ;; don't fail: a subsequent match may end before BOUND
- (el-search--skip-expression current-expr)))
- (t (el-search--skip-expression current-expr))))
- (when (and bound (<= bound (point)))
- (throw 'no-match t)))
- nil)
- (funcall fail)
- match-beg)))))))
-
-(defun el-search-forward (pattern &optional bound noerror count)
- "Search for el-search PATTERN in current buffer from point.
-Set point to the beginning of the occurrence found and return point.
-
-An optional second argument bounds the search; it is a buffer
-position. The match found must not end after that position. A
-value of nil means search to the end of the accessible portion of
-the buffer.
-
-Optional third argument NOERROR, if non-nil, means if fail just
-return nil (no error); when not t, in addition also move to limit
-of search.
-
-The optional fourth argument COUNT is a number that indicates the
-search direction and the number of occurrences to search for. If
-it is positive, search forward for COUNT successive occurrences;
-if it is negative, search backward for -COUNT occurrences. The
-match found is the COUNTth/-COUNTth one in the buffer starting
-after/before the origin of the search."
- (el-search--search-pattern-1 (el-search-make-matcher pattern) noerror bound
- (el-search-heuristic-matcher pattern)
- count))
-
-(defvar el-search-quick-help-buffer-name "*El-Search Quick Help*")
-(defvar-local el-search-help-window nil)
-
-(defun el-search-close-quick-help-maybe ()
- (when-let* ((help-buffer (get-buffer el-search-quick-help-buffer-name))
- (help-win (buffer-local-value 'el-search-help-window
help-buffer))
- ((window-live-p help-win)))
- (delete-window help-win)
- t))
-
-
-;; FIXME: make this also a declaration spec?
-(defun el-search-defpattern--check-args (type args predicate &optional message)
- "Check whether all ARGS fulfill PREDICATE.
-Raise a `user-error' if not. The string arguments TYPE and
-optional MESSAGE are used to construct the error message."
- (dolist (arg args)
- (unless (funcall predicate arg)
- (user-error (concat "Pattern `%s': "
- (or message (format "argument doesn't fulfill %S"
predicate))
- ": %S")
- type arg))))
-
-(defun el-search--elisp-file-p (file)
- (and (string-match-p (concat "\\.el" (regexp-opt jka-compr-load-suffixes)
"?\\'") file)
- (file-exists-p file)
- (not (file-directory-p file))))
-
-
-(cl-defstruct (el-search-object (:copier copy-el-search-object--1))
- pattern ;the search pattern
- head ;an `el-search-head' instance, modified ("moved") while searching
- last-match ;position of last match found
- get-matches ;method returning a stream of all matches
- properties ;An alist of additional properties. Meaningful properties
- ;are:
- ; - is-single-buffer Indicates a single-buffer search; value
should
- ; then be the searched buffer
- ; - description When specified, a string describing the
search
- )
-
-(defun copy-el-search-object (search)
- (let ((copy (copy-el-search-object--1 search)))
- (cl-callf copy-el-search-head (el-search-object-head copy))
- (cl-callf copy-alist (el-search-object-properties copy))
- copy))
-
-(cl-defmethod cl-print-object ((object el-search-object) stream)
- ;; We use a syntax that looks nice with with pp.el
- (princ "#s(el-search-object " stream)
- (prin1 (el-search--get-search-description-string object 'verbose
'dont-propertize) stream)
- (princ ")" stream))
-
-(defun el-search--current-pattern ()
- (and el-search--current-search
- (el-search-object-pattern el-search--current-search)))
-
-(defun el-search--current-matcher ()
- (and el-search--current-search
- (el-search-head-matcher (el-search-object-head
el-search--current-search))))
-
-(defun el-search--current-heuristic-matcher ()
- (and el-search--current-search
- (el-search-head-heuristic-matcher (el-search-object-head
el-search--current-search))))
-
-(cl-defstruct el-search-head
- get-buffer-stream ;a function of zero args returning a stream of
files and/or buffers to search
- matcher ;for the search pattern
- heuristic-buffer-matcher ;for the search pattern
- heuristic-matcher ;for the search pattern
- buffer ;currently searched buffer, or nil meaning
"continue in next buffer"
- position ;where to continue searching this buffer
- file ;name of currently searched file, or nil
- buffers ;stream of buffers and/or files yet to search
- )
-
-(defmacro el-search-protect-search-head (&rest body)
- "Reset current search's head when BODY exits non-locally."
- (declare (debug t))
- (macroexp-let2 nil head-copy '(copy-el-search-head (el-search-object-head
el-search--current-search))
- `(el-search-when-unwind (progn ,@body)
- (setf (el-search-object-head el-search--current-search) ,head-copy))))
-
-(defun el-search--search-buffer-p (&optional buffer)
- (and el-search--current-search
- (eq (or buffer (current-buffer))
- (el-search-head-buffer (el-search-object-head
el-search--current-search)))))
-
-(defun el-search-revive-search ()
- (el-search-hl-post-command-fun 'stop)
- (setq el-search--success nil)
- (setq el-search--wrap-flag nil)
- (el-search-reset-search el-search--current-search))
-
-(defun el-search-barf-if-not-search-buffer (&optional buffer &rest args)
- (if (eq (alist-get 'is-single-buffer (el-search-object-properties
el-search--current-search))
- (current-buffer))
- (unless (el-search-head-buffer (el-search-object-head
el-search--current-search))
- (el-search-revive-search)
- (el-search--next-buffer el-search--current-search))
- (unless (el-search--search-buffer-p buffer)
- (apply #'user-error (or args (list "Not in current search buffer"))))))
-
-(defun el-search--get-search-description-string (search &optional verbose
dont-propertize)
- (concat
- (or (alist-get 'description (el-search-object-properties search))
- "Search")
- (when verbose
- (let ((search-head (el-search-object-head search)))
- (format " [%s %s]"
- (if (alist-get 'is-single-buffer (el-search-object-properties
search))
- "single-buffer" "paused")
- (if-let ((buffer (el-search-head-buffer search-head)))
- (concat "-> "(if (buffer-live-p buffer)
- (buffer-name buffer)
- (if-let ((head-file (el-search-head-file
search-head)))
- (file-name-nondirectory head-file)
- "killed buffer")))
- "(completed)"))))
- " for"
- (let ((printed-pattern (el-search--pp-to-string (el-search-object-pattern
search))))
- (format (if (string-match-p "\n" printed-pattern) ":\n%s" " %s")
- (if dont-propertize printed-pattern
- (propertize printed-pattern 'face 'shadow))))))
-
-(defun el-search-edit-search-description ()
- "Edit the description string of the current search.
-That string appears in the printed representation of the search,
-so this is mainly useful to add short notes."
- (interactive)
- (cl-callf (lambda (old-description) (read-string "New description: "
old-description))
- (alist-get 'description (el-search-object-properties
el-search--current-search))))
-
-
-(defun el-search-kill-left-over-search-buffers ()
- "Kill all buffers that were opened just for searching.
-Buffers where a search had been paused or aborted (e.g. by moving
-the cursor) are not killed."
- (interactive)
- (dolist (buffer (buffer-list))
- (when (with-current-buffer buffer el-search--temp-buffer-flag)
- (unless (or (buffer-modified-p buffer) ; e.g. modified by
el-s-query-replace and auto-save off
- (el-search--search-buffer-p buffer)
- (with-current-buffer buffer (el-search--pending-search-p)))
- (kill-buffer buffer)))))
-
-
-(defun el-search-heuristic-matcher (pattern)
- "Return a heuristic matcher for PATTERN.
-
-A heuristic matcher is a predicate accepting two arguments. The
-first argument is a file name or buffer. The second argument is
-a thunk (see \"thunk.el\") of a list of all of this file's or
-buffer's atoms, or of the atoms of a defun (i.e. top-level
-expression) in this file or buffer. The predicate returns nil
-when we can be sure that this file or buffer or defun can't
-contain a match for the PATTERN, and must return non-nil else.
-
-The idea behind heuristic matching is to speed up searching
-without altering the matching behavior by discarding files or
-buffers or defuns that can't contain a match. Most search
-patterns contain non-ambiguous information about properties of
-atoms that must be present in a buffer or defun containing a
-match, and computing a list of atoms is negligibly fast compared
-to searching that buffer or defun directly. Thus we spare
-expensively searching all buffers and defuns we can sort out that
-way.
-
-When specified in an `el-search-defpattern' declaration, a
-MATCHER-FUNCTION should be a function accepting the same
-arguments ARGS as the defined pattern. When called with ARGS,
-this function should return either nil (meaning that for these
-specific arguments no heuristic matching should be performed and
-normal matching should be used) or a (fast!) function, the
-\"heuristic matcher\" for this pattern, that accepts two
-arguments: a file-name or buffer, and a thunk of a complete list
-of atoms in that file or buffer or of a defun in it, that returns
-non-nil when this file or buffer or defun could contain a match
-for the pattern (NAME . ARGS), and nil when we can be sure that
-it doesn't contain a match. \"Atom\" here means anything whose
-parts aren't searched by el-searching, like integers or strings,
-but unlike arrays (see `el-search--atomic-p'). When in doubt,
-the heuristic matcher function must return non-nil.
-
-When el-searching is started with a certain PATTERN, a heuristic
-matcher function is constructed by recursively destructuring the
-PATTERN and combining the heuristic matchers of the subpatterns."
- (pcase pattern
- ((pred symbolp) #'el-search-true)
- (''nil ; special case: don't miss occurrences in text like "(1 . nil)"
- #'el-search-true)
- ((pred pcase--self-quoting-p) (lambda (_ atoms-thunk) (member pattern
(thunk-force atoms-thunk))))
- (`',tree
- (pcase (el-search--flatten-tree tree)
- (`(,tree) (lambda (_ atoms-thunk) (member tree (thunk-force
atoms-thunk))))
- (flattened (let ((matchers (mapcar (lambda (atom)
(el-search-heuristic-matcher `',atom))
- flattened)))
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-every (lambda (matcher) (funcall matcher
file-name-or-buffer atoms-thunk))
- matchers))))))
- (``,qpat
- (cond
- ((eq (car-safe qpat) '\,) (el-search-heuristic-matcher (cadr qpat)))
- ((vectorp qpat)
- (let ((matchers (mapcar (lambda (inner-qpat)
(el-search-heuristic-matcher (list '\` inner-qpat)))
- qpat)))
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-every (lambda (matcher) (funcall matcher file-name-or-buffer
atoms-thunk))
- matchers))))
- ((consp qpat)
- (el-search-heuristic-matcher
- `(and
- ,(list '\` (car qpat))
- ,(if (cdr qpat) (list '\` (cdr qpat)) '_))))
- ((or (stringp qpat) (integerp qpat) (symbolp qpat))
- (lambda (_ atoms-thunk) (member qpat (thunk-force atoms-thunk))))
- (t #'el-search-true)))
- (`(and . ,patterns)
- (let ((matchers (mapcar #'el-search-heuristic-matcher patterns)))
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-every (lambda (matcher) (funcall matcher file-name-or-buffer
atoms-thunk))
- matchers))))
- (`(or . ,patterns)
- (let ((matchers (mapcar #'el-search-heuristic-matcher patterns)))
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-some (lambda (matcher) (funcall matcher file-name-or-buffer
atoms-thunk))
- matchers))))
- (`(,(or 'app 'let 'pred 'guard) . ,_) #'el-search-true)
- ((and `(,name . ,args)
- (let heuristic-matcher (alist-get name
el-search--heuristic-matchers))
- (guard heuristic-matcher)
- (let this-heuristic-matcher (apply heuristic-matcher args))
- (guard this-heuristic-matcher))
- (ignore name args heuristic-matcher) ;quite byte compiler
- this-heuristic-matcher)
- ((and (app el-search--macroexpand-1 expanded)
- (guard (not (eq expanded pattern))))
- (el-search-heuristic-matcher expanded))
- (_ #'el-search-true)))
-
-(defvar el-search--atom-list-cache (make-hash-table :test #'equal :size 1000))
-
-(defun el-search-atom-list (file-name-or-buffer)
- "Return a list of el-search-atomic expressions in FILE-NAME-OR-BUFFER.
-`nil' atoms may be missing from the list for code like
-\"(1 . nil)\")."
- (let ((get-buffer-atoms
- (lambda () (apply #'append
- (mapcar #'el-search--flatten-tree
- (save-excursion
- (goto-char (point-min))
- (let ((forms ()))
- (condition-case err
- (while t (push (el-search-read
(current-buffer)) forms))
- (end-of-file forms)
- (error
- (message "%s in %S\nat position %d -
skipping"
- (error-message-string err)
- file-name-or-buffer
- (point))
- (sit-for 3.)
- ;; FIXME: we could also `throw' a
tag that would force the
- ;; buffer/file to be searched
regularly
- nil))))))))
- (buffer (if (bufferp file-name-or-buffer)
- file-name-or-buffer
- (find-buffer-visiting file-name-or-buffer))))
- (if buffer
- (if (buffer-live-p buffer)
- (with-current-buffer buffer (funcall get-buffer-atoms))
- ;; FILE-NAME-OR-BUFFER was bound to a killed buffer. We just return
- ;; the empty list.
- '())
- (let ((file-name file-name-or-buffer))
- (if-let ((hash-entry (gethash file-name el-search--atom-list-cache))
- (its-usable (equal (nth 5 (file-attributes file-name)) (car
hash-entry))))
- (cdr hash-entry)
- (let ((atom-list (with-temp-buffer
- (let ((inhibit-message t))
- (insert-file-contents file-name-or-buffer))
- (set-syntax-table emacs-lisp-mode-syntax-table)
- (funcall get-buffer-atoms))))
- (when atom-list ;empty in case of error
- (puthash file-name
- (cons (nth 5 (file-attributes file-name)) atom-list)
- el-search--atom-list-cache))
- atom-list))))))
-
-(defun el-search--atomic-p (object)
- (or (not (sequencep object)) (stringp object) (null object)
- (char-table-p object) (bool-vector-p object)))
-
-(defun el-search--flatten-tree (tree)
- "Return a list of `el-search--atomic-p' objects in TREE."
- (let ((elements ())
- (walked-objects ;to avoid infinite recursion for circular TREEs
- (make-hash-table :test #'eq))
- (gc-cons-percentage 0.8)) ;Why is binding it here more effective than
binding it more top-level?
- (cl-labels ((walker (object)
- (if (el-search--atomic-p object)
- (push object elements)
- (unless (gethash object walked-objects)
- (puthash object t walked-objects)
- (if (consp object)
- (progn
- (while (consp object)
- (walker (car object))
- (setq object (cdr object))
- (if (gethash object walked-objects)
- (setq object nil)
- (puthash object t walked-objects)))
- (when object ;dotted list
- (walker object)))
- (cl-loop for elt being the elements of object do
(walker elt)))))))
- (walker tree)
- elements)))
-
-(defun el-search-heuristic-buffer-matcher (pattern &optional hm)
- (let ((heuristic-matcher (or hm (el-search-heuristic-matcher pattern))))
- (lambda (file-name-or-buffer)
- (el-search--message-no-log "%s"
- (if (stringp file-name-or-buffer)
- file-name-or-buffer
- (buffer-name file-name-or-buffer)))
- (funcall heuristic-matcher
- file-name-or-buffer
- (thunk-delay (el-search-atom-list file-name-or-buffer))))))
-
-(defvar warning-minimum-level)
-(defun el-search--next-buffer (search &optional predicate keep-highlighting)
- ;; Prepare to continue SEARCH in the next buffer in line. Move
- ;; SEARCH's head accordingly. When specified, PREDICATE should accept
- ;; a file name or buffer, and we skip all buffers and files not
- ;; fulfilling it. The returned buffer may be a helper buffer not
- ;; suitable for presentation to the user (this case is handled in
- ;; `el-search-continue-search').
- ;;
- ;; Return the new buffer to search in or nil if done.
- (unless keep-highlighting
- (el-search-hl-remove)
- ;; Ensure that `el-search--pending-search-p' returns nil in this
- ;; buffer even when `el-search-hl-post-command-fun' doesn't get a
- ;; chance to clean up before that call.
- (remove-hook 'post-command-hook 'el-search-hl-post-command-fun t))
- (let ((original-predicate (or predicate #'el-search-true))
- (heuristic-buffer-matcher
- (el-search-head-heuristic-buffer-matcher (el-search-object-head
search))))
- (setq predicate
- (lambda (file-name-or-buffer)
- (and (funcall original-predicate file-name-or-buffer)
- (or (not el-search-optimized-search)
- (funcall heuristic-buffer-matcher
file-name-or-buffer))))))
- (let ((head (el-search-object-head search)))
- (let ((buffer-stream (el-search-head-buffers head))
- (buffer-list-before (buffer-list))
- (done nil) next buffer)
- (while (not (or done (stream-empty-p buffer-stream)))
- (setq next (stream-first buffer-stream)
- buffer-stream (stream-rest buffer-stream)
- done (or (not predicate) (funcall predicate next))))
- (if (not done)
- (progn
- (setf (el-search-head-buffer head) nil
- (el-search-head-buffers head) buffer-stream) ;i.e. the
empty stream
- nil)
- (setf (el-search-head-buffers head) buffer-stream
- (el-search-head-position head) 1)
- (if (bufferp next)
- (setq buffer next)
- (setf (el-search-head-file head) next)
- (setq buffer (or (find-buffer-visiting next)
- (let ((warning-minimum-level :error)
- (inhibit-message t))
- (let ((fresh-buffer (generate-new-buffer "
el-search-helper-buffer")))
- (with-current-buffer fresh-buffer
- (insert-file-contents next)
- (emacs-lisp-mode)
- (setq-local el-search--temp-file-buffer-flag
next)
- (setq-local buffer-file-name next) ;make
`file' pat work as expected
- (set-visited-file-modtime)
- (set-buffer-modified-p nil))
- fresh-buffer)))))
- (unless (memq buffer buffer-list-before)
- (with-current-buffer buffer
- (setq-local el-search--temp-buffer-flag t)))
- (setf (el-search-head-buffer head) buffer)
- (when (and (bufferp buffer) (not (eq buffer (current-buffer))));FIXME:
Is this a good condition?
- (with-current-buffer buffer
- (when (and (buffer-narrowed-p)
- (y-or-n-p (format "Widen buffer \"%s\"? "
- (buffer-name))))
- (widen))))
- buffer))))
-
-(defun el-search--skip-to-next-buffer (&optional predicate)
- ;; Find next buffer fulfilling the PREDICATE and continue search there
- (el-search--next-buffer el-search--current-search predicate)
- (el-search-continue-search))
-
-;;;###autoload
-(defun el-search-count-matches (pattern &optional rstart rend interactive)
- "Like `count-matches' but accepting an el-search PATTERN instead of a regexp.
-
-Unlike `count-matches' matches \"inside\" other matches also count."
- (interactive (list (el-search-read-pattern-for-interactive "How many matches
for pattern: ")
- nil nil t))
- ;; Code is mainly adopted from `count-matches'
- (save-excursion
- (if rstart
- (if rend
- (progn
- (goto-char (min rstart rend))
- (setq rend (max rstart rend)))
- (goto-char rstart)
- (setq rend (point-max)))
- (if (and interactive (use-region-p))
- (setq rstart (region-beginning)
- rend (region-end))
- (setq rstart (point)
- rend (point-max)))
- (goto-char rstart))
- (let ((count 0)
- (matcher (el-search-make-matcher pattern))
- (hmatcher (el-search-heuristic-matcher pattern)))
- (while (and (< (point) rend)
- (el-search--search-pattern-1 matcher t rend hmatcher))
- (cl-incf count)
- (el-search--skip-expression nil t))
- (when interactive (message "%d occurrence%s" count (if (= count 1) ""
"s")))
- count)))
-
-(defun el-search--looking-at-1 (matcher &optional allow-leading-whitespace)
- "Like `el-search-looking-at' but accepts a MATCHER as first argument."
- (if (not (derived-mode-p 'emacs-lisp-mode))
- (error "Buffer not in emacs-lisp-mode: %s" (buffer-name))
- (save-excursion
- (let ((syntax-here (syntax-ppss)) (here (point)) current-sexp)
- (and (not (or (nth 3 syntax-here) (nth 4 syntax-here)))
- (condition-case nil
- (progn (setq current-sexp (el-search--ensure-sexp-start))
- t)
- (end-of-buffer nil))
- (or (= here (point))
- (and allow-leading-whitespace
- (string-match-p (rx bos (+ space) eos) (buffer-substring
here (point)))))
- (el-search--match-p matcher current-sexp))))))
-
-;;;###autoload
-(defun el-search-looking-at (pattern &optional allow-leading-whitespace)
- "El-search version of `looking-at'.
-Return non-nil when there is a match for PATTERN at point in the
-current buffer.
-
-With ALLOW-LEADING-WHITESPACE non-nil, the match may
-be preceded by whitespace."
- (el-search--looking-at-1 (el-search-make-matcher pattern)
allow-leading-whitespace))
-
-(defun el-search--all-matches (search &optional dont-copy)
- "Return a stream of all matches of SEARCH.
-The returned stream will always start searching from the
-beginning anew even when SEARCH has been used interactively or
-elements of another stream returned by this function have already
-been requested.
-
-The elements of the returned stream will have the form
-
- \(buffer match-beg file\)
-
-where BUFFER or FILE is the buffer or file where a match has been
-found (exactly one of the two will be nil), and MATCH-BEG is the
-position of the beginning of the match."
- (let* ((search (if dont-copy search (el-search-reset-search
(copy-el-search-object search))))
- (head (el-search-object-head search)))
- (seq-filter
- #'identity ;we use `nil' as a "skip" tag
- (funcall
- (letrec ((get-stream
- (lambda ()
- (stream-make
- (if-let ((buffer (or (el-search-head-buffer head)
- (el-search--next-buffer search nil
t))))
- (with-current-buffer buffer
- (save-excursion
- (goto-char (el-search-head-position head))
- (el-search--message-no-log "%s"
- (or (el-search-head-file
head)
-
(el-search-head-buffer head)))
- (if-let ((match (el-search--search-pattern-1
- (el-search-head-matcher head)
- t nil
(el-search-head-heuristic-matcher head))))
- (progn
- (setf (el-search-object-last-match search)
- (copy-marker (point)))
- (el-search--skip-expression nil t)
- (setf (el-search-head-position head)
- (copy-marker (point)))
- (cons ;Return the cons defining the build
recipe of the stream
- (list (el-search-head-buffer head)
- match
- (el-search-head-file head))
- (funcall get-stream)))
- (setf (el-search-head-buffer head) nil
- (el-search-head-file head) nil)
- (el-search--next-buffer search nil t)
- ;; retry with the next buffer
- (cons nil (funcall get-stream)))))
- ;; end of stream (no buffers left to search in)
- nil)))))
- get-stream)))))
-
-(defun el-search--set-head-pattern (head pattern)
- (setf (el-search-head-matcher head)
- (el-search-make-matcher pattern))
- (let ((hm (el-search-heuristic-matcher pattern)))
- (setf (el-search-head-heuristic-matcher head) hm)
- (setf (el-search-head-heuristic-buffer-matcher head)
- (el-search-heuristic-buffer-matcher pattern hm)))
- head)
-
-(defun el-search-compile-pattern-in-search (search)
- (el-search--set-head-pattern (el-search-object-head search)
- (el-search-object-pattern search)))
-
-(defun el-search-make-search (pattern get-buffer-stream)
- "Create and return a new `el-search-object' instance.
-PATTERN is the pattern to search, and GET-BUFFER-STREAM a
-function that returns a stream of buffers and/or files to search
-in, in order, when called with no arguments."
- (letrec ((search
- (make-el-search-object
- :pattern pattern
- :head (make-el-search-head
- :get-buffer-stream get-buffer-stream
- :buffers (funcall get-buffer-stream))
- :get-matches (lambda () (el-search--all-matches search)))))
- (el-search-compile-pattern-in-search search)
- search))
-
-(defun el-search-reset-search (search)
- "Reset SEARCH."
- (let ((head (el-search-object-head search)))
- (setf (el-search-head-buffers head)
- (funcall (el-search-head-get-buffer-stream head)))
- (setf (el-search-head-buffer head) nil)
- (setf (el-search-head-file head) nil)
- (setf (el-search-head-position head) nil)
- (setf (el-search-object-last-match search) nil)
- (el-search-compile-pattern-in-search search)
- search))
-
-
-;;;###autoload
-(defun el-search-loop-over-bindings (function)
- (cl-flet ((keybind (apply-partially #'funcall function)))
-
- (keybind emacs-lisp-mode-map ?s #'el-search-pattern)
- (keybind emacs-lisp-mode-map ?r #'el-search-pattern-backward)
- (keybind emacs-lisp-mode-map ?n #'el-search-pattern)
- (keybind emacs-lisp-mode-map ?p #'el-search-pattern-backward)
- (keybind emacs-lisp-mode-map ?% #'el-search-query-replace)
- (keybind emacs-lisp-mode-map ?h #'el-search-this-sexp) ;h like
in "highlight" or "here"
- (keybind global-map ?j #'el-search-jump)
- (keybind global-map ?a #'el-search-from-beginning)
- (keybind global-map ?< #'el-search-from-beginning)
- (keybind emacs-lisp-mode-map ?> #'el-search-last-buffer-match)
- (keybind global-map ?d #'el-search-skip-directory)
- (keybind global-map ?x
#'el-search-continue-in-next-buffer)
-
- (keybind global-map ?o #'el-search-occur)
-
- (keybind el-search-read-expression-map ?s #'exit-minibuffer)
- (keybind el-search-read-expression-map ?r #'exit-minibuffer)
- (keybind el-search-read-expression-map ?o
#'el-search-set-occur-flag-exit-minibuffer)
-
- (keybind isearch-mode-map ?s #'el-search-search-from-isearch)
- (keybind isearch-mode-map ?r
#'el-search-search-backward-from-isearch)
- (keybind isearch-mode-map ?% #'el-search-replace-from-isearch)
- (keybind isearch-mode-map ?o #'el-search-occur-from-isearch)
-
- (keybind global-map ?e #'el-search-emacs-elisp-sources)
- (keybind global-map ?l #'el-search-load-path)
- (keybind global-map ?b #'el-search-buffers)
-
- (defvar dired-mode-map)
- (defvar ibuffer-mode-map)
-
- (with-eval-after-load 'dired
- (keybind dired-mode-map ?s #'el-search-dired-marked-files))
- (with-eval-after-load 'ibuffer
- (keybind ibuffer-mode-map ?s #'el-search-ibuffer-marked-buffers))))
-
-(defun el-search-pause-search ()
- "Exit el-search normally.
-
-You also can invoke any other non-search command to exit an el-search
-normally - the state of the current search is automatically saved in
-any case."
- (interactive)
- nil)
-
-(defun el-search--set-search-origin-maybe ()
- (unless (el-search--pending-search-p)
- (setq el-search--search-origin
- (list (copy-marker (point))
- (selected-window)))))
-
-(defun el-search-keyboard-quit (&optional dont-quit)
- "Abort el-search, signaling quit.
-Go back to the place where the search had been started."
- (interactive)
- (setq el-search--success nil)
- (el-search-hl-post-command-fun 'stop) ;clear highlighting
- (let ((w (cadr el-search--search-origin)))
- (when (window-live-p w)
- (select-frame-set-input-focus (window-frame w))
- (select-window w)))
- (switch-to-buffer (marker-buffer (car el-search--search-origin)))
- (goto-char (car el-search--search-origin))
- (unless dont-quit (signal 'quit nil)))
-
-(defvar el-search-help-map (make-sparse-keymap))
-
-(defvar el-search-basic-transient-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "RET") #'el-search-pause-search)
- (define-key map "\C-g" #'el-search-keyboard-quit)
- (define-key map [??] #'el-search-help-list-bindings)
- (define-key map `[,help-char] el-search-help-map)
- (define-key map [help] el-search-help-map)
- (define-key map [f1] el-search-help-map)
- ;; (define-key map [remap point-to-register] #'el-search-to-register)
- map))
-
-(defvar el-search-prefix-key-transient-map
- (let ((transient-map (make-sparse-keymap)))
- (el-search-loop-over-bindings
- (lambda (_map key command)
- (when (memq command '(el-search-pattern
- el-search-pattern-backward
- el-search-jump
- el-search-query-replace
- el-search-from-beginning
- el-search-last-buffer-match
- el-search-skip-directory
- el-search-continue-in-next-buffer
- el-search-occur))
- (define-key transient-map (vector key) command))))
-
- ;; v and V are analogue to Ediff - FIXME: this doesn't fit into the
- ;; `el-search-loop-over-bindings' abstraction
- (define-key transient-map [?v] #'el-search-scroll-down)
- (define-key transient-map [?V] #'el-search-scroll-up)
-
- (set-keymap-parent transient-map el-search-basic-transient-map)
- transient-map))
-
-(defun el-search-keep-session-command-p (command)
- "Non-nil when COMMAND should not deactivate the current search.
-
-The default is to allow scrolling commands when
-`el-search-allow-scroll' is non-nil and `mouse-set-point'.
-
-For controlling which commands should or should not deactivate an
-active search it is recommended to advice this function."
- (or (and el-search-allow-scroll
- (symbolp command)
- (or (get command 'isearch-scroll) ;isearch is preloaded
- (get command 'scroll-command)))
- (memq command '(mouse-drag-region mouse-set-point))))
-
-(defun el-search-prefix-key-maybe-set-transient-map ()
- (set-transient-map
- (if el-search-use-transient-map
- el-search-prefix-key-transient-map
- el-search-basic-transient-map)
- (lambda () (or (memq this-command el-search-keep-transient-map-commands)
- (el-search-keep-session-command-p this-command)))))
-
-(defun el-search-shift-bindings-bind-function (map key command)
- (define-key map `[(control ,@(if (<= ?a key ?z) `(shift ,key) `(,key)))]
command))
-
-;;;###autoload
-(defun el-search-install-shift-bindings ()
- (interactive)
- (setq el-search-use-transient-map nil)
- (el-search-loop-over-bindings #'el-search-shift-bindings-bind-function)
- (define-key el-search-basic-transient-map [C-S-next]
#'el-search-scroll-down)
- (define-key el-search-basic-transient-map [C-S-prior] #'el-search-scroll-up))
-
-(defun el-search-bind-under-prefix-key-function (prefix)
- (lambda (map key command)
- (unless (memq map (list el-search-read-expression-map isearch-mode-map))
- (define-key map `[,@(seq-into prefix 'list) ,key] command))))
-
-;;;###autoload
-(defun el-search-install-bindings-under-prefix (prefix-key)
- (el-search-loop-over-bindings
- (el-search-bind-under-prefix-key-function prefix-key))
- (setq el-search-use-transient-map t))
-
-(defun el-search-setup-search-1 (pattern get-buffer-stream &optional
from-here setup-function)
- (unless el-search-occur-flag
- (el-search--set-search-origin-maybe)
- (setq el-search--success nil))
- (setq el-search--current-search
- (el-search-make-search pattern get-buffer-stream))
- (when setup-function (funcall setup-function el-search--current-search))
- (ring-insert el-search-history el-search--current-search)
- (when from-here (setq el-search--temp-buffer-flag nil))
- (unless el-search-occur-flag
- (el-search-prefix-key-maybe-set-transient-map)))
-
-(defun el-search-setup-search (pattern get-buffer-stream &optional
setup-function from-here)
- "Create and start a new el-search.
-PATTERN is the search pattern. GET-BUFFER-STREAM is a function
-of no arguments that should return a stream of buffers and/or
-files (i.e. file names) to search in.
-
-With optional FROM-HERE non-nil, the first buffer in this stream
-should be the current buffer, and searching will start at the
-current buffer's point instead of its beginning."
- (el-search-setup-search-1 pattern get-buffer-stream nil setup-function)
- (if (not el-search-occur-flag)
- (el-search-continue-search from-here)
- (setq el-search-occur-flag nil)
- (el-search-occur)))
-
-(defun el-search-stream-of-directory-files (&optional directory recurse)
- "Return a stream of emacs-lisp files in DIRECTORY.
-DIRECTORY defaults to `default-directory'. The returned stream
-will recurse into DIRECTORY's subdirectories when RECURSE is
-non-nil. Subdirectories whose name is matched by one of the
-`el-search-ignored-directory-regexps' are excluded. When
-`el-search-respect-nosearch' has a non-nil value, subdirectories
-that contain a file named \".nosearch\" are excluded as well."
- (stream-of-directory-files
- (or directory default-directory)
- t nil
- (and recurse
- (lambda (dir-name)
- (not (or (cl-some (lambda (regexp) (string-match-p regexp
(file-name-nondirectory dir-name)))
- el-search-ignored-directory-regexps)
- (and
- el-search-respect-nosearch
- (directory-files dir-name nil (rx bos ".nosearch" eos)
t))))))
- t #'el-search--elisp-file-p))
-
-
-;;;; Help stuff
-
-(make-help-screen el-search-help-for-help-internal
- "Type a help option: [bmikp] or ?"
- "You have typed %THIS-KEY%, the help character. Type a Help option:
-\(Type \\<help-map>\\[help-quit] to exit or \
-\\<help-map>\\[help-quit] \\[el-search-jump] to \
-continue searching.)
-
-b Display el-search key bindings.
-m Display key bindings with some documentation.
-i Read the introduction.
-k KEYS Display full documentation of key sequence.
-p List defined patterns.
-
-You can't type here other help keys available in the global help
-map until you finished el-searching."
- el-search-help-map)
-
-(defun el-search-help-for-help ()
- (interactive)
- (let ((display-buffer-overriding-action '(nil (inhibit-same-window . t))))
- (el-search-help-for-help-internal)))
-
-(defun el-search-help-list-bindings--1 (&optional verbose)
- (cl-flet* ((keys-string
- (lambda (cmd-name)
- (let* ((get-keys
- (lambda (&optional map)
- (seq-filter
- (lambda (binding)
- (pcase binding
- ((seq 'menu-bar) nil)
- (_ t)))
- (where-is-internal cmd-name (and map (list map))))))
- (tmap (if el-search-use-transient-map
- el-search-prefix-key-transient-map
- el-search-basic-transient-map))
- (keys (nreverse (or (funcall get-keys tmap)
- (funcall get-keys)))))
- (if keys (mapconcat #'key-description keys ", ")
- "no key"))))
- (cmd-help
- (lambda (cmd-name)
- (let* ((maxl 34)
- (add-padding
- (lambda (s)
- (let ((sl (length s)))
- (concat (if (<= maxl sl) s
- (concat s " " (make-string (- maxl sl 1)
?.)))
- " ")))))
- (princ (if verbose
- (concat
- "`" (symbol-name cmd-name) "'"
- " (" (keys-string cmd-name) ")\n"
- (when-let ((docstring (documentation cmd-name)))
- (string-match (rx (group bos (0+ nonl) eol))
docstring)
- (concat (match-string 1 docstring) "\n"))
- "\n")
- (concat " "
- (funcall add-padding (symbol-name cmd-name))
- (keys-string cmd-name)
- "\n")))))))
- (princ "Bindings for controlling el-searches:\n\n")
- (cmd-help 'el-search-pattern)
- (cmd-help 'el-search-pattern-backward)
- (cmd-help 'el-search-help-list-bindings)
- (cmd-help 'el-search-help-list-bindings-verbose)
- (cmd-help 'el-search-pause-search)
- (cmd-help 'el-search-keyboard-quit)
- (cmd-help 'el-search-occur)
- (cmd-help 'el-search-jump)
- (cmd-help 'el-search-from-beginning)
- (cmd-help 'el-search-last-buffer-match)
- (cmd-help 'el-search-scroll-down)
- (cmd-help 'el-search-scroll-up)
- (cmd-help 'el-search-continue-in-next-buffer)
- (cmd-help 'el-search-skip-directory)
- (cmd-help 'el-search-to-register)
- (cmd-help 'el-search-query-replace)
- (unless verbose (princ (substitute-command-keys "
-Toggle visibility of this window with \
-`\\<el-search-basic-transient-map>\\[el-search-help-list-bindings]'"))))
- standard-output)
-
-(defun el-search-help-list-bindings ()
- "Toggle quick help window."
- (interactive)
- (setq this-command 'el-search-pattern)
- (unless (el-search-close-quick-help-maybe)
- (let ((help-buffer (get-buffer-create el-search-quick-help-buffer-name)))
- (with-current-buffer help-buffer
- (let ((inhibit-read-only t))
- (erase-buffer)))
- (let ((standard-output help-buffer))
- (el-search-help-list-bindings--1))
- (let ((help-window (display-buffer-pop-up-window help-buffer '())))
- (fit-window-to-buffer help-window)
- (with-current-buffer help-buffer
- (setq-local el-search-help-window help-window))))))
-
-(defun el-search-help-list-bindings-verbose ()
- "List bindings and first lines of documentation."
- (interactive)
- (with-help-window (help-buffer)
- (el-search-help-list-bindings--1 'verbose)))
-
-(defun el-search-help-read-intro ()
- (interactive)
- (with-output-to-temp-buffer "*Help*"
- (princ "\
-Introduction to El-Search
-=========================\n\n\n")
- (princ (string-trim
- (replace-regexp-in-string
- "^;+ ?" ""
- (with-temp-buffer
- (insert-file-contents (locate-library "el-search.el"))
- (save-excursion
- (search-forward ";;; Commentary:")
- (buffer-substring-no-properties
- (point)
- (progn (search-forward ";; Acknowledgments")
- (forward-line -1)
- (point))))))))))
-
-(define-key el-search-help-map `[,help-char] #'el-search-help-for-help)
-(define-key el-search-help-map [help] #'el-search-help-for-help)
-(define-key el-search-help-map [f1] #'el-search-help-for-help)
-(define-key el-search-help-map [??] #'el-search-help-for-help)
-(define-key el-search-help-map [?b] #'el-search-help-list-bindings)
-(define-key el-search-help-map [?m] #'el-search-help-list-bindings-verbose)
-(define-key el-search-help-map [?p] #'el-search-list-defined-patterns)
-(define-key el-search-help-map [?i] #'el-search-help-read-intro)
-(define-key el-search-help-map [?k] #'describe-key)
-(define-key el-search-help-map [?q] #'help-quit)
-
-
-;;;; Additional pattern type definitions
-
-(defun el-search--simple-regexp-like-p (object)
- (or (atom object)
- (functionp object)
- (and (consp object)
- (if (fboundp 'proper-list-p) (proper-list-p object) t)
- (not (consp (car object))))))
-
-(defun el-search-regexp-like-p (object)
- "Return non-nil when OBJECT is regexp like.
-
-In el-search, a regexp-like is either an expression evaluating to
-a normal regexp (e.g. a string or an `rx' form; it is evaluated
-once when a pattern is compiled) or a function accepting a string
-argument that can be used directly as a predicate for match
-testing, or a list of the form
-
- \(BINDINGS X\)
-
-where BINDINGS is a let-style list of variable bindings and X one
-of the above.
-
-Example: (((case-fold-search nil)) (rx bos \"a\")) is a
-regexp-like matching any string starting with lower case \"a\"."
- (pcase object
- ((pred el-search--simple-regexp-like-p) t)
- (`(,(and (pred listp) bindings)
- ,(pred el-search--simple-regexp-like-p))
- (cl-every
- (lambda (binding)
- (pcase binding ((or (pred symbolp) `(,(pred symbolp)) `(,(pred
symbolp) ,_)) t)))
- bindings))))
-
-(defun el-search--string-matcher (regexp-like)
- "Return a compiled match predicate for REGEXP-LIKE.
-This is a predicate returning non-nil when the
-`el-search-regexp-like-p' REGEXP-LIKE matches the (only)
-argument (that should be a string)."
- (let ((regexp) (match-bindings ()))
- (pcase-exhaustive regexp-like
- ((pred el-search--simple-regexp-like-p) (setq regexp regexp-like))
- (`(,(and (pred listp) binds) ,real-regexp)
- (setq regexp real-regexp)
- (setq match-bindings binds)))
- (cl-flet ((wrap-let
- (lambda (bindings body)
- (if (null bindings) body
- `(let ,bindings ,body)))))
- (el-search--byte-compile
- (let ((string (make-symbol "string")))
- `(lambda (,string)
- ,(wrap-let
- match-bindings
- (if (functionp regexp)
- `(funcall #',regexp ,string)
- `(string-match
- ,(pcase (eval regexp t)
- ((and (pred stringp) s) s)
- (_ (error "Expression in regexp-like doesn't eval to a
string: %S" regexp)))
- ,string)))))))))
-
-(el-search-defpattern string (&rest regexps)
- "Matches any string that is matched by all REGEXPS.
-Any of the REGEXPS is `el-search-regexp-like-p'.
-
-If multiple REGEXPS are given, they don't need to match in order,
-so (string \"bar\" \"foo\") matches \"foobar\" for example."
- (declare (heuristic-matcher
- (lambda (&rest regexps)
- (let ((matchers (mapcar #'el-search--string-matcher regexps)))
- (lambda (_ atoms-thunk)
- (cl-some
- (lambda (atom)
- (and (stringp atom)
- (cl-every (lambda (matcher) (funcall matcher atom))
matchers)))
- (thunk-force atoms-thunk)))))))
- (el-search-defpattern--check-args "string" regexps #'el-search-regexp-like-p)
- `(and (pred stringp)
- ,@(mapcar (lambda (regexp) `(pred ,(el-search--string-matcher regexp)))
- regexps)))
-
-(el-search-defpattern symbol (&rest regexps)
- "Matches any symbol whose name is matched by all REGEXPS.
-Any of the REGEXPS is `el-search-regexp-like-p'.
-
-This pattern is equivalent to
-
- `(and (pred symbolp)
- (app symbol-name (string ,@regexps)))
-
-Example: to replace all symbols with names starting with \"foo-\"
-to start with \"bar-\" instead, you would use
-`el-search-query-replace' with a rule like this:
-
- (and (symbol (rx bos \"foo-\" (group (+ nonl)))) s) >
- (intern (concat \"bar-\" (match-string 1 (symbol-name s))))"
- (declare (heuristic-matcher
- (lambda (&rest regexps)
- (let ((matchers (mapcar #'el-search--string-matcher regexps)))
- (lambda (_ atoms-thunk)
- (cl-some
- (lambda (atom)
- (when-let ((symbol-name (and (symbolp atom) (symbol-name
atom))))
- (cl-every (lambda (matcher) (funcall matcher
symbol-name)) matchers)))
- (thunk-force atoms-thunk)))))))
- (el-search-defpattern--check-args "symbol" regexps #'el-search-regexp-like-p)
- `(and (pred symbolp) (app symbol-name (string ,@regexps))))
-
-(defun el-search--contains-p (matcher expr)
- "Return non-nil when expression tree EXPR contains a match for MATCHER.
-MATCHER is a matcher for the el-search pattern to match. Recurse
-on all types of sequences el-search does not treat as atomic.
-Matches are not restricted to atoms; for example
-
- (el-search--contains-p (el-search-make-matcher ''(2 3)) '(1 (2 3)))
-
-succeeds.
-
-In the positive case the return value is (t elt), where ELT is a
-matching element found in EXPR."
- (if (el-search--match-p matcher expr)
- (list t expr)
- (and (sequencep expr)
- (let ((try-match (apply-partially #'el-search--contains-p matcher)))
- (if (consp expr)
- (or (funcall try-match (car expr))
- (funcall try-match (cdr expr))) ;(1)
- (cl-some try-match expr))))))
-;; (1) This means we consider (a b c) to "contain" (b c). Because we
-;; want (a . (b c)) [a syntax common e.g. for notation of alists] to
-;; "contain" (b c), and we don't want the matching behavior to depend
-;; on actual reader syntax.
-
-(el-search-defpattern contains (&rest patterns)
- "Matches expressions that contain a match for all PATTERNs.
-
-Example:
-
- \(contains (string \"H\") 17)
-
-matches
-
- \((\"Hallo\") x (5 [1 17])).
-
-The tested expression itself is included, so for example `1' is
-matched by \(contains 1\)."
- (declare (heuristic-matcher
- (lambda (&rest patterns)
- (let ((matchers (mapcar #'el-search-heuristic-matcher patterns)))
- (lambda (file-name-or-buffer atoms-thunk)
- (cl-every (lambda (matcher) (funcall matcher
file-name-or-buffer atoms-thunk))
- matchers))))))
- (cond
- ((null patterns) '_)
- ((null (cdr patterns))
- (let ((pattern (car patterns)))
- `(app ,(apply-partially #'el-search--contains-p (el-search-make-matcher
pattern))
- `(t ,,pattern)))) ; Match again to establish bindings PATTERN
should create
- (t `(and ,@(mapcar (lambda (pattern) `(contains ,pattern)) patterns)))))
-
-(defun el-search--in-buffer-matcher (&rest atoms)
- ;; We only allow atoms here because this works with heuristic matching
- ;; and allowing arbitrary patterns would produce false positives
- (let* ((hms (mapcar #'el-search-heuristic-buffer-matcher atoms))
- (test-buffer (el-search-with-short-term-memory
- (lambda (file-name-or-buffer)
- (let ((inhibit-message t))
- (cl-every (lambda (hm) (funcall hm
file-name-or-buffer)) hms))))))
- (lambda (file-name-or-buffer _) (funcall test-buffer
file-name-or-buffer))))
-
-(el-search-defpattern in-buffer (&rest atoms)
- "Matches anything in buffers containing all ATOMS.
-
-This pattern type matches anything, but only in files or buffers
-that contain all of the ATOMS. In all other files and buffers it
-never matches."
- (declare (heuristic-matcher #'el-search--in-buffer-matcher))
- (el-search-defpattern--check-args
- "in-buffer" atoms
- (lambda (arg)
- (pcase arg
- ((or (pred el-search--atomic-p) `',(pred el-search--atomic-p) ``,(pred
el-search--atomic-p))
- t)))
- "argument not atomic")
- (let ((in-buffer-matcher (apply #'el-search--in-buffer-matcher atoms)))
- `(guard (funcall ',in-buffer-matcher (current-buffer) nil))))
-
-(el-search-defpattern in-file (&rest atoms)
- "Synonymous with `in-buffer' for buffers with an associated file.
-
-This is like `in-buffer' but only matches in buffers with an
-associated `buffer-file-name'."
- `(and (filename) (in-buffer ,@atoms)))
-
-(el-search-defpattern not (pattern)
- "Matches anything that is not matched by PATTERN."
- (declare
- (heuristic-matcher ;We can't just negate the hm of the PATTERN...
- (lambda (pattern)
- (pcase pattern
- ;; We currently only handle (not (PNAME . ARGS)) where PNAME is the
- ;; name of a pattern type with an inverse heuristic matcher definition
- ((and `(,name . ,args)
- (let inverse-heuristic-matcher (alist-get name
el-search--inverse-heuristic-matchers))
- (guard inverse-heuristic-matcher))
- (if (eq t inverse-heuristic-matcher)
- (when-let ((heuristic-matcher
- (apply (alist-get name el-search--heuristic-matchers)
args)))
- (lambda (file-name-or-buffer atoms-thunk)
- (not (funcall heuristic-matcher file-name-or-buffer
atoms-thunk))))
- (apply inverse-heuristic-matcher args)))))))
- `(app ,(apply-partially #'el-search--match-p (el-search-make-matcher
pattern))
- (pred not)))
-
-(defalias 'el-search--symbol-file-matcher
- (el-search-with-short-term-memory
- (lambda (_current-load-history regexp-like)
- ;; We enclosure a prepared hash table containing all the symbols "in"
- (let ((table (make-hash-table))
- (file-name-matches-p
- (let ((string-matcher (el-search--string-matcher regexp-like)))
- (lambda (file-name) (funcall string-matcher
(file-name-sans-extension
-
(file-name-nondirectory file-name)))))))
- (pcase-dolist (`(,file-name . ,definitions) load-history)
- (when (and (stringp file-name)
- (funcall file-name-matches-p file-name))
- (dolist (definition definitions)
- (pcase definition
- ((or (and (pred symbolp) symbol)
- (and `(,type . ,symbol)
- (guard (not (memq type '(autoload require)))))
- `(cl-defmethod ,symbol . ,_))
- (ignore (bound-and-true-p type))
- (puthash symbol t table))))))
- (lambda (symbol) (and (symbolp symbol) (gethash symbol table)))))))
-
-(el-search-defpattern symbol-file (regexp)
- "Matches any symbol whose `symbol-file' is matched by REGEXP.
-
-This pattern type matches when the object is a symbol for that
-`symbol-file' returns a (non-nil) FILE-NAME so that
-
- (file-name-sans-extension (file-name-nondirectory FILENAME)))
-
-is matched by the `el-search-regexp-like-p' REGEXP."
- (declare
- (heuristic-matcher
- (lambda (regexp)
- (lambda (_ atoms-thunk)
- (cl-some (el-search--symbol-file-matcher
- (copy-sequence load-history)
- regexp)
- (thunk-force atoms-thunk))))))
- (el-search-defpattern--check-args "symbol-file" (list regexp)
#'el-search-regexp-like-p)
- (let ((this (make-symbol "this")))
- `(and ,this
- (guard (funcall (el-search--symbol-file-matcher (copy-sequence
load-history)
- ',regexp)
- ,this)))))
-
-(defun el-search--filename-matcher (&rest regexps)
- ;; Return a file name matcher for the REGEXPS. This is a predicate
- ;; accepting two arguments that returns non-nil when the first
- ;; argument is a file name (i.e. a string) that is matched by all
- ;; `el-search-regexp-like-p' REGEXPS, or a buffer whose associated file
- ;; name matches accordingly. It ignores the second argument.
- (let ((get-file-name (lambda (file-name-or-buffer)
- (if (bufferp file-name-or-buffer)
- (buffer-file-name file-name-or-buffer)
- file-name-or-buffer))))
- (if (not regexps)
- (lambda (file-name-or-buffer _) (funcall get-file-name
file-name-or-buffer))
- (let* ((regexp-matchers (mapcar #'el-search--string-matcher regexps))
- (test-file-name-or-buffer
- (el-search-with-short-term-memory
- (lambda (file-name-or-buffer)
- (when-let ((file-name (funcall get-file-name
file-name-or-buffer)))
- (cl-every (lambda (matcher) (funcall matcher file-name))
regexp-matchers))))))
- (lambda (file-name-or-buffer _) (funcall test-file-name-or-buffer
file-name-or-buffer))))))
-
-(el-search-defpattern filename (&rest regexps)
- "Matches anything when the searched buffer has an associated file.
-
-With any `el-search-regexp-like-p' REGEXPS given, the file's
-absolute name must be matched by all of them."
- ;;FIXME: should we also allow to match the f-n-nondirectory and
- ;;f-n-sans-extension? Maybe it could become a new pattern type named
`feature'?
- (declare (heuristic-matcher #'el-search--filename-matcher)
- (inverse-heuristic-matcher t))
- (el-search-defpattern--check-args "filename" regexps
#'el-search-regexp-like-p)
- (let ((file-name-matcher (apply #'el-search--filename-matcher regexps)))
- ;; We can't expand to just t because this would not work with `not'.
- ;; `el-search--filename-matcher' caches the result, so this is still a
- ;; pseudo constant
- `(guard (funcall ',file-name-matcher (current-buffer) nil))))
-
-
-;;;; Highlighting
-
-(defvar-local el-search-hl-overlay nil)
-
-(defvar-local el-search-hl-other-overlays '())
-
-(defvar el-search-keep-hl nil
- "Non-nil indicates we should not remove any highlighting.")
-
-(defun el-search--scroll-sexp-in-view (bounds)
- ;; Try to make the sexp bounded by BOUNDS (which is a list (BEG END))
- ;; better visible. This tries to scroll (cadr BOUNDS) into view when
- ;; necessary, and to center the sexp.
- (when el-search-fancy-scrolling
- (let ((wheight (window-height)))
- ;; FIXME: make the following integer constants customizable,
- ;; presumably, named in analogy to the scroll- options?
- (unless (pos-visible-in-window-p
- ;; Don't adjust scrolling when the sexp is already completely
visible
- (save-excursion (goto-char (cadr bounds))
- (line-end-position (max +3 (/ wheight 25)))))
- (cl-flet ((signed-screen-lines-count
- (lambda (a b) (funcall (if (< b a) #'- #'identity )
- (count-screen-lines a b)))))
-
- (condition-case nil
- (scroll-up (min
- (max
- ;; make at least sexp end + a small margin visible
- (+ (signed-screen-lines-count (window-end) (cadr
bounds))
- (max 2 (/ wheight 4)))
-
- ;; also try to center current sexp - this is
- ;; / l(window-start) + l(window-end) l(car
bounds) + l(cdr bounds) \
- ;; #lines | -------------------------------,
----------------------------- |
- ;; \ 2
2 /
- (/ (+ (signed-screen-lines-count (window-start)
(car bounds))
- (signed-screen-lines-count (window-end)
(cadr bounds)))
- 2))
-
- ;; but also ensure at least a small margin is left
between point and
- ;; window start
- (- (signed-screen-lines-count (window-start) (car
bounds))
- 3)))
- ((beginning-of-buffer end-of-buffer) nil)))))))
-
-(defun el-search-hl-sexp (&optional bounds)
- (let ((bounds (or bounds (list (point) (el-search--end-of-sexp)))))
- (if (overlayp el-search-hl-overlay)
- (apply #'move-overlay el-search-hl-overlay bounds)
- (overlay-put (setq el-search-hl-overlay (apply #'make-overlay bounds))
- 'face 'el-search-match))
- (overlay-put el-search-hl-overlay 'priority 1002)
-
- ;; Vertically scroll the current sexp into view when appropriate -- we
- ;; must redisplay to get updated window bounds. The selected frame
- ;; must apparently be displayed for this to work.
- (while (not (eq t (frame-visible-p (selected-frame))))
- (sleep-for .1))
- (apply #'el-search-unhide-invisible bounds)
- (redisplay)
- (el-search--scroll-sexp-in-view bounds))
-
- (add-hook 'post-command-hook #'el-search-hl-post-command-fun t t))
-
-(defun el-search--hl-other-matches-1 (matcher from to)
- ;; Highlight all matches between FROM and TO with face
- ;; `el-search-other-match'.
- (mapc #'delete-overlay el-search-hl-other-overlays)
- (setq el-search-hl-other-overlays '())
- (let (this-match-beg this-match-end (done nil))
- (save-excursion
- (goto-char from)
- (while (not done)
- (setq this-match-beg (el-search--search-pattern-1 matcher t))
- (if (not this-match-beg)
- (setq done t)
- (goto-char this-match-beg)
- (setq this-match-end (el-search--end-of-sexp))
- (let ((ov (make-overlay this-match-beg this-match-end)))
- (overlay-put ov 'face 'el-search-other-match)
- (overlay-put ov 'priority 1001)
- (push ov el-search-hl-other-overlays)
- (goto-char this-match-end)
- (when (>= (point) to) (setq done t))))))))
-
-(defvar-local el-search--buffer-match-count-data nil
- "Holds information for displaying a match count.
-The value is a list of elements
-
- \(SEARCH BUFFER-CHARS-MOD-TICK (POINT-MIN POINT-MAX) MATCHES\)
-
-MATCHES is a stream of matches in this buffer. The other values
-are used to check validity.")
-
-(defun el-search-display-match-count (&optional just-count animator)
- "Display an x/y-style match count in the echo area.
-With optional argument JUST-COUNT non-nil, only return a string,
-don't display anything"
- (when (or just-count (and el-search--success (not el-search--wrap-flag)))
- (prog1
- (let ((el-search--search-pattern-1-do-fun animator))
- (while-no-input
- (apply (if just-count #'format
- (lambda (&rest args)
- (setq el-search--last-message (apply
#'el-search--message-no-log args))))
- (progn
-
- ;; Check whether cached stream of buffer matches is still
valid
- (pcase el-search--buffer-match-count-data
- ((or
- (and `(,(and (pred el-search-object-p)
- (pred (eq el-search--current-search)))
- . ,_)
- (pred (eq
el-search--this-session-match-count-data)))
- `(,(pred (eq el-search--current-search))
- ,(pred (eq (buffer-chars-modified-tick)))
- (,(pred (eq (point-min))) ,(pred (eq (point-max))))
. ,_)))
-
- (_
- ;; (message "Refreshing match count data") (sit-for 1)
- (redisplay) ;don't delay highlighting
- (setq-local el-search--buffer-match-count-data
- (let ((stream-of-buffer-matches
- (seq-map #'cadr
- (el-search--all-matches
- (el-search-make-search
-
(el-search--current-pattern)
- (let ((current-buffer
(current-buffer)))
- (lambda () (stream
(list current-buffer)))))
- 'dont-copy))))
- (list
- el-search--current-search
- (buffer-chars-modified-tick)
- `(,(point-min) ,(point-max))
- stream-of-buffer-matches)))
- (setq el-search--this-session-match-count-data
- el-search--buffer-match-count-data)))
-
- (let ((pos-here (point)) (matches-<=-here 1) total-matches
- (defun-bounds (or (el-search--bounds-of-defun)
(cons (point) (point))))
- (matches-<=-here-in-defun 1)
(total-matches-in-defun 0)
- (largest-match-start-not-after-pos-here nil))
- (pcase-let ((`(,_ ,_ ,_ ,matches)
el-search--buffer-match-count-data))
- (setq total-matches (let ((inhibit-message t))
(seq-length matches)))
- (while (and (not (stream-empty-p matches))
- (< (stream-first matches) (cdr
defun-bounds)))
- (when (<= (stream-first matches) pos-here)
- (setq largest-match-start-not-after-pos-here
(stream-first matches))
- (unless (= (stream-first matches) pos-here)
- (cl-incf matches-<=-here)))
- (when (<= (car defun-bounds) (stream-first matches))
- (cl-incf total-matches-in-defun)
- (when (< (stream-first matches) pos-here)
- (cl-incf matches-<=-here-in-defun)))
- (stream-pop matches))
- (if (zerop total-matches)
- (list "(No matches)")
- (let* ((at-a-match-but-not-at-match-beginning
- (and largest-match-start-not-after-pos-here
- (and (<
largest-match-start-not-after-pos-here pos-here)
- (save-excursion
- (goto-char
largest-match-start-not-after-pos-here)
- (<= pos-here
(el-search--end-of-sexp))))))
- (at-a-match
- (and largest-match-start-not-after-pos-here
- (or (= pos-here
largest-match-start-not-after-pos-here)
-
at-a-match-but-not-at-match-beginning))))
- (when (or at-a-match-but-not-at-match-beginning
- (not at-a-match))
- (cl-decf matches-<=-here)
- (cl-decf matches-<=-here-in-defun))
- (if at-a-match
- (let ((buffer-or-file
- (let ((head (el-search-object-head
el-search--current-search)))
- (or (el-search-head-file head)
- (buffer-name
(el-search-head-buffer head))))))
- (if just-count
- (list "%d/%d" matches-<=-here
total-matches)
- (list
- "%s %d/%d %s"
- buffer-or-file
- matches-<=-here
- total-matches
- (format
- (pcase (save-excursion
- (goto-char (car defun-bounds))
- (and (el-search-looking-at
'`(,_ ,_ . ,_))
- (looking-at "(") ;exclude
toplevel `ATOM and sim.
- (let ((region (list
- (progn
(down-list) (point))
- (min
(line-end-position)
-
(scan-sexps (point) 2)))))
- (when (bound-and-true-p
jit-lock-mode)
- (apply
#'jit-lock-fontify-now region))
- (apply
#'buffer-substring region))))
- ((and (pred stringp) signature)
- (format "(%s %%d/%%d)"
- (truncate-string-to-width
- signature
- 40 nil nil 'ellipsis)))
- (_ "(%d/%d)"))
- matches-<=-here-in-defun
total-matches-in-defun))))
- (list
- (concat (if (not just-count) "[Not at a match]
" "")
- (if (= matches-<=-here total-matches)
- (format "(%s/%s <-)"
matches-<=-here total-matches)
- (format "(-> %s/%s)" (1+
matches-<=-here) total-matches)))))))))
- ))))
- (when quit-flag (el-search-keyboard-quit 'dont-quit)))))
-
-(defun el-search-hl-other-matches (matcher)
- "Highlight all visible matches.
-
-Highlight all matches visible in the selected window with face
-`el-search-other-match' and add `el-search--after-scroll' to the
-local binding of `window-scroll-functions'."
- (el-search--hl-other-matches-1 matcher
- (save-excursion
- (goto-char (window-start))
- (beginning-of-defun-raw)
- (point))
- (window-end))
- (add-hook 'window-scroll-functions #'el-search--after-scroll t t))
-
-(defun el-search--after-scroll (_win start)
- (el-search--hl-other-matches-1
- (el-search--current-matcher)
- (save-excursion
- (goto-char start)
- (beginning-of-defun-raw)
- (point))
- (window-end nil t)))
-
-(defun el-search-hl-remove ()
- (when (overlayp el-search-hl-overlay)
- (delete-overlay el-search-hl-overlay))
- (remove-hook 'window-scroll-functions #'el-search--after-scroll t)
- (mapc #'delete-overlay el-search-hl-other-overlays)
- (setq el-search-hl-other-overlays '())
- (el-search-rehide-invisible))
-
-(defvar el-search-hl-post-command-fun--last-animator nil)
-
-(defun el-search-hl-post-command-fun (&optional stop)
- "Do cleanup when last search has obviously been terminated.
-
-If a search is active, arrange to count matches in the background
-and show a match count when done.
-
-With argument STOP non-nil, force cleanup."
- (cl-flet ((stop (lambda ()
- (el-search-hl-remove)
- (remove-hook 'post-command-hook
'el-search-hl-post-command-fun t)
- (setq el-search--temp-buffer-flag nil)
- (el-search-kill-left-over-search-buffers)
- (el-search-close-quick-help-maybe)
- (setq el-search--this-session-match-count-data nil))))
- (pcase this-command
- ((guard stop) (stop))
- ('el-search-query-replace)
- ((guard (el-search--entering-prefix-arg-p))) ; don't hide key input
feedback
- ('el-search-pattern
- (unless (eq this-command last-command)
- (setq el-search-hl-post-command-fun--last-animator
- (el-search--make-display-animation-function
- (lambda (icon)
- (let ((inhibit-message nil))
- (setq el-search--last-message
- (el-search--message-no-log
- "%s %s"
- (let ((head (el-search-object-head
el-search--current-search)))
- (or (el-search-head-file head)
- (el-search-head-buffer head)))
- icon)))))))
- (condition-case-unless-debug err
- (el-search-display-match-count nil
el-search-hl-post-command-fun--last-animator)
- (error (el-search--message-no-log
- "Error counting matches: %s" (error-message-string err)))))
- ((pred el-search-keep-session-command-p))
- (_ (unless el-search-keep-hl (stop))))))
-
-(defun el-search--pending-search-p ()
- (memq #'el-search-hl-post-command-fun post-command-hook))
-
-(defun el-search--reset-wrap-flag ()
- (unless (eq real-this-command
- (if (eq el-search--wrap-flag 'forward)
- 'el-search-pattern
- 'el-search-pattern-backward))
- (remove-hook 'post-command-hook 'el-search--reset-wrap-flag)
- (setq el-search--wrap-flag nil)))
-
-(defun el-search--set-wrap-flag (value)
- (when value
- (add-hook 'post-command-hook #'el-search--reset-wrap-flag t))
- (setq el-search--wrap-flag value))
-
-
-;;;; Core functions
-
-(defun el-search-continue-in-next-buffer ()
- "Skip current search buffer and continue with the next."
- (interactive)
- (el-search--skip-to-next-buffer))
-
-(defun el-search--goto-char-maybe-barf (pos)
- (when (and (buffer-narrowed-p)
- (or (< pos (point-min))
- (< (point-max) pos)))
- (unless (y-or-n-p "\
-Position not accessible in narrowed buffer - really continue?")
- (user-error "Abort")))
- (goto-char pos))
-
-(define-obsolete-function-alias 'el-search-jump-to-search-head
- 'el-search-jump "el-search 1.12.5")
-
-(defun el-search-jump (&optional arg)
- "Jump by matches.
-Select a match, resuming the last search if necessary. The
-prefix argument decides which match is selected:
-
- no prefix arg: select the (last) current match
- 0: go to the match following point
- N: go to the Nth match after `window-start'
--N: go to the Nth match before `window-end'
-
-In a non-interactive call, ARG should be an integer, having the
-same meaning as a numeric prefix arg, or an el-search-object to
-make current, or the symbol t, in which case the user is prompted
-for an older search to resume."
- (interactive "P")
- (el-search--set-search-origin-maybe)
- (when (integerp arg)
- (el-search-barf-if-not-search-buffer
- (current-buffer)
- "Prefix ARG only allowed in current search's current buffer"))
- (when (or (el-search-object-p arg) (eq arg t))
- ;; FIXME: would it be better to include some context around the search
- ;; head - or to even use an overview buffer for selection?
- (setq el-search--current-search
- (if (el-search-object-p arg) arg
- (el-search--read-history-entry
- el-search-history #'el-search--get-search-description-string)))
- (setq el-search--success t)
- (el-search--set-wrap-flag nil))
- (el-search-compile-pattern-in-search el-search--current-search)
- (if-let ((search el-search--current-search)
- (current-head (el-search-object-head search))
- (current-search-buffer (el-search-head-buffer current-head)))
- (if (not (buffer-live-p current-search-buffer))
- (let* ((head-file-name (el-search-head-file current-head))
- (search (el-search-reset-search search))
- (buffer-stream (el-search-head-buffers (el-search-object-head
search)))
- (buffer-stream-from-head-file
- (let ((inhibit-message t))
- (and head-file-name
- (cadr (stream-divide-with-get-rest-fun
- buffer-stream
- (lambda (s)
- (while (and (not (stream-empty-p s))
- (or (not (stringp (stream-first
s)))
- (not (file-equal-p
(stream-first s) head-file-name))))
- (stream-pop s))
- s)))))))
- (message "Search head points to a killed buffer...")
- (sit-for 1)
- (if (or (not head-file-name)
- (stream-empty-p buffer-stream-from-head-file))
- (el-search--message-no-log "Restarting search...")
- (setf (el-search-head-buffers (el-search-object-head search))
- buffer-stream-from-head-file)
- (message "Restarting from %s..." (file-name-nondirectory
head-file-name)))
- (sit-for 2)
- (el-search-continue-search))
- (setq this-command 'el-search-pattern)
- (pop-to-buffer current-search-buffer
el-search-display-next-buffer-action)
- (el-search-protect-search-head
- (let ((last-match (el-search-object-last-match search)))
- (cond
- ((and (not (el-search-object-p arg))
- (< (prefix-numeric-value arg) 0))
- (setq arg (prefix-numeric-value arg))
- (goto-char (window-end)))
- ((not (numberp arg))
- (el-search--goto-char-maybe-barf
- (if (not (and last-match
- ;; this should only happen for bad search patterns
- (eq (marker-buffer last-match) (current-buffer))))
- (el-search-head-position current-head)
- last-match)))
- ((zerop arg) (setq arg 1))
- (t (goto-char (window-start))))
- (let ((match-pos
- (save-excursion
- (el-search--search-pattern-1
- (el-search--current-matcher)
- t nil
- (el-search--current-heuristic-matcher)
- (if (numberp arg) arg 1)))))
- (when (and (numberp arg) (not match-pos))
- (setq el-search--success nil)
- (el-search-hl-post-command-fun 'stop)
- (goto-char (car el-search--search-origin))
- (user-error "No match there"))
- (unless (or (numberp arg) (eq (point) match-pos))
- (message "No match at search head any more - going to the next
match")
- (redisplay)
- ;; Don't just `sit-for' here: `pop-to-buffer' may have
generated frame
- ;; focus events
- (sleep-for 1.5))
- (if (not match-pos)
- (el-search-continue-search)
- (goto-char match-pos)
- (setf (el-search-head-position current-head)
- (copy-marker (point)))
- (setf (el-search-object-last-match el-search--current-search)
- (copy-marker (point)))
- (el-search-hl-sexp)
- (el-search-hl-other-matches (el-search--current-matcher)))))))
- (el-search--message-no-log "[Search completed - restarting]")
- (el-search-revive-search)
- (sit-for 1.5)
- (el-search-continue-search))
- (el-search-prefix-key-maybe-set-transient-map))
-
-(defun el-search-continue-search (&optional from-here)
- "Continue or resume the current search.
-
-With prefix arg FROM-HERE given, the current search buffer should
-be the current buffer, and the search will be resumed from point
-instead of the position where the search would normally be
-continued."
- (interactive "P")
- (el-search--set-this-command-refresh-message-maybe)
- (unless (eq last-command this-command)
- (el-search--set-search-origin-maybe)
- (el-search-compile-pattern-in-search el-search--current-search))
- (el-search-protect-search-head
- (el-search-when-unwind
- (unwind-protect
- (let* ((old-current-buffer (current-buffer))
- (head (el-search-object-head el-search--current-search))
- (current-search-buffer
- (or (el-search-head-buffer head)
- (el-search--next-buffer el-search--current-search))))
- (when from-here
- (cond
- ((eq (current-buffer) current-search-buffer)
- (setf (el-search-head-position head) (copy-marker (point))))
- ((and current-search-buffer (buffer-live-p
current-search-buffer))
- (user-error "Please resume from buffer %s" (buffer-name
current-search-buffer)))
- (current-search-buffer
- (user-error "Search head points to a killed buffer"))))
- (let ((match nil)
- (matcher (el-search--current-matcher))
- (heuristic-matcher (el-search--current-heuristic-matcher)))
- (while (and (el-search-head-buffer head)
- (not (setq match (with-current-buffer
(el-search-head-buffer head)
- (save-excursion
-
(el-search--goto-char-maybe-barf
- (el-search-head-position
head))
- (el-search--search-pattern-1
- matcher t nil
heuristic-matcher))))))
- (el-search--next-buffer el-search--current-search))
- (if (not match)
- (progn
- (if (not (or el-search--success
- (and from-here
- (save-excursion
- (goto-char (point-min))
- (el-search--search-pattern-1
- matcher t nil heuristic-matcher)))))
- (progn
- (el-search--message-no-log "No matches")
- (sit-for .7))
- (el-search--set-wrap-flag 'forward)
- (let ((keys (car (where-is-internal
'el-search-pattern))))
- (el-search--message-no-log
- (if keys
- (format "No (more) matches - Hit %s to wrap
search"
- (key-description keys))
- "No (more) matches")))))
- (let (match-start)
- ;; If (el-search-head-buffer head) is only a worker buffer,
replace it
- ;; with a buffer created with `find-file-noselect'
- (with-current-buffer (el-search-head-buffer head)
- (goto-char match)
- (setq match-start (point))
- (when el-search--temp-file-buffer-flag
- (let ((file-name buffer-file-name))
- (setq buffer-file-name nil) ;prevent f-f-ns to find
this buffer
- (let ((buffer-list-before (buffer-list))
- (new-buffer (find-file-noselect file-name)))
- (setf (el-search-head-buffer head) new-buffer)
- (unless (memq new-buffer buffer-list-before)
- (with-current-buffer new-buffer
- (setq-local el-search--temp-buffer-flag t)))))))
- (pop-to-buffer (el-search-head-buffer head)
el-search-display-next-buffer-action)
- (el-search--goto-char-maybe-barf match-start))
- (setf (el-search-object-last-match el-search--current-search)
- (copy-marker (point)))
- (setf (el-search-head-position head)
- (copy-marker (point)))
- (el-search-hl-sexp)
- (unless (and (eq this-command last-command)
- el-search--success
- (eq (current-buffer) old-current-buffer))
- (el-search-hl-other-matches matcher))
- (setq el-search--success t)))
- (el-search-prefix-key-maybe-set-transient-map))
- (el-search-kill-left-over-search-buffers))
- (el-search-hl-post-command-fun 'stop))))
-
-(defun el-search-skip-directory (directory)
- "Skip all subsequent matches in files located under DIRECTORY."
- (interactive
- (list (expand-file-name
- (read-directory-name "Skip all files under directory: " nil
- (if-let ((search el-search--current-search)
- (current-head (el-search-object-head
search))
- (current-file (el-search-head-file
current-head)))
- (file-name-directory current-file)
- default-directory)
- t))))
- (el-search--skip-to-next-buffer
- (lambda (buffer-or-file-name)
- (or (bufferp buffer-or-file-name)
- ;; `file-in-directory-p' would be perfect here, but it calls
- ;; file-truename on both args what we don't want, so we use this:
- (string-match-p (rx bos "..") (file-relative-name buffer-or-file-name
directory)))))
- (el-search-prefix-key-maybe-set-transient-map))
-
-(defun el-search-pattern--interactive (&optional prompt display-match-count)
- (list (if (or
- ;;Hack to make a pop-up buffer search from occur "stay active"
- (el-search--pending-search-p)
- (and (eq this-command last-command)
- (or el-search--success el-search--wrap-flag)))
- (el-search--current-pattern)
- (el-search-read-pattern-for-interactive prompt
display-match-count))))
-
-;;;###autoload
-(defun el-search-pattern (pattern)
- "Start new or resume last elisp buffer search.
-
-Search current buffer for expressions that are matched by
-PATTERN. When called from the current search's current search
-buffer, continue that search from point. Otherwise or when a new
-PATTERN is given, start a new single-buffer search from point.
-
-With prefix arg, generally resume the last search. With prefix
-arg 0, restart it. With C-u C-u or negative prefix arg, prompt
-for an older search to resume.
-
-The minibuffer is put into `emacs-lisp-mode' for reading the
-input pattern, and there are some special key bindings:
-\\<el-search-read-expression-map>\\[newline] inserts a newline,
-and <up> and <down> are unbound in the local map to let you move
-the cursor vertically - see `el-search-read-expression-map' for
-details.
-
-PATTERN is an \"el-search\" pattern - which means, either a
-`pcase' pattern or complying with one of the additional pattern
-types defined with `el-search-defpattern'.
-
-See `el-search-defined-patterns' for a list of defined patterns."
- (declare (interactive-only el-search-forward))
- (interactive (if current-prefix-arg (list current-prefix-arg)
- (el-search-pattern--interactive nil 'display-match-count)))
- (cl-flet ((restart-search
- (lambda ()
- (el-search-reset-search el-search--current-search)
- (setq el-search--success nil)
- (el-search-continue-search))))
- (if (and current-prefix-arg (called-interactively-p 'any))
- (let ((numerical-arg (prefix-numeric-value current-prefix-arg)))
- (el-search--set-search-origin-maybe)
- (cond
- ((or (equal current-prefix-arg '(16)) (< numerical-arg 0)) ;resume
older search
- (el-search-jump t))
- ((= numerical-arg 0) ;restart
- (restart-search))
- (t ;resume current search
- (el-search-jump))))
- (cond
- ((eq el-search--wrap-flag 'forward)
- (progn
- (el-search--set-wrap-flag nil)
- (el-search--message-no-log "[Wrapped search]")
- (sit-for .7)
- (restart-search)))
- ((or
- (el-search--pending-search-p)
- (and (eq this-command last-command)
- (eq pattern (el-search--current-pattern))))
- (progn
- (el-search--skip-expression nil t)
- (el-search-continue-search 'from-here)))
- (t ;create a new search single-buffer search
- (let ((current-buffer (current-buffer)))
- (el-search-setup-search
- pattern
- (lambda () (stream (list current-buffer)))
- (lambda (search) (setf (alist-get 'is-single-buffer
(el-search-object-properties search))
- current-buffer))
- 'from-here)))))))
-
-;;;###autoload
-(defalias 'el-search #'el-search-pattern)
-
-(defmacro el-search--unless-no-buffer-match (&rest body)
- "Execute BODY unless no match for current search in current buffer.
-In this case, ignore BODY and emit a message saying \"No matches\".
-
-The return value is the result of the last form in BODY if it is
-executed, and nil else."
- (declare (indent 0) (debug (body)))
- `(if (not (or el-search--success
- (save-excursion
- (goto-char (point-min))
- (el-search--search-pattern-1
- (el-search--current-matcher) t nil
(el-search--current-heuristic-matcher)))))
- (progn
- (ding)
- (el-search--message-no-log "No matches")
- (sit-for .7)
- nil)
- ,@body))
-
-(defun el-search-from-beginning (&optional arg)
- "Go to the first of this buffer's matches.
-With prefix ARG, go to the last match in the current buffer."
- (interactive "P")
- (el-search--set-search-origin-maybe)
- (el-search-barf-if-not-search-buffer)
- (cond
- (arg (el-search-last-buffer-match))
- (t
- (el-search--unless-no-buffer-match
- (setf (el-search-head-position (el-search-object-head
el-search--current-search))
- (point-min))
- (el-search-continue-search)))))
-
-(defun el-search-last-buffer-match ()
- "Go to the last of this buffer's matches."
- (interactive)
- (el-search--set-search-origin-maybe)
- (el-search-barf-if-not-search-buffer)
- (el-search--unless-no-buffer-match
- (goto-char (point-max))
- (funcall-interactively #'el-search-pattern-backward
(el-search--current-pattern))))
-
-(defun el-search--search-backward-1 (matcher &optional noerror bound
heuristic-matcher count)
- "Like `el-search-backward' but accepts a matcher as first argument.
-In addition, a HEURISTIC-MATCHER corresponding to the MATCHER can
-be specified as fourth argument, and COUNT becomes the fifth argument.
-
-This function is the counterpart of `el-search--search-pattern-1'."
- (cond
- ((not (derived-mode-p 'emacs-lisp-mode))
- (if noerror nil (error "Buffer not in emacs-lisp-mode: %s" (buffer-name))))
- ((and count (not (integerp count)))
- (signal 'wrong-type-argument (list 'integerp count)))
- ((and count (< count 0))
- (el-search--search-pattern-1 matcher noerror bound heuristic-matcher (-
count)))
- ((and bound (< (point) bound))
- (error "Invalid search bound (wrong side of point)"))
- (t
- (let* ((opoint (point))
- (fail (lambda ()
- (goto-char
- (if (not (memq noerror '(nil t)))
- (or bound (point-min))
- opoint))
- (if noerror nil (signal 'search-failed nil)))))
- (if count
- (cond
- ((= count 0) (point)) ;this is what the vanilla search functions do
- ((catch 'success
- ;; This is inefficient: O(n^2)
- (while (< 0 count)
- (cond
- ((not (el-search--search-backward-1 matcher t bound
heuristic-matcher))
- (throw 'success nil))
- ((= 1 count)
- (throw 'success t))
- (t (cl-decf count)))))
- (point))
- (t (funcall fail)))
- (let ((found-match nil))
- (let ((outer-loop-done nil))
- ;; Strategy: search forwards (inner loop) for PATTERN, starting
from
- ;; this toplevel expression's beginning up to point. If matches
- ;; starting before point exist, return the last one. If no match
is
- ;; found, search the top level expression before this one up to its
- ;; end, etc (outer loop).
- (while (not outer-loop-done)
- (let ((hindmost-match nil)
- (current-upper-limit (point))
- (current-defun-start (or (syntax-ppss-toplevel-pos
(syntax-ppss))
- (scan-sexps (point) -1)))
- (current-defun-end))
-
- (when current-defun-start
- ;; Search for the hindmost match starting before
CURRENT-UPPER-LIMIT
- (let ((done nil))
- (goto-char current-defun-start)
- (setq current-defun-end (el-search--end-of-sexp
current-defun-start))
- (when (and bound (< current-defun-end bound))
- (setq done t
- outer-loop-done t
- found-match nil))
- (while (and (not done)
- (el-search--search-pattern-1
- matcher t current-defun-end
heuristic-matcher))
- (if (>= (point) current-upper-limit)
- (setq done t)
- (setq hindmost-match (point))
- (el-search--skip-expression nil t)))))
-
- (if (not hindmost-match)
- (if current-defun-start
- (goto-char current-defun-start)
- ;; reached bob
- (setq outer-loop-done t))
- (setq outer-loop-done t)
- (setq found-match hindmost-match)))))
- (if (and found-match (not (and bound (< found-match bound))))
- (goto-char found-match)
- (funcall fail))))))))
-
-(defun el-search-backward (pattern &optional bound noerror count)
- "Search backward for el-search PATTERN from point.
-Set point to the beginning of the occurrence found and return point.
-
-This function is almost identical to `el-search-forward', except
-that by default it searches backward instead of forward, and the
-sign of COUNT also indicates exactly the opposite searching
-direction. See `el-search-forward' for details."
- (el-search--search-backward-1 (el-search-make-matcher pattern) noerror bound
- (el-search-heuristic-matcher pattern)
- count))
-
-;;;###autoload
-(defun el-search-pattern-backward (pattern)
- "Search the current buffer backward for matches of PATTERN.
-See the command `el-search-pattern' for more information."
- (declare (interactive-only el-search-backward))
- (interactive (el-search-pattern--interactive nil 'display-match-count))
- (if (eq pattern (el-search--current-pattern))
- (progn
- (el-search-compile-pattern-in-search el-search--current-search)
- (el-search-prefix-key-maybe-set-transient-map))
- (let ((current-buffer (current-buffer)))
- (el-search-setup-search-1
- pattern
- (lambda () (stream (list current-buffer)))
- 'from-here
- (lambda (search) (setf (alist-get 'is-single-buffer
(el-search-object-properties search))
- current-buffer))))
- ;; Make this buffer the current search buffer so that a following C-S
- ;; doesn't delete highlighting
- (el-search--next-buffer el-search--current-search))
- (el-search--set-this-command-refresh-message-maybe)
- (when (eq el-search--wrap-flag 'backward)
- (el-search--set-wrap-flag nil)
- (el-search--message-no-log "[Wrapped backward search]")
- (sit-for .7)
- (goto-char (point-max)))
- (if-let ((preceding-match (el-search--search-backward-1
- (el-search--current-matcher)
- t nil
- (el-search--current-heuristic-matcher))))
- (progn
- (goto-char preceding-match)
- (setf (el-search-head-position (el-search-object-head
el-search--current-search))
- (copy-marker (point)))
- (setf (el-search-object-last-match el-search--current-search)
- (copy-marker (point)))
- (el-search-hl-sexp)
- (unless (and (eq last-command 'el-search-pattern) el-search--success)
- (el-search-hl-other-matches (el-search--current-matcher)))
- (setq el-search--success t))
- (el-search--unless-no-buffer-match
- (let ((keys (car (where-is-internal 'el-search-pattern-backward))))
- (el-search--message-no-log
- (if keys
- (format "No (more) match; hit %s to wrap search" (key-description
keys))
- "No (more) match")))
- (sit-for .7)
- (el-search--set-wrap-flag 'backward))))
-
-(define-obsolete-function-alias 'el-search-previous-match
- 'el-search-pattern-backward "el-search 1.3")
-(define-obsolete-function-alias 'el-search-pattern-backwards
- 'el-search-pattern-backward "el-search 1.6.7")
-
-
-
-;;;###autoload
-(defun el-search-this-sexp (sexp)
- "Prepare to el-search the `sexp-at-point'.
-
-Grab the `sexp-at-point' SEXP and prepare to el-search the
-current buffer for other matches of 'SEXP.
-
-Use the normal search commands to seize the search."
- (interactive (list (if (not (derived-mode-p 'emacs-lisp-mode))
- (user-error "Current buffer not in `emacs-lisp-mode'")
- (let ((symbol-at-point-text (thing-at-point 'symbol))
- symbol-at-point)
- (if (and symbol-at-point-text
- ;; That should ideally be always true but
isn't
- (condition-case nil
- (symbolp (setq symbol-at-point
- (el-search-read
symbol-at-point-text)))
- (invalid-read-syntax nil)))
- symbol-at-point
- (if (thing-at-point 'sexp)
- (sexp-at-point)
- (user-error "No sexp at point")))))))
- (let ((printed-sexp (el-search--pp-to-string sexp)))
- (el-search--pushnew-to-history (concat "'" printed-sexp)
'el-search-pattern-history)
- (let ((current-buffer (current-buffer)))
- (el-search-setup-search-1
- `',sexp
- (lambda () (stream (list current-buffer)))
- 'from-here
- (lambda (search) (setf (alist-get 'is-single-buffer
(el-search-object-properties search))
- current-buffer))))
- (el-search--next-buffer el-search--current-search)
- (setf (el-search-head-position (el-search-object-head
el-search--current-search))
- (copy-marker (point)))
- (setq this-command 'el-search-pattern
- el-search--success t)
- (el-search-hl-other-matches (el-search--current-matcher))
- (add-hook 'post-command-hook #'el-search-hl-post-command-fun t t)
- (el-search--message-no-log "%s" printed-sexp)))
-
-(defun el-search-scroll-down ()
- "Jump to the first match starting after `window-end'."
- (interactive)
- (el-search-barf-if-not-search-buffer)
- (el-search--set-this-command-refresh-message-maybe)
- (let ((here (point)))
- (goto-char (window-end))
- (if (el-search--search-pattern-1 (el-search--current-matcher) t nil
- (el-search--current-heuristic-matcher))
- (el-search-jump 0)
- (goto-char here)
- (el-search--message-no-log "[No more matches after here]")
- (sit-for 1))))
-
-(defun el-search-scroll-up ()
- "Jump to the hindmost match starting before `window-start'."
- (interactive)
- (el-search-barf-if-not-search-buffer)
- (el-search--set-this-command-refresh-message-maybe)
- (let ((here (point)))
- (goto-char (window-start))
- (if (el-search--search-backward-1 (el-search--current-matcher) t nil
- (el-search--current-heuristic-matcher))
- (el-search-jump 0)
- (goto-char here)
- (el-search--message-no-log "[No more matches before here]")
- (sit-for 1))))
-
-
-;;;; El-Occur
-
-(defvar-local el-search-occur-search-object nil)
-
-(defvar el-search-occur--outline-visible t)
-
-(defun el-search-occur-revert-function (&rest _)
- (el-search--occur el-search-occur-search-object t)
- (unless el-search-occur--outline-visible
- (outline-hide-leaves)))
-
-(defun el-search-edit-occur-pattern (new-pattern)
- "Change the search pattern associated with this *El Occur* buffer.
-Prompt for a new pattern and revert."
- (interactive (list (let ((el-search--initial-mb-contents
- (el-search--pp-to-string
- (el-search-object-pattern
el-search-occur-search-object))))
- (el-search-read-pattern-for-interactive "New pattern:
"))))
- (setf (el-search-object-pattern el-search-occur-search-object)
- new-pattern)
- (el-search-compile-pattern-in-search el-search-occur-search-object)
- (revert-buffer))
-
-(defvar el-search-occur-match-ov-prop 'el-occur-match-data)
-(defvar el-search-occur-headline-prop 'el-search-occur-headline)
-
-(defun el-search-occur-jump-to-match ()
- (interactive)
- (if (button-at (point))
- (push-button)
- (if-let ((params (pcase (get-char-property (point)
el-search-occur-match-ov-prop)
- (`(,buffer ,match-beg ,file ,_) (list (or file buffer)
match-beg)))))
- (apply #'el-search--occur-button-action params)
- ;; User clicked not directly on a match
- (catch 'nothing-here
- (let ((clicked-pos (point)) (done nil) some-match-pos)
- (save-excursion
- (pcase (el-search--bounds-of-defun)
- ('nil
- (throw 'nothing-here t))
- (`(,defun-beg . ,defun-end)
- (unless (< defun-end (point)) (goto-char defun-beg))))
- ;; Try to find corresponding position in source buffer
- (setq some-match-pos (point))
- (while (and (not done) (setq some-match-pos
- (funcall
#'next-single-char-property-change
- some-match-pos
el-search-occur-match-ov-prop)))
- (setq done (or (memq some-match-pos (list (point-min)
(point-max)))
- (cl-some (lambda (ov) (overlay-get ov
el-search-occur-match-ov-prop))
- (overlays-at some-match-pos))))))
- (let ((delta-lines (count-lines clicked-pos some-match-pos)))
- (when (save-excursion
- (goto-char (max clicked-pos some-match-pos))
- (not (bolp)))
- (cl-decf delta-lines))
- (when (< clicked-pos some-match-pos)
- (cl-callf - delta-lines))
- (pcase-let ((`(,buffer ,pos ,file . ,_)
- (get-char-property some-match-pos
el-search-occur-match-ov-prop)))
- (el-search--occur-button-action
- (or file buffer) nil
- (lambda ()
- (goto-char pos)
- (beginning-of-line)
- (forward-line delta-lines))
- '()))))))))
-
-(cl-defun el-search--occur-button-action
- (filename-or-buffer &optional match-pos do-fun (display-buffer-action nil
action-specified))
- (let ((buffer (cond
- ((bufferp filename-or-buffer)
- filename-or-buffer)
- ((functionp filename-or-buffer)
- (funcall filename-or-buffer))
- (t (find-file-noselect filename-or-buffer))))
- (search-pattern (el-search-object-pattern
el-search-occur-search-object)))
- (with-selected-window (display-buffer
- buffer
- (cond
- (action-specified display-buffer-action)
- (match-pos
'((display-buffer-pop-up-window)))
- (t
el-search-display-buffer-popup-action)))
- (when match-pos
- (when (and (buffer-narrowed-p)
- (or (< match-pos (point-min))
- (> match-pos (point-max)))
- (not (and (y-or-n-p "Widen buffer? ")
- (progn (widen) t))))
- (user-error "Can't jump to match"))
- (goto-char match-pos))
- (el-search-setup-search-1
- search-pattern
- (lambda () (stream (list buffer)))
- 'from-here
- (lambda (search)
- (setf (alist-get 'is-single-buffer (el-search-object-properties
search))
- buffer)))
- (el-search--next-buffer el-search--current-search)
- (setq this-command 'el-search-pattern
- el-search--success t)
- (when match-pos
- (el-search-hl-sexp)
- (el-search-display-match-count))
- (el-search-hl-other-matches (el-search--current-matcher))
- (add-hook 'post-command-hook #'el-search-hl-post-command-fun t t)
- (when do-fun (funcall do-fun)))))
-
-(defun el-search-occur--next-match (&optional backward)
- (let ((pos (point)) new-pos)
- (cl-flet ((at-a-match-beg-p
- (lambda (pos)
- (when-let ((match-data (get-char-property pos
el-search-occur-match-ov-prop)))
- (and (not (= pos (if backward (point-min) (point-max))))
- (not (eq match-data
- (get-char-property (1- pos)
el-search-occur-match-ov-prop))))))))
- (while (and (setq new-pos (funcall (if backward
#'previous-single-char-property-change
- #'next-single-char-property-change)
- pos el-search-occur-match-ov-prop))
- (not (eq pos new-pos))
- (setq pos new-pos)
- (not (at-a-match-beg-p pos)))))
- (if (memq pos (list (point-min) (point-max) nil))
- (progn
- (el-search--message-no-log "No match %s this position" (if backward
"before" "after"))
- (sit-for 1.5))
- (goto-char pos)
- (save-excursion (hs-show-block))
- (redisplay)
- (el-search--scroll-sexp-in-view (list (point) (el-search--end-of-sexp)))
- (el-search-occur--show-match-count))))
-
-(defvar el-search-occur--total-matches nil)
-
-(defun el-search-occur--show-match-count ()
- (pcase-let ((`(,_buffer ,_mb ,_file ,nbr)
- (get-char-property (point) el-search-occur-match-ov-prop)))
- (el-search--message-no-log
- "%d/%s" nbr
- (if el-search-occur--total-matches
- (format "%d" el-search-occur--total-matches)
- "???"))))
-
-(defun el-search-occur-next-match ()
- "Move point to the next match."
- (interactive)
- (el-search-occur--next-match))
-
-(defun el-search-occur-previous-match ()
- "Move point to the previous match."
- (interactive)
- (el-search-occur--next-match 'backward))
-
-
-(defun el-search-occur-cycle ()
- "Cycle between showing an outline and everything."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (if el-search-occur--outline-visible
- (outline-hide-leaves)
- (outline-show-all)))
- (cl-callf not el-search-occur--outline-visible))
-
-(defun el-search-occur-tab-command ()
- "Hide or unhide heading or sexp at point."
- (interactive)
- (call-interactively
- (if (not (outline-on-heading-p))
- #'hs-toggle-hiding
- #'outline-toggle-children)))
-
-(defvar el-search-occur-mode-map-1
- (let ((map (make-sparse-keymap)))
- (define-key map "\t" #'el-search-occur-tab-command)
- (define-key map "\r" #'el-search-occur-jump-to-match)
- (define-key map [backtab] #'el-search-occur-cycle)
- (define-key map [?p] #'el-search-occur-previous-match)
- (define-key map [?n] #'el-search-occur-next-match)
- (define-key map [?r] #'el-search-occur-previous-match)
- (define-key map [?s] #'el-search-occur-next-match)
- (define-key map [?e] #'el-search-edit-occur-pattern)
- (define-key map [?c ?n] #'el-search-occur-no-context)
- (define-key map [?c ?d] #'el-search-occur-defun-context)
- (define-key map [?c ?a] #'el-search-occur-defun-context)
- (define-key map [?c ?s] #'el-search-occur-some-context)
- map))
-
-(defvar el-search-occur-mode-map
- (let ((map (copy-keymap el-search-occur-mode-map-1)))
- (set-keymap-parent map (make-composed-keymap special-mode-map
emacs-lisp-mode-map))
- map))
-
-(defcustom el-search-occur-match-markers (list "--> " " <--")
- "Whether to mark matches in copied or saved text in *El Occur*.
-
-When non-nil, should be a list of two strings (BEFORE-MARKER
-AFTER-MARKER). When large parts of an *El Occur* buffer are
-copied or the buffer is saved to a file, all matches are silently
-surrounded with these markers. This is useful if you want to
-send the buffer contents to someone else. \"Large\" means that
-the copied text includes buffer or file headlines, so this will
-not get in your way if you only want to copy single expressions
-from an *El Occur* buffer.
-
-When nil, all such treatment is disabled."
- :type '(choice
- (const :tag "Off" nil)
- (list :tag "Match Text Markers"
- (string :tag "Before-Marker String")
- (string :tag "After-Marker String"))))
-
-(defun el-search-occur-filter-buffer-substring (beg end &optional delete)
- (if (or delete
- (not el-search-occur-match-markers)
- (eq end (next-single-char-property-change beg
el-search-occur-headline-prop nil end)))
- (buffer-substring--filter beg end delete)
- (let ((contents '())
- p)
- (save-excursion
- (setq p (goto-char beg))
- (while (not (<= end (point)))
- (goto-char (next-single-char-property-change (point)
el-search-occur-match-ov-prop nil end))
- (push (buffer-substring p (point)) contents)
- (push (if (get-char-property (point) el-search-occur-match-ov-prop)
- (car el-search-occur-match-markers)
- (if (<= end (point)) "" (cadr
el-search-occur-match-markers)))
- contents)
- (setq p (point))))
- (apply #'concat (nreverse contents)))))
-
-(defun el-search-occur-write-file (&optional file)
- (let ((file (or file buffer-file-name))
- (contents (save-restriction (widen) (filter-buffer-substring
(point-min) (point-max)))))
- (with-temp-buffer
- (insert contents)
- (write-region (point-min) (point-max) file nil t))
- (set-buffer-modified-p nil)
- t ;signal success
- ))
-
-(define-derived-mode el-search-occur-mode emacs-lisp-mode "El-Occur"
- "Major mode for El-Occur buffers.
-
-This mode provides the following key bindings:
-
-\\{el-search-occur-mode-map-1}
-The mode's keymap inherits from `emacs-lisp-mode-map' and in
-addition from `special-mode-map':
-
-\\{special-mode-map}"
- (setq-local revert-buffer-function #'el-search-occur-revert-function)
- (setq buffer-read-only t)
- (setq-local hs-hide-comments-when-hiding-all nil)
- (hs-minor-mode +1)
- (setq outline-regexp (rx bol ";;; " (+ "*")))
- (outline-minor-mode +1)
- (add-hook 'write-contents-functions 'el-search-occur-write-file nil t)
- (setq-local filter-buffer-substring-function
#'el-search-occur-filter-buffer-substring))
-
-(put 'el-search-occur-mode 'mode-class 'special)
-
-(defun el-search-occur-get-some-context (match-beg)
- (let ((context-beg nil)
- (need-more-context-p
- (lambda (start)
- (let (end)
- (pcase (save-excursion
- (goto-char start)
- (prog1 (el-search-read (current-buffer))
- (setq end (point))))
- ((or (pred atom) `(,(pred atom))) t)
- ((guard (< (- end start) 100)) t)))))
- (try-go-upwards (lambda (pos) (condition-case nil
- (when-let ((pos (scan-lists pos -1
1)))
- (if (eq (char-before pos) ?`) (1-
pos) pos))
- (scan-error nil)))))
- (when (funcall need-more-context-p match-beg)
- (setq context-beg (funcall try-go-upwards match-beg))
- (when (and context-beg (funcall need-more-context-p context-beg))
- (setq context-beg (or (funcall try-go-upwards context-beg)
- context-beg))))
- (cons (or context-beg match-beg)
- (if context-beg (scan-lists context-beg 1 0)
- (el-search--end-of-sexp match-beg)))))
-
-(defun el-search-occur-get-defun-context (match-beg)
- (let ((bounds (el-search--bounds-of-defun match-beg)))
- (save-excursion
- (goto-char (car bounds))
- (let ((done nil))
- (while (not (or done (bobp)))
- (forward-line -1)
- (if (looking-at-p "[[:space:]]*;")
- (setf (car bounds) (point))
- (setq done t)))))
- bounds))
-
-(defun el-search-occur-get-null-context (match-beg)
- (cons match-beg (el-search--end-of-sexp match-beg)))
-
-(defvar el-search-get-occur-context-function #'el-search-occur-get-some-context
- "Function determining amount of context shown in *El Occur* buffers.")
-
-(defun el-search-occur-defun-context ()
- "Show complete top-level expressions in *El Occur*."
- (interactive)
- (setq el-search-get-occur-context-function
#'el-search-occur-get-defun-context)
- (revert-buffer))
-
-(defun el-search-occur-no-context ()
- "Show no context around matches in *El Occur*."
- (interactive)
- (setq el-search-get-occur-context-function
#'el-search-occur-get-null-context)
- (revert-buffer))
-
-(defun el-search-occur-some-context ()
- "Show some context around matches in *El Occur*."
- (interactive)
- (setq el-search-get-occur-context-function
#'el-search-occur-get-some-context)
- (revert-buffer))
-
-(declare-function which-func-ff-hook which-func)
-
-(defun el-search--occur (search &optional buffer)
- (unwind-protect
- (let ((occur-buffer (or buffer (generate-new-buffer "*El Occur*"))))
- (setq this-command 'el-search-pattern)
- (setq-local el-search--temp-buffer-flag nil)
- (with-selected-window (if buffer (selected-window) (display-buffer
occur-buffer))
- (let ((inhibit-read-only t))
- (if el-search-occur-search-object
- (progn
- (erase-buffer)
- (delete-all-overlays))
- (setq el-search-occur-search-object search)
- (put 'el-search-occur-search-object 'permanent-local t)
- (el-search-occur-mode))
- (insert (format ";;; * %s -*- mode: el-search-occur -*-\n\n;;;
** %s\n\n"
- (current-time-string)
- (el-search--get-search-description-string search)))
- (condition-case-unless-debug err
- (let ((insert-summary-position (point))
- (match-nbr 0)
- (stream-of-matches
- (stream-partition
- (funcall (el-search-object-get-matches search))
- (lambda (this prev)
- (and (eq (car this) (car prev)) (equal (nth 2 this)
(nth 2 prev))))))
- stream-of-buffer-matches buffer-matches
- (matching-files 0) (matching-buffers 0) (overall-matches
0))
- (while (setq stream-of-buffer-matches (stream-pop
stream-of-matches))
- (setq buffer-matches (seq-length stream-of-buffer-matches))
- (cl-incf overall-matches buffer-matches)
- (pcase-let* ((`(,buffer ,_ ,file)
- ;; This always binds BUFFER to a live buffer
- (stream-first stream-of-buffer-matches))
- (get-buffer (with-current-buffer buffer
el-search--get-buffer-fun)))
- (when get-buffer
- (let ((real-get-buffer get-buffer)
- (buffer-name (buffer-name buffer)))
- (setq get-buffer
- (lambda (&optional arg)
- (if arg buffer-name (funcall
real-get-buffer))))))
- (if file (cl-incf matching-files) (cl-incf
matching-buffers))
- (insert "\n\n;;; *** ")
- (insert-button
- (or file (format "%S" buffer))
- 'action
- (lambda (_) (el-search--occur-button-action (or
get-buffer file buffer)))
- el-search-occur-headline-prop t)
- (insert (format " (%d match%s)\n"
- buffer-matches
- (if (> buffer-matches 1) "es" "")))
- (let ((buffer-matches+counts+contexts
- (seq-map (pcase-lambda ((and match `(,_
,match-beg ,_)))
- (with-current-buffer buffer
- (list
- match
- (cl-incf match-nbr)
- (let
((open-paren-in-column-0-is-defun-start nil))
- (save-excursion
- (funcall
el-search-get-occur-context-function
- match-beg))))))
- stream-of-buffer-matches)))
- (while (not (stream-empty-p
buffer-matches+counts+contexts))
- (pcase-let ((`((,_ ,match-beg ,_) ,_ (,context-beg .
,context-end))
- (stream-first
buffer-matches+counts+contexts)))
- (let ((insertion-point (point)) matches
- (end-of-defun (with-current-buffer buffer
- (goto-char match-beg)
- (let ((paren-depth (car
(syntax-ppss))))
- (if (< 0 paren-depth)
- (scan-lists match-beg
1 paren-depth)
-
(el-search--end-of-sexp))))))
- (let ((rest buffer-matches+counts+contexts)
- (remaining-buffer-matches+counts+contexts
- buffer-matches+counts+contexts))
- (with-current-buffer buffer
- (while (pcase (stream-first rest)
- (`(,_ ,_ (,(and cbeg (pred (>
end-of-defun))) . ,_))
- (prog1 t
- (stream-pop rest)
- (when (< cbeg context-end)
- (setq
remaining-buffer-matches+counts+contexts rest)
- (when (< cbeg context-beg)
- (setq context-beg cbeg)
- (setq context-end
- (or
(el-search--end-of-sexp cbeg)
-
context-end)))))))))
- (setq matches
- (car (stream-divide-with-get-rest-fun
- buffer-matches+counts+contexts
- (lambda (_)
remaining-buffer-matches+counts+contexts))))
- (setq buffer-matches+counts+contexts
-
remaining-buffer-matches+counts+contexts))
- (cl-flet ((insert-match-and-advance
- (match-beg nbr)
- (let ((insertion-point (point)))
- (insert (with-current-buffer buffer
-
(buffer-substring-no-properties
- (goto-char match-beg)
- (goto-char
(el-search--end-of-sexp)))))
- (let ((ov (make-overlay
insertion-point (point) nil 'fr-ad)))
- (overlay-put ov 'face
'el-search-occur-match)
- (overlay-put
- ov el-search-occur-match-ov-prop
- `(,(or get-buffer buffer)
,match-beg ,file ,nbr)))
- (with-current-buffer buffer
(point)))))
- (insert (format "\n;;;; Line %d\n"
- (with-current-buffer buffer
- (line-number-at-pos
context-beg))))
- (setq insertion-point (point))
- (let ((working-position context-beg)
main-match-beg)
- (while (not (stream-empty-p matches))
- (pcase-let ((`((,_ ,match-beg ,_) ,nbr ,_)
(stream-pop matches)))
- (insert-buffer-substring buffer
working-position match-beg)
- (setq
- main-match-beg (point)
- working-position
(insert-match-and-advance match-beg nbr))
- ;; Drop any matches inside the printed
area.
- (while
- (pcase (stream-first matches)
- (`((,_ ,(and (pred (>
working-position)) mb) ,_) ,nbr ,_)
- (let ((ov-start (+ main-match-beg
(- mb match-beg))))
- (overlay-put
- (make-overlay
- ov-start
- (+ ov-start
- (with-current-buffer buffer
- (el-search--end-of-sexp
mb)))
- nil 'front-advance) ;f-a is
needed for later indenting
- el-search-occur-match-ov-prop
- `(,(or get-buffer buffer) ,mb
,file ,nbr)))
- (stream-pop matches)
- t)))))
- (insert
- (with-current-buffer buffer
- (buffer-substring-no-properties
- (point) (el-search--end-of-sexp
context-beg))))))
-
- (let ((inhibit-message t) (message-log-max nil))
- (indent-region insertion-point (point)))
- (insert "\n")))))))
-
- (save-excursion
- (goto-char insert-summary-position)
- (setq el-search-occur--total-matches overall-matches)
- (insert
- (if (zerop overall-matches)
- ";;; * No matches"
- (concat
- (format ";;; ** %d matches in " overall-matches)
- (unless (zerop matching-files) (format "%d files"
matching-files))
- (unless (or (zerop matching-files) (zerop
matching-buffers)) " and ")
- (unless (zerop matching-buffers) (format "%d buffers"
matching-buffers))
- (unless (zerop overall-matches) ":\n\n")))))
- (goto-char (point-min))
- (when (and (bound-and-true-p which-function-mode)
- (eq el-search-get-occur-context-function
- #'el-search-occur-get-defun-context))
- (which-func-ff-hook)))
- (quit (insert "\n\n;;; * Aborted"))
- (error (insert "\n\n;;; * Error: " (error-message-string err)
- "\n\
-;;; If you think this error could be caused by a bug in
-;;; el-search, please make a bug report to the maintainer.
-;;; Thanks!")))
- (el-search--message-no-log "")
- (set-buffer-modified-p nil))))
- (el-search-kill-left-over-search-buffers)))
-
-(defun el-search-occur ()
- "Display an occur-like overview of matches of the current search.
-
-Buffers and files are separated by headlines. Matches are
-highlighted with face `el-search-match'. For short matches, some
-context is shown, and nearby matches are grouped.
-\\<el-search-occur-mode-map>
-Clicking on a file or buffer name displays it in a different
-window and goes to the first match.
-\\[el-search-occur-jump-to-match] on a match displays that match
-in its buffer. \\[revert-buffer] refreshes the buffer and
-restarts the search. \\[hs-toggle-hiding] folds and unfolds
-expressions, while \\[el-search-occur-cycle] folds and unfolds
-buffer and file sections like in `org-mode'. At the beginning of
-a headline, <tab> toggles folding the following section.
-
-Hit \\[quit-window] to leave without killing the buffer.
-
-The occur buffer is in `el-search-occur-mode' that is derived
-from `emacs-lisp-mode' and `special-mode'. In addition it makes
-use of `hs-minor-mode' and `orgstruct-mode'."
- (interactive)
- (el-search--message-no-log "Preparing occur...")
- (if el-search--current-search
- (el-search--occur el-search--current-search)
- (user-error "No active search"))
- (setq this-command 'el-search-pattern))
-
-(defun el-search-set-occur-flag-exit-minibuffer ()
- (interactive)
- (setq el-search-occur-flag t)
- (exit-minibuffer))
-
-;;;###autoload
-(defun el-search-buffers (pattern)
- "Search all live elisp buffers for PATTERN."
- (interactive
- (list (el-search-read-pattern-for-interactive "Search elisp buffers for
pattern: ")))
- (el-search-setup-search
- pattern
- (lambda ()
- (seq-filter
- (lambda (buffer) (with-current-buffer buffer (and (derived-mode-p
'emacs-lisp-mode)
- (not (eq major-mode
'el-search-occur-mode)))))
- (stream (buffer-list))))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- "el-search-buffers"))))
-
-;;;###autoload
-(defun el-search-directory (pattern directory &optional recursively)
- "Search all elisp files in DIRECTORY for PATTERN.
-With prefix arg RECURSIVELY non-nil, search subdirectories recursively."
- (interactive (let ((dir (expand-file-name
- (read-directory-name (format "El-Search
Directory%s: "
- (if current-prefix-arg
" recursively" ""))
- nil default-directory t))))
- (list (el-search-read-pattern-for-interactive "Search
pattern: ")
- dir
- current-prefix-arg)))
- (el-search-setup-search
- pattern
- (lambda () (el-search-stream-of-directory-files directory recursively))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- (concat (if recursively "Recursive directory search
in "
- "Directory search in ")
- directory)))))
-
-;;;###autoload
-(defun el-search-emacs-elisp-sources (pattern)
- "Search Emacs elisp sources for PATTERN.
-This command recursively searches all elisp files under
-`source-directory'."
- (interactive (list (el-search-read-pattern-for-interactive
- "Search Elisp sources for pattern: ")))
- (el-search-setup-search
- pattern
- (lambda ()
- (seq-filter
- #'el-search--elisp-file-p
- (el-search-stream-of-directory-files source-directory t)))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- "Search the Emacs Elisp sources"))))
-
-;;;###autoload
-(defun el-search-load-path (pattern)
- "Search PATTERN in all elisp files in all directories in `load-path'.
-nil elements in `load-path' (standing for `default-directory')
-are ignored."
- (interactive (list (el-search-read-pattern-for-interactive
- "Search load path for pattern: ")))
- (el-search-setup-search
- pattern
- (lambda ()
- (stream-concatenate
- (seq-map (lambda (path) (el-search-stream-of-directory-files path nil))
- (stream (remq nil load-path)))))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- "Search `load-path'"))))
-
-(declare-function dired-get-marked-files "dired")
-
-;;;###autoload
-(defun el-search-dired-marked-files (pattern files &optional recursively)
- "El-search files and directories marked in dired.
-With RECURSIVELY given (the prefix arg in an interactive call),
-search directories recursively.
-
-This function uses `el-search-stream-of-directory-files' to
-compute a the file stream - see there for a description of
-related user options."
- (interactive (list (el-search-read-pattern-for-interactive
- "Search marked files for pattern: ")
- (dired-get-marked-files)
- current-prefix-arg))
- (el-search-setup-search
- pattern
- (lambda ()
- (stream-concatenate
- (seq-map
- (lambda (file)
- (if (file-directory-p file)
- (el-search-stream-of-directory-files file recursively)
- (stream (list file))))
- (stream files))))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- "el-search-dired-marked-files"))))
-
-(declare-function ibuffer-get-marked-buffers 'ibuffer)
-
-;;;###autoload
-(defun el-search-ibuffer-marked-buffers (pattern buffer-names)
- "El-search the buffers marked in *Ibuffer*."
- (interactive
- (list (el-search-read-pattern-for-interactive
- "Search marked files for pattern: ")
- ;; Return a list of buffer names here so that `repeat-complex-command'
- ;; works ok
- (mapcar #'buffer-name (ibuffer-get-marked-buffers))))
- (el-search-setup-search
- pattern
- (lambda () (stream (delq nil (mapcar #'get-buffer buffer-names))))
- (lambda (search) (setf (alist-get 'description (el-search-object-properties
search))
- "el-search-ibuffer-marked-files"))))
-
-(defun el-search-repository--delete-buffer-file ()
- (when (and (stringp buffer-file-name)
- (file-exists-p buffer-file-name))
- (delete-file buffer-file-name)))
-
-(defun el-search-repository--clean-up ()
- (dolist (b (buffer-list))
- (when (with-current-buffer b (memq
#'el-search-repository--delete-buffer-file kill-buffer-hook))
- (kill-buffer b))))
-
-(declare-function vc-read-revision 'vc)
-(declare-function vc-find-revision 'vc)
-;;;###autoload
-(defun el-search-repository (repo-root-dir pattern &optional revision
file-regexp)
- "El-Search the Git repository under REPO-ROOT-DIR for PATTERN.
-Optional string arg REVISION specifies a repository revision.
-When nil or omitted, search the worktree. When the second
-optional string argument FILE-REGEXP is specified, it should be a
-regexp, and only matching files will be el-searched.
-
-When called interactively, you are prompted for all arguments.
-
-Searching any REVISION is internally using temporarily files."
- (interactive
- (cl-flet* ((return (v) (if (equal v "") nil v))
- (choose (l &rest nums) (mapcar (lambda (n) (return (nth n l)))
nums)))
- (let* ((this-vc-root-dir (vc-root-dir))
- (repo (expand-file-name
- (read-directory-name "Repository root: "
- this-vc-root-dir this-vc-root-dir
'mustmatch))))
- (choose (list repo
- (vc-read-revision "Revision (leave empty for
\"worktree\"): " (list repo) 'Git)
- (read-string "File filter regexp (leave empty for no
filtering): ")
- (el-search-read-pattern-for-interactive "Search pattern:
"))
- 0 3 1 2))))
- (let ((just-worktree (not revision)))
- (el-search-setup-search
- pattern
- (lambda ()
- (let* ((default-directory repo-root-dir)
- (files (seq-filter #'el-search--elisp-file-p
- (stream
- (mapcar #'expand-file-name
- (split-string
- (shell-command-to-string
- (if just-worktree
- "git ls-files -z
--recurse-submodules"
- (format "git ls-tree --name-only
-z -r %s --"
- (shell-quote-argument
revision))))
- "\0" 'omit-nulls))))))
- (when file-regexp
- (setq files (seq-filter (apply-partially #'string-match-p
file-regexp) files)))
- (if just-worktree files
- (seq-map
- (lambda (filename)
- (cl-flet ((get-buffer+newflag
- (lambda ()
- (let* ((buffer-list-before (buffer-list))
- (b (let ((inhibit-message t)
- (default-directory repo-root-dir))
- (vc-find-revision filename revision)))
- (buffer-new? (not (memq b
buffer-list-before))))
- (when buffer-new?
- (with-current-buffer b
- ;; We must delete any temporary files VC
creates. We don't check
- ;; whether these files might have existed
before.
- (add-hook 'kill-buffer-hook
-
#'el-search-repository--delete-buffer-file
- 'append 'local)
- (add-hook 'kill-emacs-hook
#'el-search-repository--clean-up)))
- (cons b buffer-new?)))))
- (pcase-let ((`(,b . ,buffer-new?) (get-buffer+newflag)))
- (with-current-buffer b
- (when buffer-new?
- (setq-local el-search--temp-buffer-flag t))
- (setq-local el-search--get-buffer-fun
- (lambda () (car (get-buffer+newflag)))))
- b)))
- files)))))))
-
-;;;; Register usage
-
-(defun el-search-to-register (register &optional el-search-object)
- "Prompt for a register and save the EL-SEARCH-OBJECT to it.
-In an interactive call or when EL-SEARCH-OBJECT is nil, the
-current search is used."
- (interactive (list (if el-search--current-search
- (register-read-with-preview "Save current search to
register: ")
- (user-error "No search has been started yet"))))
- (set-register register (or el-search-object el-search--current-search)))
-
-(defun el-search-clone-to-register (register &optional el-search-object)
- "Prompt for a register and save a clone of the EL-SEARCH-OBJECT to it.
-In an interactive call or when EL-SEARCH-OBJECT is nil, the
-current search is used.
-
-This is similar to `el-search-to-register' but what is saved is a
-clone with an individual state."
- (interactive (list (if el-search--current-search
- (register-read-with-preview "Save clone of current
search to register: ")
- (user-error "No search has been started yet"))))
- (set-register register (copy-el-search-object (or el-search-object
el-search--current-search))))
-
-(cl-defmethod register-val-jump-to ((val el-search-object) _arg)
- (el-search-jump val))
-
-(cl-defmethod register-val-describe ((val el-search-object) _verbose) ;VERBOSE
is only used by C-x r v
- (let ((print-circle nil)) ;bug#30070
- (cl-prin1 val)))
-
-
-;;;; Query-replace
-
-(cl-defstruct el-search-query-replace-object
- search-object from-pattern to-expr textual-to splice)
-
-(defun el-search--get-q-r-description-string (qr-object &optional verbose
dont-propertize)
- (let ((qr-search (el-search-query-replace-object-search-object qr-object)))
- (concat
- "Replace"
- (let ((printed-rule
- (concat
- (let ((printed-pattern (el-search--pp-to-string
(el-search-object-pattern qr-search))))
- (format (if (string-match-p "\n" printed-pattern) ":\n%s" " %s")
- printed-pattern))
- " -> "
- (el-search--pp-to-string (el-search-query-replace-object-to-expr
qr-object)))))
- (if dont-propertize printed-rule
- (propertize printed-rule 'face 'shadow)))
- (and verbose
- (let ((search-head (el-search-object-head qr-search)))
- (format " [%s %s]"
- (if (alist-get 'is-single-buffer
(el-search-object-properties qr-search))
- "single-buffer" "paused")
- (if-let ((buffer (el-search-head-buffer search-head)))
- (concat "in "(if (buffer-live-p buffer)
- (buffer-name buffer)
- (if-let ((head-file
(el-search-head-file search-head)))
- (file-name-nondirectory head-file)
- "killed buffer")))
- "(completed)")))))))
-
-(cl-defmethod cl-print-object ((object el-search-query-replace-object) stream)
- (princ "#s(el-search-query-replace " stream)
- (prin1 (el-search--get-q-r-description-string object 'verbose
'dont-propertize) stream)
- (princ ")" stream))
-
-(defun el-search-query-replace-to-register (register &optional
el-search-query-replace-object)
- "Prompt for a register and save the EL-SEARCH-QUERY-REPLACE-OBJECT to it.
-In an interactive call or when EL-SEARCH-QUERY-REPLACE-OBJECT is
-nil, the last active `el-search-query-replace' session object is
-used."
- (interactive (list (if el-search--current-query-replace
- (register-read-with-preview "Save current
query-replace to register: ")
- (user-error "No el-search-query-replace has been
started yet"))))
- (set-register register (or el-search-query-replace-object
el-search--current-query-replace)))
-
-(cl-defmethod register-val-jump-to ((val el-search-query-replace-object) _arg)
- (el-search-query-replace val nil))
-
-(cl-defmethod register-val-describe ((val el-search-query-replace-object)
_verbose)
- (let ((print-circle nil)) ;bug#30070
- (cl-prin1 val)))
-
-(defun el-search--replace-hunk (region to-insert)
- "Replace the text in REGION in current buffer with string TO-INSERT.
-Add line breaks before and after TO-INSERT when appropriate and
-reindent.
-
-The return value is a marker pointing to the end of the inserted
-text."
- (atomic-change-group
- (let* ((inhibit-message t)
- (message-log-max nil)
- (opoint (point))
- (original-text (prog1 (apply #'buffer-substring-no-properties
region)
- (goto-char (car region))
- (apply #'delete-region region)))
- ;; care about other sexps in this line
- (sexp-before-us (not (looking-back
- (rx (or "(" (seq bol (zero-or-more (syntax
whitespace)))))
- (line-beginning-position))))
- (sexp-after-us (not (looking-at (rx (or (seq (* (syntax
whitespace)) (any ";)")) eol)))))
- (insert-newline-before
- (or
- (and (string-match-p "\n" to-insert)
- (not (string-match-p "\n" original-text))
- (or (and sexp-before-us sexp-after-us)
- (looking-back
- (rx (or (syntax word) (syntax symbol))
- (+ blank)
- (or (syntax word) (syntax symbol))
- (* any))
- (line-beginning-position))))
- ;; (and sexp-before-us
- ;; (> (+ (apply #'max (mapcar #'length (split-string
to-insert "\n")))
- ;; (- (point) (line-beginning-position)))
- ;; fill-column))
- ))
- (insert-newline-after (and insert-newline-before sexp-after-us)))
- (when insert-newline-before
- (when (looking-back (rx (+ (syntax whitespace)))
(line-beginning-position) 'greedy)
- (delete-region (match-beginning 0) (match-end 0)))
- (insert "\n"))
- (insert to-insert)
- (when insert-newline-after
- (insert "\n"))
- (prog1 (copy-marker (point))
- (if (string= to-insert "")
- ;; We deleted the match. Clean up.
- (if (save-excursion (goto-char (line-beginning-position))
- (looking-at (rx bol (* space) eol)))
- (delete-region (match-beginning 0) (min (1+ (match-end 0))
(point-max)))
- (save-excursion
- (skip-chars-backward " \t")
- (when (looking-at (rx (+ space) eol))
- (delete-region (match-beginning 0) (match-end 0))))
- (when (and (looking-back (rx space) (1- (point)))
- (looking-at (rx (+ space))))
- (delete-region (match-beginning 0) (match-end 0)))
- (indent-according-to-mode))
- (save-excursion
- ;; the whole enclosing sexp might need re-indenting
- (condition-case nil (up-list) (scan-error))
- (indent-region opoint (1+ (point)))))))))
-
-(defun el-search--format-replacement (replacement original replace-expr-input
splice)
- ;; Return a printed representation of REPLACEMENT. Try to reuse the
- ;; layout of subexpressions shared with the original (replaced)
- ;; expression and the replace expression.
- (if (and splice (not (listp replacement)))
- (error "Expression to splice in is not a list: %S" replacement)
- (let ((orig-buffer (generate-new-buffer "orig-expr")))
- (with-current-buffer orig-buffer
- (emacs-lisp-mode)
- (insert original)
- (when replace-expr-input (insert "\n\n" replace-expr-input)))
- (unwind-protect
- (with-temp-buffer
- (emacs-lisp-mode)
- (insert (if splice
- (let ((insertions (mapcar #'el-search--pp-to-string
replacement)))
- (mapconcat #'identity insertions
- (if (cl-some (apply-partially
#'string-match-p "\n")
- insertions)
- "\n" " ")))
- (el-search--pp-to-string replacement)))
- (goto-char 1)
- (let (start this-sexp end orig-match-start orig-match-end done)
- (while (and (< (point) (point-max))
- (condition-case nil
- (progn
- (setq start (point)
- this-sexp (el-search-read
(current-buffer))
- end (point))
- t)
- (end-of-buffer nil)))
- (setq done nil orig-match-start nil)
- (with-current-buffer orig-buffer
- (goto-char 1)
- (if (el-search-forward `',this-sexp nil t)
- (setq orig-match-start (point)
- orig-match-end (progn (forward-sexp) (point)))
- (setq done t)))
- ;; find out whether we have a sequence of equal expressions
- (while (and (not done)
- (condition-case nil
- (progn (setq this-sexp (el-search-read
(current-buffer)))
- t)
- ((invalid-read-syntax end-of-buffer end-of-file)
nil)))
- (if (with-current-buffer orig-buffer
- (condition-case nil
- (if (not (equal this-sexp (el-search-read
(current-buffer))))
- nil
- (setq orig-match-end (point))
- t)
- ((invalid-read-syntax end-of-buffer end-of-file)
nil)))
- (setq end (point))
- (setq done t)))
- ;; FIXME: there could be another occurrence of THIS-SEXP in
- ;; ORIG-BUFFER with more subsequent equal expressions after it
- ;; FIXME: include any trailing comment?
- (if orig-match-start
- (el-search--replace-hunk
- (list start end)
- (with-current-buffer orig-buffer
- (buffer-substring-no-properties orig-match-start
orig-match-end)))
- (goto-char start)
- (el-search--skip-expression nil t))
- (condition-case nil
- (el-search--ensure-sexp-start)
- (end-of-buffer (goto-char (point-max))))))
- (goto-char 1)
- (forward-sexp (if splice (length replacement) 1))
- (let ((result (buffer-substring 1 (point))))
- (when (cl-some
- (lambda (thing) (and (symbolp thing) thing (not
(intern-soft thing))))
- (el-search--flatten-tree replacement))
- ;; el-search can't handle #N read syntax; we print the
replacement
- ;; with print-circle -> nil
- (user-error "The replacement is not allowed to contain
uninterned symbols"))
- (if (condition-case nil
- (equal replacement (el-search-read (if splice (format
"(%s)" result) result)))
- ((debug error) nil))
- result
- (error "Apparent error in `el-search--format-replacement'
-Can you please make a bug report including a recipe of what
-exactly you did? Thanks!"))))
- (kill-buffer orig-buffer)))))
-
-(defvar el-search-query-replace--current-match-string nil
- "Holds the current match as a string.")
-
-(declare-function ediff-make-cloned-buffer 'ediff-util)
-(declare-function ediff-regions-internal 'ediff)
-(defun el-search-query-replace-ediff-replacement (&rest hook-funs)
- ;; Assumes that the *Replacement* buffer is current
- ;; FIXME: should we make this ediff3 with prefix arg?
- (interactive)
- (let* ((buffer-orig (generate-new-buffer "*El-search Orig*"))
- (buffer-b (make-indirect-buffer
- (current-buffer)
- (generate-new-buffer-name "*El-search Replacement*")
- 'clone))
- (delete-temp-buffers
- (lambda () (mapc #'kill-buffer (list buffer-orig buffer-b)))))
- (with-current-buffer buffer-orig
- (emacs-lisp-mode)
- (insert el-search-query-replace--current-match-string)
- (indent-region (point-min) (point-max))
- (setq buffer-read-only t))
- (require 'ediff)
- (apply #'ediff-regions-internal
- (nconc
- (with-current-buffer buffer-orig (list buffer-orig (point-min)
(point-max)))
- (with-current-buffer buffer-b
- (save-excursion
- (goto-char (point-min))
- (while (looking-at (rx (or (seq bol ";;") (seq bol eol))))
- (forward-line))
- (list (current-buffer) (point) (point-max))))
- (list (apply #'list
- (lambda () (add-hook 'ediff-quit-hook
delete-temp-buffers t t))
- hook-funs)
- 'ediff-regions-linewise nil nil)))))
-
-(defun el-search-query-replace--comments-preserved-p (from-text to-text)
- ;; Return non-nil when strings FROM-TEXT and TO-TEXT contain the same
- ;; comments.
- (cl-flet* ((goto-next-comment-start-p
- (lambda ()
- (let ((success nil) (done nil))
- (while (not (or done success))
- (if (not (search-forward-regexp comment-start-skip nil t))
- (setq done t)
- (setq success (not (nth 3 (syntax-ppss))))))
- success)))
- (get-comments
- (lambda (text)
- (let ((comments '()))
- (with-temp-buffer
- (insert text)
- (goto-char (point-min))
- (emacs-lisp-mode)
- (while (goto-next-comment-start-p)
- (let ((comment-text (buffer-substring (point)
(line-end-position))))
- (unless (string= comment-text "")
- (push comment-text comments)))
- (forward-line +1))
- comments)))))
- (cl-tree-equal
- (sort (get-comments from-text) #'string-lessp)
- (sort (get-comments to-text) #'string-lessp)
- :test #'string=)))
-
-(defun el-search--search-and-replace-pattern
- (pattern replacement &optional splice to-input-string use-current-search)
- (if-let ((qr-object (and (el-search-query-replace-object-p pattern)
pattern)))
- (setq
- el-search--current-query-replace qr-object
- pattern (el-search-query-replace-object-from-pattern
qr-object)
- replacement (el-search-query-replace-object-to-expr
qr-object)
- splice (el-search-query-replace-object-splice
qr-object)
- to-input-string (el-search-query-replace-object-textual-to
qr-object)
- el-search--current-search (el-search-query-replace-object-search-object
qr-object)
- use-current-search t)
- (unless use-current-search
- (let ((current-buffer (current-buffer)))
- (el-search-setup-search-1
- pattern
- (lambda () (stream (list current-buffer)))
- t
- (let ((here (copy-marker (point))))
- (lambda (search)
- (setf (alist-get 'is-single-buffer
- (el-search-object-properties search))
- current-buffer)
- (setf (alist-get 'description (el-search-object-properties
search))
- "Search created by `el-search-query-replace'")
- (let ((inhibit-message t))
- (el-search--next-buffer search)
- (setf (el-search-head-position (el-search-object-head search))
- here)))))))
- (ring-insert el-search-query-replace-object-history
- (setq el-search--current-query-replace
- (make-el-search-query-replace-object
- :search-object el-search--current-search
- :from-pattern pattern
- :to-expr replacement
- :textual-to to-input-string
- :splice nil))))
- (catch 'done
- (let ((replace-all nil) (replace-all-and-following nil)
- nbr-replaced nbr-skipped (nbr-replaced-total 0) (nbr-changed-buffers
0)
- (el-search-keep-hl t) (opoint (point))
- (get-replacement (el-search-make-matcher pattern replacement))
- (skip-matches-in-replacement 'ask)
- (matcher (el-search-make-matcher pattern))
- (heuristic-matcher (el-search--current-heuristic-matcher))
- (save-all-answered nil)
- (should-quit nil)
- (stop-for-comments el-search-query-replace-stop-for-comments)
- (stopped-for-comments nil)
- (message-continue
- (lambda ()
- (message "%s" (substitute-command-keys "Resume with C-u
\\[el-search-query-replace]"))
- (sit-for 2))))
- (let ((replace-in-current-buffer
- (lambda ()
- (setq nbr-replaced 0)
- (setq nbr-skipped 0)
- (condition-case err
- (let ((start-point (point)))
-
- (unless replace-all
- (el-search-hl-other-matches matcher)
- (add-hook 'window-scroll-functions
#'el-search--after-scroll t t)
- (when use-current-search
- (let ((head (el-search-object-head
el-search--current-search)))
- (el-search--message-no-log "%s..."
- (or (el-search-head-file
head)
-
(el-search-head-buffer head)))
- (sit-for 1.))))
-
- (while (el-search--search-pattern-1 matcher t nil
heuristic-matcher)
- (setq opoint (point))
- (setf (el-search-head-position
- (el-search-object-head
el-search--current-search))
- (copy-marker (point)))
- (setf (el-search-object-last-match
el-search--current-search)
- (copy-marker (point)))
- (unless replace-all
- (el-search-hl-sexp))
- (let* ((region (list (point) (el-search--end-of-sexp)))
- (original-text (apply
#'buffer-substring-no-properties region))
- (expr (el-search-read original-text))
- (replaced-this nil)
- (new-expr (funcall get-replacement expr))
- (get-replacement-string
- (lambda () (el-search--format-replacement
- new-expr original-text
to-input-string splice)))
- (to-insert (funcall get-replacement-string))
- (void-replacement-p
- (lambda ()
- ;; We can't just test "(and splice (null
new-expr))" because the
- ;; replacement could have been edited with o
- (with-temp-buffer
- (emacs-lisp-mode)
- (insert to-insert)
- (goto-char (point-min))
- (condition-case nil
- (progn (el-search--ensure-sexp-start)
- nil)
- (end-of-buffer t)))))
- replacement-end-pos
- (do-replace
- (lambda ()
- (save-excursion
- (save-restriction
- (widen)
- (setq replacement-end-pos
- (el-search--replace-hunk
- (list (point)
(el-search--end-of-sexp))
- to-insert))))
- (unless (funcall void-replacement-p)
- ;;skip potentially newly added whitespace
- (el-search--ensure-sexp-start))
- (cl-incf nbr-replaced)
- (cl-incf nbr-replaced-total)
- (setq replaced-this t)
- (when replace-all
- (let ((head (el-search-object-head
el-search--current-search)))
- (el-search--message-no-log
- "%s (%d%%)"
- (or (el-search-head-file head)
- (el-search-head-buffer head))
- (/ (* 100 (- (point) start-point -1))
- (- (point-max) start-point -1)))))))
- (accepted-replacement nil)
- (edit-replacement
- (lambda (&optional ediff-only)
- (save-excursion ;user may copy stuff from
base buffer etc.
- (let* ((header
- (propertize "\
-;; This buffer shows the individual replacement for the current match.
-;; You may edit it here while query-replace is interrupted by a
-;; `recursive-edit'.
-;; Type C-c C-c to confirm, or C-c C-q to quit, dismissing
-;; changes in this buffer.
-;; Type C-c C-e to Ediff the current match with this buffer's content.
-;; Type C-c C-r to revert this buffer."
- 'read-only t 'field t
- 'front-sticky t
'rear-nonsticky t))
- (find-replacement-beg
- (lambda ()
- (goto-char (point-min))
- (when (looking-at (regexp-quote
header))
- (goto-char (match-end 0)))
- (while (and (not (eobp))
(looking-at "^$"))
- (forward-line))))
- (buffer (generate-new-buffer
"*Replacement*"))
- (window (display-buffer buffer)))
- (select-window window)
- (emacs-lisp-mode)
- (unless ediff-only
- (insert header "\n\n"))
- (save-excursion (insert to-insert))
- (let ((inhibit-message t))
- (indent-region (point) (point-max)))
- (let* ((owconf
(current-window-configuration))
- (make-cleanup-fun
- (lambda (&optional do)
- (lambda ()
- (interactive)
- ;; Ediff may change the
window configuration
- (set-window-configuration
owconf)
- (when do (funcall do)))))
- (make-ediff-startup-hook-fun
- (lambda (&optional do)
- (let ((e (funcall
make-cleanup-fun do)))
- (lambda () (add-hook
'ediff-quit-hook e t t))))))
- (use-local-map
- (let ((map (make-sparse-keymap))
- (abort (funcall
- make-cleanup-fun
- (lambda ()
- (set-buffer-modified-p
nil)
-
(exit-recursive-edit)))))
- (set-keymap-parent map
(current-local-map))
- (define-key map [(control ?c)
(control ?c)]
- (funcall make-cleanup-fun
- (lambda ()
- (setq
accepted-replacement t)
- (exit-recursive-edit))))
- (define-key map [(control ?c)
(control ?q)]
- abort)
- (define-key map [(control ?c)
(control ?k)]
- abort)
- (define-key map [(control ?c)
(control ?a)]
- abort)
- (define-key map [(control ?c)
(control ?e)]
- (lambda ()
- (interactive)
-
(el-search-query-replace-ediff-replacement
- (funcall
make-ediff-startup-hook-fun))))
- (define-key map [(control ?c)
(control ?r)]
- (lambda ()
- (interactive)
- (funcall find-replacement-beg)
- (delete-region (point)
(point-max))
- (insert (funcall
get-replacement-string))))
- map))
- (let
((el-search-query-replace--current-match-string
- original-text))
- (when ediff-only
-
(el-search-query-replace-ediff-replacement
- (funcall
make-ediff-startup-hook-fun
- #'exit-recursive-edit)))
- (set-buffer-modified-p nil)
- (recursive-edit)))
- (let ((new-to-insert
- (and (buffer-modified-p buffer)
- (with-current-buffer buffer
- (funcall
find-replacement-beg)
- (string-trim
- (buffer-substring (point)
(point-max)))))))
- (when (and new-to-insert
- (y-or-n-p "Use modified
version?"))
- (setq to-insert new-to-insert)))
- (delete-window window)
- (kill-buffer buffer))
- (el-search--after-scroll (selected-window)
(window-start))
- nil)))
- (use-dialog-box nil)
- (query
- (lambda ()
- (if stopped-for-comments
- (progn
- (setq stopped-for-comments nil)
- ?o)
- (car
- (read-multiple-choice
- (let ((nbr-done (+ nbr-replaced
nbr-skipped))
- (nbr-to-do (el-search-count-matches
pattern)))
- (format "[%d/%d] %s"
- (if replaced-this nbr-done (1+
nbr-done))
- (+ nbr-done nbr-to-do)
- (if replaced-this (propertize
"*" 'face 'success) "-")))
- (delq nil
- (list
- `(?y "y"
- ,(if replaced-this
- "Keep replacement and
move to the next match"
- "Replace match and move to
the next"))
- (and (not replaced-this)
- '(?n "n" "Move to the next
match"))
- '(?r "r" "\
-Replace match but don't move or restore match if already replaced")
- '(?! "!" "Replace all remaining
matches in this buffer")
- '(?b "skip buf"
- "Skip this buffer and any
remaining matches in it")
- (and buffer-file-name
- '(?d "dir"
- "Skip a parent directory
of current file"))
- (and (not replaced-this)
- (list ?s (concat (if splice
"no " "")
- "splice")
-
(substitute-command-keys "\
-Toggle splicing mode (\\[describe-function] el-search-query-replace for
details)")))
- '(?e "edit" "\
-Show current replacement in a separate buffer - you can modify it there")
- '(?E "Ediff" "\
-Ediff match with replacement")
- '(?q "quit")
- '(?\r "quit")
- '(?S "S" "\
-Switch to driving search. Useful to reposition search head.")))))))))
- (when (and
- stop-for-comments
- (not
(el-search-query-replace--comments-preserved-p
- (concat original-text "\n"
to-input-string)
- to-insert)))
- (pcase (if (eq stop-for-comments 'ask)
- (car (read-multiple-choice
- (propertize
- "Problems with adjusting comments
- edit now? "
- 'face
'el-search-highlight-in-prompt-face)
- (list
- '(?y "yes" "Edit the replacement
now")
- '(?n "no" "Just replace and mess
up comments")
- '(?Y "always Yes" "Yes, now and
later - don't ask again")
- '(?N "always No" "No, not now
and not later")
- '(?q "quit"))))
- (progn
- (message "%s" (propertize
- "Problems with adjusting
comments, please edit"
- 'face
'el-search-highlight-in-prompt-face))
- (sit-for 1.5)
- ?y))
- (?n)
- (?N (setq stop-for-comments nil))
- (?y (setq stopped-for-comments t))
- (?Y (setq stop-for-comments t)
- (setq stopped-for-comments t))
- ((or ?q ?\C-g) (signal 'quit t))))
- (if (and replace-all
- (not stopped-for-comments))
- (funcall do-replace)
- (undo-boundary)
- (let* ((handle nil)
- (replace-or-restore
- (lambda ()
- (if (not replaced-this)
- (progn
- (activate-change-group
- (setq handle
(prepare-change-group)))
- (funcall do-replace))
- (cancel-change-group handle)
- (setq handle nil)
- (setq replaced-this nil)
- (cl-decf nbr-replaced)
- (cl-decf nbr-replaced-total))))
- (edit-and-update
- (lambda (&optional ediff-only)
- (let ((old-to-insert to-insert))
- (funcall edit-replacement ediff-only)
- (unless (and (string= old-to-insert
to-insert)
- (not accepted-replacement))
- (if (not replaced-this)
- (progn
- (funcall replace-or-restore)
- (undo-boundary))
- ;; (el-search--message-no-log
- ;; "Already replaced this match -
hit r r to update")
- ;; (sit-for 2)
- (funcall replace-or-restore)
- (funcall replace-or-restore))))
- nil)))
- (unwind-protect
- (while (not (pcase (funcall query)
- (?r (funcall replace-or-restore)
- nil)
- (?y
- (unless replaced-this (funcall
do-replace))
- t)
- (?n
- (cl-incf nbr-skipped)
- t)
- (?!
- (setq replace-all t)
- (when (and use-current-search
- (not (alist-get
-
'is-single-buffer
-
(el-search-object-properties
-
el-search--current-search))))
- (pcase (car
(read-multiple-choice
- "\
-Also replace in all following buffers?"
- '((?! "Only
this"
- "\
-Replace only remaining matches in this buffer")
- (?/ "This
then pause"
- "\
-Replace all in this buffer then terminate to resume session later")
- (?A "All
buffers"
- "\
-Replace all matches in all buffers"))))
- (?A (setq
replace-all-and-following t))
- (?/ (setq replace-all
'stop))))
- (unless replaced-this (funcall
do-replace))
- t)
- (?b (goto-char (point-max))
- (message "Skipping this
buffer")
- (sit-for 1)
- ;; FIXME: add #skipped
matches to nbr-skipped?
- t)
- (?d (call-interactively
#'el-search-skip-directory)
- t)
- (?s
- (setq splice (not splice)
- to-insert (funcall
get-replacement-string))
- (setf
(el-search-query-replace-object-splice
-
el-search--current-query-replace)
- splice)
- nil)
- (?e (funcall edit-and-update)
- nil)
- (?E (funcall edit-and-update
'ediff-only)
- nil)
- ((or ?q ?\C-g ?\r) (signal
'quit t))
- (?S
- (run-with-timer
- 0 nil
- (lambda ()
- (message "Activating
driving search...")
- (sit-for 1.)
- (el-search-jump
el-search--current-search)))
- (signal 'quit t)))))
- (when handle (accept-change-group handle))))
- (when (and replaced-this (not replace-all))
- (undo-boundary)))
- (unless (eobp)
- (let* ((replacement-contains-another-match
- (and replaced-this
- ;; This intentionally includes the
replacement itself
- (save-excursion
- (el-search--search-pattern-1
- matcher t replacement-end-pos
heuristic-matcher))))
- (skip-replacement
- (lambda () (goto-char
replacement-end-pos))))
- (cond
- ((not (and replaced-this
- replacement-contains-another-match
- skip-matches-in-replacement))
- (unless (or replaced-this (eobp))
- (el-search--skip-expression nil t)))
- ((eq skip-matches-in-replacement 'ask)
- (el-search-hl-other-matches matcher)
- (pcase (car (read-multiple-choice
- (propertize
- "Skip the matches in the
replacement? "
- 'face
'el-search-highlight-in-prompt-face)
- '((?s "skip"
- "Skip any matches in this
replacement")
- (?d "don't"
- "Continue with the matches
in the replacement")
- (?S "always Skip"
- "Skip now and for the rest
of this session")
- (?D "always Don't"
- "Don't skip now and for the
rest of this session")
- (?q "quit"
- "Abort this query-replace
session"))))
- ((and (or ?s ?S) answer)
- (when (= answer ?S) (setq
skip-matches-in-replacement t))
- (funcall skip-replacement))
- (?q (signal 'quit t))
- (answer
- (when (= answer ?D) (setq
skip-matches-in-replacement nil))
- (when replace-all
- (setq replace-all nil)
- ;; FIXME: can this be annoying? Problem:
we need to catch possibly
- ;; infinite loops
- (message "Falling back to interactive
mode")
- (sit-for 2.)))))
- (t (funcall skip-replacement))))))))
- (quit (setq should-quit t))
- ((error debug) (setq should-quit (lambda () (error "%s"
(error-message-string err))))))
- (el-search-hl-remove)
- (when should-quit
- (remove-hook 'post-command-hook
'el-search-hl-post-command-fun t)
- (if (functionp should-quit)
- (funcall should-quit)
- (funcall message-continue)
- (throw 'done t)))
- (setf (el-search-head-position (el-search-object-head
el-search--current-search))
- (point-max))
- (goto-char opoint)
- (if (> nbr-replaced 0)
- (progn
- (cl-incf nbr-changed-buffers)
- (when (pcase el-search-auto-save-buffers
- ((or 'nil
- (guard (not buffer-file-name)))
- nil)
- ((and 'ask-multi
- (guard (alist-get 'is-single-buffer
-
(el-search-object-properties
-
el-search--current-search))))
- nil)
- ((or 'ask 'ask-multi)
- (if save-all-answered
- (cdr save-all-answered)
- (pcase (car (read-multiple-choice
- (format
- "Replaced %d matches%s - save
this buffer? "
- nbr-replaced
- (if (zerop nbr-skipped) ""
- (format " (%d skipped)"
nbr-skipped)))
- '((?y "yes")
- (?n "no")
- (?Y "Yes to all"
- "\
-Save this buffer and all following buffers without asking again")
- (?N "No to all"
- "\
-Don't save this buffer and all following buffers; don't ask again"))))
- (?y t)
- (?n nil)
- (?Y (cdr (setq save-all-answered (cons t
t))))
- (?N (cdr (setq save-all-answered (cons t
nil)))))))
- (_ t))
- (save-buffer)))
- (unless use-current-search
- (message "Replaced %d matches%s"
- nbr-replaced
- (if (zerop nbr-skipped) ""
- (format " (%d skipped)" nbr-skipped))))))))
- (let ((stop nil))
- (while (and (not stop)
- ;FIXME: do it better.
- (progn (el-search-continue-search)
- (and el-search--success (not
el-search--wrap-flag))))
- (funcall replace-in-current-buffer)
- (when (eq replace-all 'stop)
- (setq stop t)
- (el-search-hl-post-command-fun 'stop)
- (funcall message-continue))
- (unless replace-all-and-following (setq replace-all nil))))
- (message "Replaced %d matches in %d buffers" nbr-replaced-total
nbr-changed-buffers)))))
-
-(defun el-search-query-replace--read-args ()
- (barf-if-buffer-read-only)
- (if (not current-prefix-arg)
- (let ((from-input
- (let ((el-search--initial-mb-contents
- (or el-search--initial-mb-contents
- (and (or (eq last-command 'el-search-pattern)
- (el-search--pending-search-p))
- (if (equal (el-search--current-pattern)
- (el-search-read (car
el-search-query-replace-history)))
- (car el-search-query-replace-history)
- (el-search--pp-to-string
(el-search--current-pattern)))))))
- ;; We only want error hints so we don't bind
el-search--display-match-count-in-prompt
- (unwind-protect (minibuffer-with-setup-hook
#'el-search-read-pattern-setup-mb
- (let
((el-search--reading-input-for-query-replace t))
- (el-search--read-pattern "Query replace
pattern: " nil
-
'el-search-query-replace-history)))
- (when (timerp el-search--mb-hints-timer)
- (cancel-timer el-search--mb-hints-timer)))))
- from to read-from read-to)
- (with-temp-buffer
- (emacs-lisp-mode)
- (insert from-input)
- (goto-char 1)
- (forward-sexp)
- (skip-chars-forward " \t\n ")
- ;; FIXME: maybe more sanity tests here...
- (if (not (looking-at (rx (or "->" "=>" ">"))))
- (setq from from-input
- to (let ((el-search--initial-mb-contents nil))
- (el-search--read-pattern "Replace with result of
evaluation of: " from)))
- (delete-region (point) (match-end 0))
- (goto-char 1)
- (forward-sexp)
- (setq from (buffer-substring 1 (point)))
- (skip-chars-forward " \t\n ")
- (setq to (buffer-substring (point) (progn (forward-sexp)
(point))))))
- (unless (and el-search-query-replace-history
- (not (string= from from-input))
- (string= from-input (car
el-search-query-replace-history)))
- (push (with-temp-buffer
- (emacs-lisp-mode)
- (insert (let ((newline-in-from (string-match-p "\n" from))
- (newline-in-to (string-match-p "\n" to)))
- (format "%s%s%s ->%s%s"
- (if (and (or newline-in-from newline-in-to)
- (not (string-match-p (rx bos
"\n") from))) "\n" "")
- (if newline-in-from
"\n" "" ) from
- (if (and (or newline-in-from newline-in-to)
- (not (string-match-p (rx bos
"\n") to))) "\n" " ") to)))
- (indent-region 1 (point-max))
- (buffer-string))
- el-search-query-replace-history))
- (el-search--pushnew-to-history from 'el-search-pattern-history)
- (setq read-from (el-search-read from))
- (setq read-to (el-search-read to))
- (el-search--maybe-warn-about-unquoted-symbol read-from)
- (when (and (symbolp read-to)
- (not (el-search--contains-p (el-search-make-matcher
`',read-to) read-from))
- (not (eq read-to t))
- (not (eq read-to nil)))
- (el-search--maybe-warn-about-unquoted-symbol read-to))
- (list read-from read-to to))
- (unless el-search--current-query-replace
- (error "No pending query-replace session"))
- (let ((numeric-prefix (prefix-numeric-value current-prefix-arg)))
- (when (or (< numeric-prefix 0) (equal current-prefix-arg '(16)))
- (setq el-search--current-query-replace
- (el-search--read-history-entry
- el-search-query-replace-object-history
- #'el-search--get-q-r-description-string)))
- (let ((query-restart (lambda () (y-or-n-p "Restart current query-replace
session? ")))
- (restart (lambda () (el-search-reset-search
- (el-search-query-replace-object-search-object
- el-search--current-query-replace)))))
- (unless (or (= numeric-prefix 0)
- (el-search-head-buffer
- (el-search-object-head
- (el-search-query-replace-object-search-object
- el-search--current-query-replace)))
- (and (funcall query-restart)
- (prog1 t (funcall restart))))
- (user-error "%s" (substitute-command-keys "\
-Session terminated - C-u 0 \\[el-search-query-replace] to restart")))
- (when (and (= numeric-prefix 0)
- (or (funcall query-restart)
- (user-error "Abort")))
- (funcall restart)))
- (list el-search--current-query-replace nil))))
-
-;;;###autoload
-(defun el-search-query-replace (from-pattern to-expr &optional textual-to)
- "Replace some matches of \"el-search\" pattern FROM-PATTERN.
-
-With prefix arg, generally resume the last session; but with
-prefix arg 0 restart the last session, and with negative or plain
-C-u C-u prefix arg, prompt for an older session to resume.
-
-FROM-PATTERN is an el-search pattern to match. TO-EXPR is an
-Elisp expression that is evaluated repeatedly for each match with
-bindings created in FROM-PATTERN in effect to produce a
-replacement expression.
-
-As each match is found, the user must type a character saying
-what to do with it. For directions, type ? at that time.
-
-As an alternative to enter FROM-PATTERN and TO-EXPR separately,
-you can also give an input of the form
-
- FROM-PATTERN -> TO-EXPR
-
-\(\">\" and \"=>\" are also allowed as a separator) to the first
-prompt and specify both expressions at once. This format is also
-used for history entries.
-
-Operate from point to (point-max), unless when called directly
-after a search command; then use the current search to drive
-query-replace (similar to isearch). You get a multi-buffer
-query-replace this way when the current search is multi-buffer.
-
-It is possible to replace matches with an arbitrary number of
-expressions (even with zero expressions, effectively deleting
-matches) by using the \"splicing\" submode that can be toggled
-from the prompt with \"s\". When splicing mode is on (default
-off), the replacement expression must evaluate to a list, and all
-of the list's elements are inserted in order.
-
-In a non-interactive call, FROM-PATTERN can be an
-el-search-query-replace-object to resume. In this case the remaining
-arguments are ignored."
- (interactive (el-search-query-replace--read-args)) ;this binds the optional
argument
- (setq this-command 'el-search-query-replace) ;in case we come from isearch
- (el-search--search-and-replace-pattern
- from-pattern to-expr nil textual-to
- (or (el-search-query-replace-object-p from-pattern)
- (let ((search-head (and el-search--current-search
- (el-search-object-head
el-search--current-search))))
- (and
- search-head
- (eq (el-search-head-buffer search-head) (current-buffer))
- (equal from-pattern (el-search-object-pattern
el-search--current-search))
- (or (eq last-command 'el-search-pattern)
- (el-search--pending-search-p))
- (prog1 t
- (el-search--message-no-log "Using the current search to drive
query-replace...")
- (sit-for 1.)))))))
-
-(defun el-search--take-over-from-isearch (&optional goto-left-end)
- (let ((other-end (and goto-left-end isearch-other-end))
- (input isearch-string))
- (isearch-exit)
- (when (and other-end (< other-end (point)))
- (goto-char other-end))
- input))
-
-
-;;;; Invoking from Isearch
-
-;;;###autoload
-(defun el-search-search-from-isearch ()
- "Switch to an el-search session from isearch.
-Reuse already given input."
- (interactive)
- (let ((el-search--initial-mb-contents (concat "'"
(el-search--take-over-from-isearch))))
- ;; use `call-interactively' so we get recorded in
`extended-command-history'
- (call-interactively #'el-search-pattern)))
-
-;;;###autoload
-(defun el-search-search-backward-from-isearch ()
- "Switch to `el-search-pattern-backward' from isearch.
-Reuse already given input."
- (interactive)
- (let ((el-search--initial-mb-contents (concat "'"
(el-search--take-over-from-isearch))))
- (call-interactively #'el-search-pattern-backward)))
-
-(define-obsolete-function-alias 'el-search-search-backwards-from-isearch
- 'el-search-search-backward-from-isearch "el-search 1.6.7")
-
-;;;###autoload
-(defun el-search-replace-from-isearch ()
- "Switch to `el-search-query-replace' from isearch.
-Reuse already given input."
- (interactive)
- (let ((el-search--initial-mb-contents (concat "'"
(el-search--take-over-from-isearch t))))
- (call-interactively #'el-search-query-replace)))
-
-;;;###autoload
-(defun el-search-occur-from-isearch ()
- "Switch to `el-search-occur' from isearch.
-Reuse already given input."
- (interactive)
- (setq el-search-occur-flag t)
- (call-interactively #'el-search-search-from-isearch))
-
-
-;;;; Menus
-
-;;;###autoload
-(progn
- (require 'easymenu)
-
- (easy-menu-add-item
- nil '("Tools")
- `("El-Search"
- ["Search Directory" el-search-directory]
- ["Search Directory Recursively"
- ,(lambda () (interactive)
- (let ((current-prefix-arg '(4)))
- (call-interactively #'el-search-directory)))]
- ["Search 'load-path'" el-search-load-path]
- ["Search Emacs Elisp Sources" el-search-emacs-elisp-sources]
- ["Search Elisp Buffers" el-search-buffers]
- ["Search Repository" el-search-repository]
- ["List Patterns" el-search-list-defined-patterns]))
-
- (easy-menu-add-item
- (lookup-key emacs-lisp-mode-map [menu-bar]) '("Emacs-Lisp")
- `("El-Search"
- ["Forward" el-search-pattern]
- ["Backward" el-search-pattern-backward]
- ["Sexp at Point" el-search-this-sexp]
- ["Resume Last Search" el-search-jump :enable el-search--current-search]
- ["Resume Former Search" ,(lambda () (interactive) (el-search-jump '(4)))
- :enable (cdr (ring-elements el-search-history))]
- ["Query-Replace" el-search-query-replace :enable (not buffer-read-only)]
- ["Resume Query-Replace"
- ,(lambda () (interactive) (el-search-query-replace
el-search--current-query-replace nil))
- :enable el-search--current-query-replace]
- ["Occur" ,(lambda () (interactive)
- (defvar el-search-occur-flag)
- (let ((el-search-occur-flag t)) (call-interactively
#'el-search-pattern)))])))
-
-(easy-menu-define nil el-search-occur-mode-map "El Occur Menu"
- `("El-Occur"
- ["Next Match" el-search-occur-next-match
- :help "Go to the next match"]
- ["Previous Match" el-search-occur-previous-match
- :help "Go to the previous match"]
- ["Jump to Source" el-search-occur-jump-to-match
- :help "Jump to corresponding position in source"]
- ["Adjust Pattern" el-search-edit-occur-pattern
- :help "Edit search pattern and revert"]
- ("Context"
- ["No context" el-search-occur-no-context
- :style radio
- :selected (eq el-search-get-occur-context-function
'el-search-occur-get-null-context)]
- ["Some context" el-search-occur-some-context
- :style radio
- :selected (eq el-search-get-occur-context-function
'el-search-occur-get-some-context)]
- ["Top-Level" el-search-occur-defun-context
- :style radio
- :selected (eq el-search-get-occur-context-function
'el-search-occur-get-defun-context)])
- ("Outline"
- ["Hide all" el-search-occur-cycle :style radio :selected (not
el-search-occur--outline-visible)]
- ["Show All" el-search-occur-cycle :style radio :selected
el-search-occur--outline-visible])))
-
-
-(provide 'el-search)
-;;; el-search.el ends here
diff --git a/packages/electric-spacing/electric-spacing.el
b/packages/electric-spacing/electric-spacing.el
deleted file mode 100644
index 14e8ce0..0000000
--- a/packages/electric-spacing/electric-spacing.el
+++ /dev/null
@@ -1,352 +0,0 @@
-;;; electric-spacing.el --- Insert operators with surrounding spaces smartly
-
-;; Copyright (C) 2004, 2005, 2007-2014 Free Software Foundation, Inc.
-
-;; Author: William Xu <william.xwl@gmail.com>
-;; Version: 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, 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 EMMS; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; Smart Operator mode is a minor mode which automatically inserts
-;; surrounding spaces around operator symbols. For example, `='
-;; becomes ` = ', `+=' becomes ` += '. This is most handy for writing
-;; C-style source code.
-;;
-;; Type `M-x smart-operator-mode' to toggle this minor mode.
-
-;;; Acknowledgements
-
-;; Nikolaj Schumacher <n_schumacher@web.de>, for suggesting
-;; reimplementing as a minor mode and providing an initial patch for
-;; that.
-
-;;; Code:
-
-(require 'cc-mode)
-
-;;; electric-spacing minor mode
-
-(defcustom electric-spacing-double-space-docs t
- "Enable double spacing of . in document lines - e.g., type `.' => get `. '."
- :type 'boolean
- :group 'electricity)
-
-(defcustom electric-spacing-docs t
- "Enable electric-spacing in strings and comments."
- :type 'boolean
- :group 'electricity)
-
-(defvar electric-spacing-rules
- '((?= . electric-spacing-self-insert-command)
- (?< . electric-spacing-<)
- (?> . electric-spacing->)
- (?% . electric-spacing-%)
- (?+ . electric-spacing-+)
- (?- . electric-spacing--)
- (?* . electric-spacing-*)
- (?/ . electric-spacing-/)
- (?& . electric-spacing-&)
- (?| . electric-spacing-self-insert-command)
- (?: . electric-spacing-:)
- (?? . electric-spacing-?)
- (?, . electric-spacing-\,)
- (?~ . electric-spacing-~)
- (?. . electric-spacing-.)))
-
-(defun electric-spacing-post-self-insert-function ()
- (when electric-spacing-mode
- (let ((rule (cdr (assq last-command-event electric-spacing-rules))))
- (when rule
- (goto-char (electric--after-char-pos))
- (delete-char -1)
- (funcall rule)))))
-
-(add-hook 'post-self-insert-hook #'electric-spacing-post-self-insert-function)
-
-;;;###autoload
-(define-minor-mode electric-spacing-mode
- "Toggle automatic surrounding space insertion (Electric Spacing mode).
-With a prefix argument ARG, enable Electric Spacing mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
-
-This is a local minor mode. When enabled, typing an operator automatically
-inserts surrounding spaces. e.g., `=' becomes ` = ', `+=' becomes ` += '.
-This is very handy for many programming languages."
- :global nil
- :group 'electricity
- :lighter " _+_")
-
-(defun electric-spacing-self-insert-command ()
- "Insert character with surrounding spaces."
- (electric-spacing-insert (string last-command-event)))
-
-(defun electric-spacing-insert (op &optional only-where)
- "See `electric-spacing-insert-1'."
- (delete-horizontal-space)
- (cond ((and (electric-spacing-lispy-mode?)
- (not (electric-spacing-document?)))
- (electric-spacing-lispy op))
- ((not electric-spacing-docs)
- (electric-spacing-insert-1 op 'middle))
- (t
- (electric-spacing-insert-1 op only-where))))
-
-(defun electric-spacing-insert-1 (op &optional only-where)
- "Insert operator OP with surrounding spaces.
-e.g., `=' becomes ` = ', `+=' becomes ` += '.
-
-When `only-where' is 'after, we will insert space at back only;
-when `only-where' is 'before, we will insert space at front only;
-when `only-where' is 'middle, we will not insert space."
- (pcase only-where
- (`before (insert " " op))
- (`middle (insert op))
- (`after (insert op " "))
- (_
- (let ((begin? (bolp)))
- (unless (or (looking-back (regexp-opt
- (mapcar 'char-to-string
- (mapcar 'car
electric-spacing-rules)))
- (line-beginning-position))
- begin?)
- (insert " "))
- (insert op " ")
- (when begin?
- (indent-according-to-mode))))))
-
-(defun electric-spacing-c-types ()
- (concat c-primitive-type-key "?"))
-
-(defun electric-spacing-document? ()
- (nth 8 (syntax-ppss)))
-
-(defun electric-spacing-lispy-mode? ()
- (derived-mode-p 'emacs-lisp-mode
- 'lisp-mode
- 'lisp-interaction-mode
- 'scheme-mode))
-
-(defun electric-spacing-lispy (op)
- "We're in a Lisp-ish mode, so let's look for parenthesis.
-Meanwhile, if not found after ( operators are more likely to be function names,
-so let's not get too insert-happy."
- (cond
- ((save-excursion
- (backward-char 1)
- (looking-at "("))
- (if (equal op ",")
- (electric-spacing-insert-1 op 'middle)
- (electric-spacing-insert-1 op 'after)))
- ((equal op ",")
- (electric-spacing-insert-1 op 'before))
- (t
- (electric-spacing-insert-1 op 'middle))))
-
-
-;;; Fine Tunings
-
-(defun electric-spacing-< ()
- "See `electric-spacing-insert'."
- (cond
- ((or (and c-buffer-is-cc-mode
- (looking-back
- (concat "\\("
- (regexp-opt
- '("#include" "vector" "deque" "list" "map" "stack"
- "multimap" "set" "hash_map" "iterator" "template"
- "pair" "auto_ptr" "static_cast"
- "dynmaic_cast" "const_cast" "reintepret_cast"
-
- "#import"))
- "\\)\\ *")
- (line-beginning-position)))
- (derived-mode-p 'sgml-mode))
- (insert "<>")
- (backward-char))
- (t
- (electric-spacing-insert "<"))))
-
-(defun electric-spacing-: ()
- "See `electric-spacing-insert'."
- (cond (c-buffer-is-cc-mode
- (if (looking-back "\\?.+")
- (electric-spacing-insert ":")
- (electric-spacing-insert ":" 'middle)))
- ((derived-mode-p 'haskell-mode)
- (electric-spacing-insert ":"))
- (t
- (electric-spacing-insert ":" 'after))))
-
-(defun electric-spacing-\, ()
- "See `electric-spacing-insert'."
- (electric-spacing-insert "," 'after))
-
-(defun electric-spacing-. ()
- "See `electric-spacing-insert'."
- (cond ((and electric-spacing-double-space-docs
- (electric-spacing-document?))
- (electric-spacing-insert "." 'after)
- (insert " "))
- ((or (looking-back "[0-9]")
- (or (and c-buffer-is-cc-mode
- (looking-back "[a-z]"))
- (and
- (derived-mode-p 'python-mode 'ruby-mode)
- (looking-back "[a-z\)]"))
- (and
- (derived-mode-p 'js-mode 'js2-mode)
- (looking-back "[a-z\)$]"))))
- (insert "."))
- ((derived-mode-p 'cperl-mode 'perl-mode 'ruby-mode)
- ;; Check for the .. range operator
- (if (looking-back ".")
- (insert ".")
- (insert " . ")))
- (t
- (electric-spacing-insert "." 'after)
- (insert " "))))
-
-(defun electric-spacing-& ()
- "See `electric-spacing-insert'."
- (cond (c-buffer-is-cc-mode
- ;; ,----[ cases ]
- ;; | char &a = b; // FIXME
- ;; | void foo(const int& a);
- ;; | char *a = &b;
- ;; | int c = a & b;
- ;; | a && b;
- ;; `----
- (cond ((looking-back (concat (electric-spacing-c-types) " *" ))
- (electric-spacing-insert "&" 'after))
- ((looking-back "= *")
- (electric-spacing-insert "&" 'before))
- (t
- (electric-spacing-insert "&"))))
- (t
- (electric-spacing-insert "&"))))
-
-(defun electric-spacing-* ()
- "See `electric-spacing-insert'."
- (cond (c-buffer-is-cc-mode
- ;; ,----
- ;; | a * b;
- ;; | char *a;
- ;; | char **b;
- ;; | (*a)->func();
- ;; | *p++;
- ;; | *a = *b;
- ;; `----
- (cond ((looking-back (concat (electric-spacing-c-types) " *" ))
- (electric-spacing-insert "*" 'before))
- ((looking-back "\\* *")
- (electric-spacing-insert "*" 'middle))
- ((looking-back "^[ (]*")
- (electric-spacing-insert "*" 'middle)
- (indent-according-to-mode))
- ((looking-back "= *")
- (electric-spacing-insert "*" 'before))
- (t
- (electric-spacing-insert "*"))))
- (t
- (electric-spacing-insert "*"))))
-
-(defun electric-spacing-> ()
- "See `electric-spacing-insert'."
- (cond ((and c-buffer-is-cc-mode (looking-back " - "))
- (delete-char -3)
- (insert "->"))
- (t
- (electric-spacing-insert ">"))))
-
-(defun electric-spacing-+ ()
- "See `electric-spacing-insert'."
- (cond ((and c-buffer-is-cc-mode (looking-back "\\+ *"))
- (when (looking-back "[a-zA-Z0-9_] +\\+ *")
- (save-excursion
- (backward-char 2)
- (delete-horizontal-space)))
- (electric-spacing-insert "+" 'middle)
- (indent-according-to-mode))
- (t
- (electric-spacing-insert "+"))))
-
-(defun electric-spacing-- ()
- "See `electric-spacing-insert'."
- (cond ((and c-buffer-is-cc-mode (looking-back "\\- *"))
- (when (looking-back "[a-zA-Z0-9_] +\\- *")
- (save-excursion
- (backward-char 2)
- (delete-horizontal-space)))
- (electric-spacing-insert "-" 'middle)
- (indent-according-to-mode))
- (t
- (electric-spacing-insert "-"))))
-
-(defun electric-spacing-? ()
- "See `electric-spacing-insert'."
- (cond (c-buffer-is-cc-mode
- (electric-spacing-insert "?"))
- (t
- (electric-spacing-insert "?" 'after))))
-
-(defun electric-spacing-% ()
- "See `electric-spacing-insert'."
- (cond (c-buffer-is-cc-mode
- ;; ,----
- ;; | a % b;
- ;; | printf("%d %d\n", a % b);
- ;; `----
- (if (and (looking-back "\".*")
- (not (looking-back "\",.*")))
- (insert "%")
- (electric-spacing-insert "%")))
- ;; If this is a comment or string, we most likely
- ;; want no spaces - probably string formatting
- ((and (derived-mode-p 'python-mode)
- (electric-spacing-document?))
- (insert "%"))
- (t
- (electric-spacing-insert "%"))))
-
-(defun electric-spacing-~ ()
- "See `electric-spacing-insert'."
- ;; First class regex operator =~ langs
- (cond ((derived-mode-p 'ruby-mode 'perl-mode 'cperl-mode)
- (if (looking-back "= ")
- (progn
- (delete-char -2)
- (insert "=~ "))
- (insert "~")))
- (t
- (insert "~"))))
-
-(defun electric-spacing-/ ()
- "See `electric-spacing-insert'."
- ;; *nix shebangs #!
- (cond ((and (eq 1 (line-number-at-pos))
- (save-excursion
- (move-beginning-of-line nil)
- (looking-at "#!")))
- (insert "/"))
- (t
- (electric-spacing-insert "/"))))
-
-(provide 'electric-spacing)
-
-;;; electric-spacing.el ends here
diff --git a/packages/epoch-view/epoch-view.el
b/packages/epoch-view/epoch-view.el
deleted file mode 100644
index 8093637..0000000
--- a/packages/epoch-view/epoch-view.el
+++ /dev/null
@@ -1,99 +0,0 @@
-;;; epoch-view.el --- Minor mode to visualize epoch timestamps
-
-;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
-
-;; Author: Ted Zlatanov <tzz@lifelogs.com>
-;; Keywords: data, timestamp, epoch, unix
-;; Version: 0.0.1
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Use like any other minor mode. You'll see tooltips with dates
-;; instead of Unix epoch times. This mode turns on font-lock and
-;; leaves it on forever. You may or may not like that.
-
-;;; TODO:
-
-;; Instead of letting font-lock-mode manage the `display' property,
-;; manage it ourselves so when multiple modes specify `display' it
-;; won't get wiped out when this mode doesn't need it anymore.
-
-;;; Code:
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; User Variables:
-
-(defcustom epoch-view-time-format "%F %T"
- "Format for time view. Same as `format-time-string'."
- :type '(choice :tag "Time format"
- (string :tag "Choose your own `format-time-string' format")
- (const :tag "YYYY-MM-DD HH:MM:SS" "%F %T"))
- :group 'epoch-view)
-
-(defvar epoch-view-font-lock-keywords
- '(("\\<[0-9]\\{8,11\\}\\>"
- (0 (epoch-view-render))))
- "Font-lock keywords of epoch timestamps.")
-
-(defun epoch-view-render ()
- "Render a epoch match."
- (let ((text (match-string-no-properties 0)))
- `(face font-lock-warning-face
- display ,(epoch-view--render text))))
-
-(defun epoch-view--render-time (text)
- "Render the time portion of an epoch match from TEXT."
- (format-time-string
- epoch-view-time-format
- (seconds-to-time (car (read-from-string (concat text ".0"))))))
-
-(defun epoch-view--render (text)
- "Render a epoch match from a number in TEXT, ending with TEXT."
- (format "[%s] %s" (epoch-view--render-time text) text))
-
-(defun epoch-view-turn-on ()
- "Turn on epoch-view-mode."
- (let ((props (make-local-variable 'font-lock-extra-managed-props)))
- (add-to-list props 'display))
-
- (font-lock-add-keywords nil epoch-view-font-lock-keywords))
-
-(defun epoch-view-turn-off ()
- "Turn off epoch-view-mode."
- (font-lock-remove-keywords
- nil
- `(,@epoch-view-font-lock-keywords)))
-
-;;;###autoload
-(define-minor-mode
- epoch-view-mode
- "Visualize epoch (Unix) timestamps."
- :lighter " EpochVw"
- (progn
- (if epoch-view-mode
- (epoch-view-turn-on)
- (epoch-view-turn-off))
- ;; Turn on font lock
- (font-lock-mode 1)))
-
-(provide 'epoch-view)
-
-(run-hooks 'epoch-view-load-hook)
-
-;;; epoch-view.el ends here
diff --git a/packages/filladapt/filladapt.el b/packages/filladapt/filladapt.el
deleted file mode 100644
index 685c7e3..0000000
--- a/packages/filladapt/filladapt.el
+++ /dev/null
@@ -1,854 +0,0 @@
-;;; filladapt.el --- Adaptive fill -*- lexical-binding:t -*-
-
-;; Copyright (C) 1989, 1995-2018 Free Software Foundation, Inc.
-
-;; Author: Kyle E. Jones <kyle_jones@wonderworks.com>
-;; Maintainer: emacs-devel@gnu.org
-;; Version: 2.12.2
-;; Package-Requires: ((emacs "24.4"))
-
-;; 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, 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 <http://www.gnu.org/licenses/>.
-;;
-
-;; LCD Archive Entry:
-;; filladapt|Kyle Jones|kyle_jones@wonderworks.com|
-;; Minor mode to adaptively set fill-prefix and overload filling functions|
-;; 28-February-1998|2.12|~/packages/filladapt.el|
-
-;;; Commentary:
-
-;; These functions enhance the default behavior of Emacs' Auto Fill
-;; mode and the commands fill-paragraph, lisp-fill-paragraph,
-;; fill-region-as-paragraph and fill-region.
-;;
-;; The chief improvement is that the beginning of a line to be
-;; filled is examined and, based on information gathered, an
-;; appropriate value for fill-prefix is constructed. Also the
-;; boundaries of the current paragraph are located. This occurs
-;; only if the fill prefix is not already non-nil.
-;;
-;; The net result of this is that blurbs of text that are offset
-;; from left margin by asterisks, dashes, and/or spaces, numbered
-;; examples, included text from USENET news articles, etc.. are
-;; generally filled correctly with no fuss.
-;;
-;; Since this package replaces existing Emacs functions, it cannot
-;; be autoloaded. Save this in a file named filladapt.el in a
-;; Lisp directory that Emacs knows about, byte-compile it and put
-;; (require 'filladapt)
-;; in your .emacs file.
-;;
-;; Note that in this release Filladapt mode is a minor mode and it is
-;; _off_ by default. If you want it to be on by default, use
-;; (setq-default filladapt-mode t)
-;;
-;; M-x filladapt-mode toggles Filladapt mode on/off in the current
-;; buffer.
-;;
-;; Use
-;; (add-hook 'text-mode-hook #'filladapt-mode)
-;; to have Filladapt always enabled in Text mode.
-;;
-;; Use
-;; (add-hook 'c-mode-hook #'turn-off-filladapt-mode)
-;; to have Filladapt always disabled in C mode.
-;;
-;; In many cases, you can extend Filladapt by adding appropriate
-;; entries to the following three `defvar's. See `postscript-comment'
-;; or `texinfo-comment' as a sample of what needs to be done.
-;;
-;; filladapt-token-table
-;; filladapt-token-match-table
-;; filladapt-token-conversion-table
-
-;;; Code:
-
-(defgroup filladapt nil
- "Enhanced filling"
- :group 'fill)
-
-(defvar filladapt-mode) ;Defined later by `define-minor-mode'.
-
-(defcustom filladapt-mode-line-string " Filladapt"
- "String to display in the modeline when Filladapt mode is active.
-Set this to nil if you don't want a modeline indicator for Filladapt."
- :type 'string)
-
-(defcustom filladapt-fill-column-tolerance nil
- "Tolerate filled paragraph lines ending this far from the fill column.
-If any lines other than the last paragraph line end at a column
-less than \"fill-column - filladapt-fill-column-tolerance\", `fill-column' will
-be adjusted using the filladapt-fill-column-*-fuzz variables and
-the paragraph will be re-filled until the tolerance is achieved
-or filladapt runs out of fuzz values to try.
-
-A nil value means behave normally, that is, don't try refilling
-paragraphs to make filled line lengths fit within any particular
-range."
- :type '(choice (const nil)
- integer))
-
-(defcustom filladapt-fill-column-forward-fuzz 5
- "Try values from `fill-column' to \"fill-column + this variable\"
-when trying to make filled paragraph lines fall with the tolerance
-range specified by `filladapt-fill-column-tolerance'."
- :type 'integer)
-
-(defcustom filladapt-fill-column-backward-fuzz 5
- "Try values from `fill-column' to \"fill-column - this variable\"
-when trying to make filled paragraph lines fall with the tolerance
-range specified by `filladapt-fill-column-tolerance'."
- :type 'integer)
-
-(defcustom filladapt-token-table
- '(
- ;; this must be first
- ("^" beginning-of-line)
- ;; Included text in news or mail replies
- (">+" citation->)
- ;; Included text generated by SUPERCITE. We can't hope to match all
- ;; the possible variations, your mileage may vary.
- ("\\(\\w\\|[0-9]\\)[^'`\"< \t\n]*>[ \t]*" supercite-citation)
- ;; Lisp comments
- (";+" lisp-comment)
- ;; UNIX shell comments
- ("#+" sh-comment)
- ;; Postscript comments
- ("%+" postscript-comment)
- ;; C++ comments
- ("///*" c++-comment)
- ;; Texinfo comments
- ("@c[ \t]" texinfo-comment)
- ("@comment[ \t]" texinfo-comment)
- ;; Bullet types.
- ;;
- ;; LaTex \item
- ;;
- ("\\\\item[ \t]" bullet)
- ;;
- ;; 1. xxxxx
- ;; xxxxx
- ;;
- ("[0-9]+\\.[ \t]" bullet)
- ;;
- ;; 2.1.3 xxxxx xx x xx x
- ;; xxx
- ;;
- ("[0-9]+\\(\\.[0-9]+\\)+[ \t]" bullet)
- ;;
- ;; a. xxxxxx xx
- ;; xxx xxx
- ;;
- ("[A-Za-z]\\.[ \t]" bullet)
- ;;
- ;; 1) xxxx x xx x xx or (1) xx xx x x xx xx
- ;; xx xx xxxx xxx xx x x xx x
- ;;
- ("(?[0-9]+)[ \t]" bullet)
- ;;
- ;; a) xxxx x xx x xx or (a) xx xx x x xx xx
- ;; xx xx xxxx xxx xx x x xx x
- ;;
- ("(?[A-Za-z])[ \t]" bullet)
- ;;
- ;; 2a. xx x xxx x x xxx
- ;; xxx xx x xx x
- ;;
- ("[0-9]+[A-Za-z]\\.[ \t]" bullet)
- ;;
- ;; 1a) xxxx x xx x xx or (1a) xx xx x x xx xx
- ;; xx xx xxxx xxx xx x x xx x
- ;;
- ("(?[0-9]+[A-Za-z])[ \t]" bullet)
- ;;
- ;; - xx xxx xxxx or * xx xx x xxx xxx
- ;; xxx xx xx x xxx x xx x x x
- ;;
- ("[-~*+]+[ \t]" bullet)
- ;;
- ;; o xx xxx xxxx xx x xx xxx x xxx xx x xxx
- ;; xxx xx xx
- ;;
- ("o[ \t]" bullet)
- ;; don't touch
- ("[ \t]+" space)
- ("$" end-of-line)
- )
- "Table of tokens filladapt knows about.
-Format is
-
- ((REGEXP SYM) ...)
-
-filladapt uses this table to build a tokenized representation of
-the beginning of the current line. Each REGEXP is matched
-against the beginning of the line until a match is found.
-Matching is done case-sensitively. The corresponding SYM is
-added to the list, point is moved to (match-end 0) and the
-process is repeated. The process ends when there is no REGEXP in
-the table that matches what is at point."
- :type '(repeat (list regexp symbol)))
-
-(defcustom filladapt-not-token-table
- '(
- "[Ee]\\.g\\.[ \t,]"
- "[Ii]\\.e\\.[ \t,]"
- ;; end-of-line isn't a token if whole line is empty
- "^$"
- )
- "List of regexps that can never be a token.
-Before trying the regular expressions in `filladapt-token-table',
-the regexps in this list are tried. If any regexp in this list
-matches what is at point then the token generator gives up and
-doesn't try any of the regexps in `filladapt-token-table'.
-
-Regexp matching is done case-sensitively."
- :type '(repeat regexp))
-
-(defcustom filladapt-token-match-table
- '(
- (citation-> citation->)
- (supercite-citation supercite-citation)
- (lisp-comment lisp-comment)
- (sh-comment sh-comment)
- (postscript-comment postscript-comment)
- (c++-comment c++-comment)
- (texinfo-comment texinfo-comment)
- (bullet)
- (space bullet space)
- (beginning-of-line beginning-of-line)
- )
- "Table describing what tokens a certain token will match.
-
-To decide whether a line belongs in the current paragraph,
-filladapt creates a token list for the fill prefix of both lines.
-Tokens and the columns where tokens end are compared. This table
-specifies what a certain token will match.
-
-Table format is
-
- (SYM [SYM1 [SYM2 ...]])
-
-The first symbol SYM is the token, subsequent symbols are the
-tokens that SYM will match."
- :type '(repeat (repeat symbol)))
-
-(defcustom filladapt-token-match-many-table
- '(
- space
- )
- "List of tokens that can match multiple tokens.
-If one of these tokens appears in a token list, it will eat all
-matching tokens in a token list being matched against it until it
-encounters a token that doesn't match or a token that ends on
-a greater column number."
- :type '(repeat symbol))
-
-(defcustom filladapt-token-paragraph-start-table
- '(
- bullet
- )
- "List of tokens that indicate the start of a paragraph.
-If parsing a line generates a token list containing one of
-these tokens, then the line is considered to be the start of a
-paragraph."
- :type '(repeat symbol))
-
-(defcustom filladapt-token-conversion-table
- '(
- (citation-> . exact)
- (supercite-citation . exact)
- (lisp-comment . exact)
- (sh-comment . exact)
- (postscript-comment . exact)
- (c++-comment . exact)
- (texinfo-comment . exact)
- (bullet . spaces)
- (space . exact)
- (end-of-line . exact)
- )
- "Table that specifies how to convert a token into a fill prefix.
-Table format is
-
- ((SYM . HOWTO) ...)
-
-SYM is the symbol naming the token to be converted.
-HOWTO specifies how to do the conversion.
- `exact' means copy the token's string directly into the fill prefix.
- `spaces' means convert all characters in the token string that are
- not a TAB or a space into spaces and copy the resulting string into
- the fill prefix."
- :type '(repeat (cons symbol (choice (const exact)
- (const spaces)))))
-
-(defcustom filladapt-token-match-empty '(beginning-of-line end-of-line)
- "List of tokens that may match the empty string.
-Normally a token is ignored if it matches the empty string. This list
-contains the tokens that should be excluded from that rule."
- :type '(repeat symbol))
-
-(defcustom filladapt-fill-paragraph-post-hook nil
- "Hooks run after filladapt runs `fill-paragraph'."
- :type 'hook)
-
-(defvar filladapt--inside-filladapt nil
- "Non-nil if the filladapt version of a fill function executing.
-Currently this is only checked by the filladapt version of
-`fill-region-as-paragraph' to avoid this infinite recursion:
-
- fill-region-as-paragraph -> fill-paragraph -> fill-region-as-paragraph ...")
-
-(defvar filladapt-debug nil
- "Non-nil means filladapt debugging is enabled.
-Use the `filladapt-debug' function to turn on debugging.
-
-With debugging enabled, filladapt will
-
- a. display the proposed indentation with the tokens highlighted
- using `filladapt-debug-indentation-face-1' and
- `filladapt-debug-indentation-face-2'.
- b. display the current paragraph using the face specified by
- `filladapt-debug-paragraph-face'.")
-
-;; (if filladapt-debug
-;; (add-hook 'post-command-hook #'filladapt-display-debug-info-maybe))
-
-(defvar filladapt-debug-indentation-face-1 'highlight
- "Face used to display the indentation when debugging is enabled.")
-
-(defvar filladapt-debug-indentation-face-2 'secondary-selection
- "Another face used to display the indentation when debugging is enabled.")
-
-(defvar filladapt-debug-paragraph-face 'bold
- "Face used to display the current paragraph when debugging is enabled.")
-
-(defvar filladapt-debug-indentation-extents nil)
-(make-variable-buffer-local 'filladapt-debug-indentation-extents)
-(defvar filladapt-debug-paragraph-extent nil)
-(make-variable-buffer-local 'filladapt-debug-paragraph-extent)
-
-;; kludge city, see references in code.
-(defvar filladapt-old-line-prefix)
-
-(advice-add 'do-auto-fill :around #'filladapt--do-auto-fill)
-(defun filladapt--do-auto-fill (orig-fun &rest args)
- "Overloading for `filladapt-mode'."
- (catch 'done
- (if (and filladapt-mode (null fill-prefix))
- (save-restriction
- (let ((paragraph-ignore-fill-prefix nil)
- ;; if the user wanted this stuff, they probably
- ;; wouldn't be using filladapt-mode.
- (adaptive-fill-mode nil)
- (adaptive-fill-regexp nil)
- ;; need this or Emacs 19 ignores fill-prefix when
- ;; inside a comment.
- (comment-multi-line t)
- (filladapt--inside-filladapt t)
- fill-prefix retval)
- (if (filladapt-adapt nil nil)
- (progn
- (setq retval (apply orig-fun args))
- (throw 'done retval))))))
- (apply orig-fun args)))
-
-(defun filladapt--fill-paragraph (orig-fun &optional arg &rest args)
- "Overloading for `filladapt-mode'."
- (let ((filladapt--inside-filladapt t))
- (catch 'done
- (if (and filladapt-mode (null fill-prefix))
- (save-restriction
- (let ((paragraph-ignore-fill-prefix nil)
- ;; if the user wanted this stuff, they probably
- ;; wouldn't be using filladapt-mode.
- (adaptive-fill-mode nil)
- (adaptive-fill-regexp nil)
- ;; need this or Emacs 19 ignores fill-prefix when
- ;; inside a comment.
- (comment-multi-line t)
- fill-prefix retval)
- (if (filladapt-adapt t nil)
- (progn
- (if filladapt-fill-column-tolerance
- (let* ((low (- fill-column
- filladapt-fill-column-backward-fuzz))
- (high (+ fill-column
- filladapt-fill-column-forward-fuzz))
- (old-fill-column fill-column)
- (fill-column fill-column)
- (lim (- high low))
- (done nil)
- (sign 1)
- (delta 0))
- (while (not done)
- (setq retval (apply orig-fun arg args))
- (if (filladapt-paragraph-within-fill-tolerance)
- (setq done 'success)
- (setq delta (1+ delta)
- sign (* sign -1)
- fill-column (+ fill-column (* delta sign)))
- (while (and (<= delta lim)
- (or (< fill-column low)
- (> fill-column high)))
- (setq delta (1+ delta)
- sign (* sign -1)
- fill-column (+ fill-column
- (* delta sign))))
- (setq done (> delta lim))))
- ;; if the paragraph lines never fell
- ;; within the tolerances, refill using
- ;; the old fill-column.
- (if (not (eq done 'success))
- (let ((fill-column old-fill-column))
- (setq retval (apply orig-fun arg args)))))
- (setq retval (apply orig-fun arg args)))
- (run-hooks 'filladapt-fill-paragraph-post-hook)
- (throw 'done retval))))))
- ;; filladapt-adapt failed, so do fill-paragraph normally.
- (apply orig-fun arg args))))
-
-(advice-add 'fill-paragraph :around #'filladapt--fill-paragraph)
-(advice-add 'lisp-fill-paragraph :around #'filladapt--fill-paragraph)
-
-(advice-add 'fill-region-as-paragraph :around
- #'filladapt--fill-region-as-paragraph)
-(defun filladapt--fill-region-as-paragraph (orig-fun beg end &optional justify
- &rest args)
- "Overloading for `filladapt-mode'."
- (if (and filladapt-mode (not filladapt--inside-filladapt))
- (save-restriction
- (narrow-to-region beg end)
- (let ((filladapt--inside-filladapt t)
- line-start last-token)
- (goto-char beg)
- (while (equal (char-after (point)) ?\n)
- (delete-char 1))
- (end-of-line)
- (while (zerop (forward-line))
- (if (setq last-token
- (car (last (filladapt-parse-prefixes))))
- (progn
- (setq line-start (point))
- (move-to-column (nth 1 last-token))
- (delete-region line-start (point))))
- ;; Dance...
- ;;
- ;; Do this instead of (delete-char -1) to keep
- ;; markers on the correct side of the whitespace.
- (goto-char (1- (point)))
- (insert " ")
- (delete-char 1)
-
- (end-of-line))
- (goto-char beg)
- (fill-paragraph justify))
- ;; In XEmacs 19.12 and Emacs 18.59 fill-region relies on
- ;; fill-region-as-paragraph to do this. If we don't do
- ;; it, fill-region will spin in an endless loop.
- (goto-char (point-max)))
- (apply orig-fun beg end justify args)))
-
-(advice-add 'fill-region :around #'filladapt--fill-region)
-(defun filladapt--fill-region (orig-fun beg end &optional justify &rest args)
- "Overloading for `filladapt-mode'."
- (if (and filladapt-mode (not filladapt--inside-filladapt))
- (save-restriction
- (narrow-to-region beg end)
- (let ((filladapt--inside-filladapt t)
- start)
- (goto-char beg)
- (while (not (eobp))
- (setq start (point))
- (while (and (not (eobp)) (not (filladapt-parse-prefixes)))
- (forward-line 1))
- (if (not (equal start (point)))
- (progn
- (save-restriction
- (narrow-to-region start (point))
- (apply #'fill-region start (point) justify args)
- (goto-char (point-max)))
- (if (and (not (bolp)) (not (eobp)))
- (forward-line 1))))
- (if (filladapt-parse-prefixes)
- (progn
- (save-restriction
- ;; for the clipping region
- (filladapt-adapt t t)
- (fill-paragraph justify)
- (goto-char (point-max)))
- (if (and (not (bolp)) (not (eobp)))
- (forward-line 1)))))))
- (apply orig-fun beg end justify args)))
-
-(defvar zmacs-region-stays) ; for XEmacs
-
-;;;###autoload
-(define-minor-mode filladapt-mode
- "Toggle Filladapt minor mode.
-With arg, turn Filladapt mode on iff arg is positive. When
-Filladapt mode is enabled, auto-fill-mode and the fill-paragraph
-command are both smarter about guessing a proper fill-prefix and
-finding paragraph boundaries when bulleted and indented lines and
-paragraphs are used."
- :lighter filladapt-mode-line-string
- ;; don't deactivate the region.
- (setq zmacs-region-stays t))
-
-(define-obsolete-function-alias 'turn-on-filladapt-mode #'filladapt-mode "")
-
-(defun turn-off-filladapt-mode ()
- "Unconditionally turn off Filladapt mode in the current buffer."
- (filladapt-mode -1))
-
-(defun filladapt-paragraph-start (list)
- "Return non-nil if LIST contains a paragraph starting token.
-LIST should be a token list as returned by `filladapt-parse-prefixes'."
- (catch 'done
- (while list
- (if (memq (car (car list)) filladapt-token-paragraph-start-table)
- (throw 'done t))
- (setq list (cdr list)))))
-
-(defun filladapt-parse-prefixes ()
- "Parse all the tokens after point and return a list of them.
-The tokens regular expressions are specified in
-`filladapt-token-table'. The list returned is of this form
-
- ((SYM COL STRING) ...)
-
-SYM is a token symbol as found in `filladapt-token-table'.
-COL is the column at which the token ended.
-STRING is the token's text."
- (save-excursion
- (let ((token-list nil)
- (done nil)
- (old-point (point))
- (case-fold-search nil)
- token-table not-token-table moved)
- (catch 'done
- (while (not done)
- (setq not-token-table filladapt-not-token-table)
- (while not-token-table
- (if (looking-at (car not-token-table))
- (throw 'done t))
- (setq not-token-table (cdr not-token-table)))
- (setq token-table filladapt-token-table
- done t)
- (while token-table
- (if (or (null (looking-at (car (car token-table))))
- (and (not (memq (car (cdr (car token-table)))
- filladapt-token-match-empty))
- (eq (match-beginning 0) (match-end 0))))
- (setq token-table (cdr token-table))
- (goto-char (match-end 0))
- (setq token-list (cons (list (nth 1 (car token-table))
- (current-column)
- (buffer-substring
- (match-beginning 0)
- (match-end 0)))
- token-list)
- moved (not (eq (point) old-point))
- token-table (if moved nil (cdr token-table))
- done (not moved)
- old-point (point))))))
- (nreverse token-list))))
-
-(defun filladapt-tokens-match-p (list1 list2)
- "Compare two token lists and return non-nil if they match, nil otherwise.
-The lists are walked through in lockstep, comparing tokens.
-
-When two tokens A and B are compared, they are considered to
-match if
-
- 1. A appears in B's list of matching tokens or
- B appears in A's list of matching tokens
-and
- 2. A and B both end at the same column
- or
- A can match multiple tokens and ends at a column > than B
- or
- B can match multiple tokens and ends at a column > than A
-
-In the case where the end columns differ the list pointer for the
-token with the greater end column is not moved forward, which
-allows its current token to be matched against the next token in
-the other list in the next iteration of the matching loop.
-
-All tokens must be matched in order for the lists to be considered
-matching."
- (let ((matched t)
- (done nil))
- (while (and (not done) list1 list2)
- (let* ((token1 (car (car list1)))
- (token1-matches-many-p
- (memq token1 filladapt-token-match-many-table))
- (token1-matches (cdr (assq token1 filladapt-token-match-table)))
- (token1-endcol (nth 1 (car list1)))
- (token2 (car (car list2)))
- (token2-matches-many-p
- (memq token2 filladapt-token-match-many-table))
- (token2-matches (cdr (assq token2 filladapt-token-match-table)))
- (token2-endcol (nth 1 (car list2)))
- (tokens-match (or (memq token1 token2-matches)
- (memq token2 token1-matches))))
- (cond ((not tokens-match)
- (setq matched nil
- done t))
- ((and token1-matches-many-p token2-matches-many-p)
- (cond ((= token1-endcol token2-endcol)
- (setq list1 (cdr list1)
- list2 (cdr list2)))
- ((< token1-endcol token2-endcol)
- (setq list1 (cdr list1)))
- (t
- (setq list2 (cdr list2)))))
- (token1-matches-many-p
- (cond ((= token1-endcol token2-endcol)
- (setq list1 (cdr list1)
- list2 (cdr list2)))
- ((< token1-endcol token2-endcol)
- (setq matched nil
- done t))
- (t
- (setq list2 (cdr list2)))))
- (token2-matches-many-p
- (cond ((= token1-endcol token2-endcol)
- (setq list1 (cdr list1)
- list2 (cdr list2)))
- ((< token2-endcol token1-endcol)
- (setq matched nil
- done t))
- (t
- (setq list1 (cdr list1)))))
- ((= token1-endcol token2-endcol)
- (setq list1 (cdr list1)
- list2 (cdr list2)))
- (t
- (setq matched nil
- done t)))))
- (and matched (null list1) (null list2)) ))
-
-(defun filladapt-make-fill-prefix (list)
- "Build a `fill-prefix' for a token LIST.
-`filladapt-token-conversion-table' specifies how this is done."
- (let ((prefix-list nil)
- (conversion-spec nil))
- (while list
- (setq conversion-spec (cdr (assq (car (car list))
- filladapt-token-conversion-table)))
- (cond ((eq conversion-spec 'spaces)
- (setq prefix-list
- (cons
- (filladapt-convert-to-spaces (nth 2 (car list)))
- prefix-list)))
- ((eq conversion-spec 'exact)
- (setq prefix-list
- (cons
- (nth 2 (car list))
- prefix-list))))
- (setq list (cdr list)))
- (apply #'concat (nreverse prefix-list))))
-
-(defun filladapt-paragraph-within-fill-tolerance ()
- (catch 'done
- (save-excursion
- (let ((low (- fill-column filladapt-fill-column-tolerance))
- (shortline nil))
- (goto-char (point-min))
- (while (not (eobp))
- (if shortline
- (throw 'done nil)
- (end-of-line)
- (setq shortline (< (current-column) low))
- (forward-line 1)))
- t ))))
-
-(defun filladapt-convert-to-spaces (string)
- "Return a copy of STRING, with all non-tabs and non-space changed to spaces."
- (let ((space-list '(?\ ?\t))
- (space ?\ ))
- (setq string (copy-sequence string))
- (dotimes (i (length string))
- (if (not (memq (aref string i) space-list))
- (aset string i space)))
- string ))
-
-(defun filladapt-adapt (paragraph debugging)
- "Set `fill-prefix' based on the contents of the current line.
-
-If the first arg PARAGRAPH is non-nil, also set a clipping region
-around the current paragraph.
-
-If the second arg DEBUGGING is non-nil, don't do the kludge that's
-necessary to make certain paragraph fills work properly."
- (save-excursion
- (beginning-of-line)
- (let ((token-list (filladapt-parse-prefixes))
- curr-list done)
- (if (null token-list)
- nil
- (setq fill-prefix (filladapt-make-fill-prefix token-list))
- (if paragraph
- (let (beg end)
- (if (filladapt-paragraph-start token-list)
- (setq beg (point))
- (save-excursion
- (setq done nil)
- (while (not done)
- (cond ((not (= 0 (forward-line -1)))
- (setq done t
- beg (point)))
- ((not (filladapt-tokens-match-p
- token-list
- (setq curr-list (filladapt-parse-prefixes))))
- (forward-line 1)
- (setq done t
- beg (point)))
- ((filladapt-paragraph-start curr-list)
- (setq done t
- beg (point)))))))
- (save-excursion
- (setq done nil)
- (while (not done)
- (cond ((not (= 0 (progn (end-of-line) (forward-line 1))))
- (setq done t
- end (point)))
- ((not (filladapt-tokens-match-p
- token-list
- (setq curr-list (filladapt-parse-prefixes))))
- (setq done t
- end (point)))
- ((filladapt-paragraph-start curr-list)
- (setq done t
- end (point))))))
- (narrow-to-region beg end)
- ;; Multiple spaces after the bullet at the start of
- ;; a hanging list paragraph get squashed by
- ;; fill-paragraph. We kludge around this by
- ;; replacing the line prefix with the fill-prefix
- ;; used by the rest of the lines in the paragraph.
- ;; fill-paragraph will not alter the fill prefix so
- ;; we win. The post hook restores the old line prefix
- ;; after fill-paragraph has been called.
- (if (and paragraph (not debugging))
- (let (col)
- (setq col (nth 1 (car (last token-list))))
- (goto-char (point-min))
- (move-to-column col)
- (setq filladapt-old-line-prefix
- (buffer-substring (point-min) (point)))
- (delete-region (point-min) (point))
- (insert fill-prefix)
- (add-hook 'filladapt-fill-paragraph-post-hook
- #'filladapt-cleanup-kludge-at-point-min)))))
- t ))))
-
-(defun filladapt-cleanup-kludge-at-point-min ()
- "Cleanup the paragraph fill kludge.
-See `filladapt-adapt'."
- (save-excursion
- (goto-char (point-min))
- (insert filladapt-old-line-prefix)
- (delete-char (length fill-prefix))
- (remove-hook 'filladapt-fill-paragraph-post-hook
- #'filladapt-cleanup-kludge-at-point-min)))
-
-(defalias 'filladapt-delete-extent
- (if (featurep 'xemacs)
- 'delete-extent
- #'delete-overlay))
-
-(defalias 'filladapt-make-extent
- (if (featurep 'xemacs)
- 'make-extent
- #'make-overlay))
-
-(defalias 'filladapt-set-extent-endpoints
- (if (featurep 'xemacs)
- 'set-extent-endpoints
- #'move-overlay))
-
-(defalias 'filladapt-set-extent-property
- (if (featurep 'xemacs)
- 'set-extent-property
- #'overlay-put))
-
-(defun filladapt-debug ()
- "Toggle filladapt debugging on/off in the current buffer."
- ;; (interactive)
- (set (make-local-variable 'filladapt-debug) (not filladapt-debug))
- (if (null filladapt-debug)
- (progn
- (dolist (e filladapt-debug-indentation-extents)
- (filladapt-set-extent-endpoints e 1 1))
- (if filladapt-debug-paragraph-extent
- (progn
- (filladapt-delete-extent filladapt-debug-paragraph-extent)
- (setq filladapt-debug-paragraph-extent nil)))))
- (add-hook 'post-command-hook #'filladapt-display-debug-info-maybe))
-
-(defun filladapt-display-debug-info-maybe ()
- (cond ((null filladapt-debug) nil)
- (fill-prefix nil)
- (t
- (if (null filladapt-debug-paragraph-extent)
- (let ((e (filladapt-make-extent 1 1)))
- (filladapt-set-extent-property e 'detachable nil)
- (filladapt-set-extent-property e 'evaporate nil)
- (filladapt-set-extent-property e 'face
- filladapt-debug-paragraph-face)
- (setq filladapt-debug-paragraph-extent e)))
- (save-excursion
- (save-restriction
- (let ((ei-list filladapt-debug-indentation-extents)
- (ep filladapt-debug-paragraph-extent)
- (face filladapt-debug-indentation-face-1)
- fill-prefix token-list e)
- (if (null (filladapt-adapt t t))
- (progn
- (filladapt-set-extent-endpoints ep 1 1)
- (while ei-list
- (filladapt-set-extent-endpoints (car ei-list) 1 1)
- (setq ei-list (cdr ei-list))))
- (filladapt-set-extent-endpoints ep (point-min) (point-max))
- (beginning-of-line)
- (setq token-list (filladapt-parse-prefixes))
- (message "(%s)" (mapconcat (function
- (lambda (q) (symbol-name (car q))))
- token-list
- " "))
- (while token-list
- (if ei-list
- (setq e (car ei-list)
- ei-list (cdr ei-list))
- (setq e (filladapt-make-extent 1 1))
- (filladapt-set-extent-property e 'detachable nil)
- (filladapt-set-extent-property e 'evaporate nil)
- (push e filladapt-debug-indentation-extents))
- (filladapt-set-extent-property e 'face face)
- (filladapt-set-extent-endpoints e (point)
- (progn
- (move-to-column
- (nth 1
- (car token-list)))
- (point)))
- (setq face (if (eq face filladapt-debug-indentation-face-1)
- filladapt-debug-indentation-face-2
- filladapt-debug-indentation-face-1))
- (setq token-list (cdr token-list)))
- (while ei-list
- (filladapt-set-extent-endpoints (car ei-list) 1 1)
- (setq ei-list (cdr ei-list))))))))))
-
-(provide 'filladapt)
-;;; filladapt.el ends here
diff --git a/packages/flylisp/flylisp.el b/packages/flylisp/flylisp.el
deleted file mode 100644
index 647a543..0000000
--- a/packages/flylisp/flylisp.el
+++ /dev/null
@@ -1,506 +0,0 @@
-;;; flylisp.el --- Color unbalanced parentheses and parentheses inconsistent
with indentation -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
-
-;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
-;; Version: 0.2
-;; Package-Requires: ((emacs "24.1") (cl-lib "0.4"))
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Colors mismatched open parentheses with fl-mismatched-face, red by
-;; default. Works reliably after Emacs 24.3, in which bug 16247 is
-;; fixed.
-;;
-;; Also colors open and close parentheses which are inconsistent with
-;; the indentation of lines between them with fl-inconsistent-face,
-;; orange by default. This is useful for the Lisp programmer who
-;; infers a close paren's location from the open paren and
-;; indentation. The coloring serves as a warning that the indentation
-;; misleads about where the close paren is. It may also help to
-;; localize the mistake, whether due to a misindented line or a
-;; misplaced paren.
-;;
-;; As an example, consider:
-;;
-;; (aaa (bbb "word-a
-;; word-b" (ccc 1
-;; 2)
-;; fff))
-;;
-;; (aaa ...) and (ccc ...) are consistent, so are not colored.
-;; (bbb ...) is inconsistent because the indentation of fff is
-;; inconsistent with the actual location of the close paren. The open
-;; and close paren are thus colored with the fl-inconsistent-face.
-;; This example also shows that multi line strings don't cause an
-;; inconsistency.
-;;
-;; Currently, the package only detects close parens that are after the
-;; place indentation would predict. A planned feature is to also
-;; indicate when the close paren is before.
-;;
-;; Also planned is to color mismatched close parens.
-
-;;; Code:
-
-;; TODO: Algorithm doesn't account for close paren which is too soon.
-;;
-;; (abc
-;; (def))
-;; (ghi)
-;;
-;; (abc ...) are inconsistent parens because (ghi) is indented too far
-
-;; TODO: implement mismatched close parens
-
-;; TODO: Write tests:
-;;
-;; ;; Expect (abc ...) is consistent, (def ...) is inconsistent:
-;; (abc a-symbol (a-func-call "word-a
-;; word-b" (def ghi
-;; jkl)
-;;
-;; ;; Expect (when ...) is inconsistent:
-;; (when (and t
-;; nil))
-;; ;; After change, expect (when ...) is consistent and last paren
mismatched:
-;; (when (and t)
-;; nil))
-;;
-;; Given (a ...) inconsistent, change to (a ...(), and verify close
-;; paren is consistent.
-
-(require 'cl-lib)
-(require 'jit-lock)
-
-(defgroup flylisp nil
- "Color unbalanced parentheses and parentheses inconsistent with indentation."
- :prefix "flylisp-"
- :group 'paren-matching)
-
-(defgroup flylisp-faces nil
- "Faces for flylisp package. "
- :group 'flylisp
- :group 'faces)
-
-(defface fl-inconsistent-face
- '((((class color) (background light))
- :foreground "dark orange")
- (((class color) (background dark))
- :foreground "orange"))
- "Face applied to matching open and close parens whose placement
-is inconsistent with indentation."
- :group 'flylisp-faces)
-
-(defface fl-mismatched-face
- '((((class color) (background light))
- :foreground "dark red")
- (((class color) (background dark))
- :foreground "red"))
- "Face applied to a paren who has no match."
- :group 'flylisp-faces)
-
-;; An open paren and algorithmic data about it.
-;;
-;; position is the position in the buffer of the open paren
-;;
-;; close is one of:
-;; - nil if unknown
-;; - the position before the matching close paren
-;; - the symbol 'mismatched if no matching close paren exists
-;;
-;; column is the displayed column of the open paren in its logical
-;; line of the buffer
-;;
-;; inconsistent is whether the open paren's close paren is
-;; inconsistent with the indentation within the list defined by the
-;; parens. It is one of:
-;; - nil if unknown or consistent
-;; - an integer offset from the open position to the position of the
-;; first inconsistency. This offset is also cached in the open
-;; paren text properties for performance.
-(cl-defstruct fl--Open position close column inconsistent)
-
-(defsubst fl--colorize-inconsistent (open-obj)
- "Colorize the fl--Open OPEN-OBJ as inconsistent."
- (add-text-properties (fl--Open-position open-obj)
- (1+ (fl--Open-position open-obj))
- `(fl-inconsistency
- ,(fl--Open-inconsistent open-obj)
- font-lock-face
- fl-inconsistent-face
- rear-nonsticky
- t))
- (add-text-properties (fl--Open-close open-obj)
- (1+ (fl--Open-close open-obj))
- `(font-lock-face
- fl-inconsistent-face
- rear-nonsticky
- t)))
-
-(defsubst fl--line-check-opens (open-stack)
- "Check fl--Open objects of the OPEN-STACK list for
-consistency.
-
-The inconsistent==nil elements of OPEN-STACK must have columns
-that are strictly decreasing moving towards the tail (a necessary
-but not sufficient condition for being consistent). The
-implementation optimizes on this assumption.
-
-Call with point on the line being checked; puts point on the next
-line or EOB."
- (let ((indent-pos (progn (back-to-indentation)
- (point)))
- (indent-column (current-column))
- (line-end (progn (end-of-line)
- (point))))
- ;; Assess open-objs against indent-column
- (unless (eq indent-pos line-end) ; Skip whitespace lines
- ;; Since we're only interested in marking Opens inconsistent,
- ;; the open-stack's documented property allows the iteration to
- ;; stop at the first inconsistent==nil Open with small enough
- ;; column.
- (while (and open-stack
- (or (fl--Open-inconsistent (car open-stack))
- (<= indent-column
- (fl--Open-column (car open-stack)))))
- ;; Check fl--Open-inconsistent to avoid excessive
- ;; syntax-ppss when there's a lot of bad
- ;; indentation.
- (unless (or (fl--Open-inconsistent (car open-stack))
- ;; Multi line strings don't cause inconsistency
- (nth 3 (syntax-ppss indent-pos)))
- (setf (fl--Open-inconsistent (car open-stack))
- (- indent-pos (fl--Open-position (car open-stack)))))
- (pop open-stack)))
- ;; Go to next line. Since we already know line-end, use it
- ;; instead of rescanning the line
- ;;
- ;; goto-char tolerates going beyond EOB
- (goto-char (1+ line-end))))
-
-(defsubst fl--region-check-opens (downward-objs
- upward-objs)
- "Check inputted parens in a region for inconsistency, first
-going down in sexp depth then up per the DOWNWARD-OBJS and
-UPWARD-OBJS.
-
-Point must be at the start of the region to process and will end
-up near the end.
-
-DOWNWARD-OBJS is a list of fl--Open objects. Each must be a
-parent of the next in the list.
-
-UPWARD-OBJS is a list of fl--Open objects. Each must be a child
-of the next in the list."
- (while downward-objs
- (fl--line-check-opens upward-objs)
- (while (and downward-objs
- (< (fl--Open-position (car downward-objs))
- (point)))
- (push (pop downward-objs)
- upward-objs)))
- (while (and upward-objs
- (number-or-marker-p (fl--Open-close (car upward-objs))))
- (fl--line-check-opens upward-objs)
- (while (and upward-objs
- (number-or-marker-p (fl--Open-close (car upward-objs)))
- (< (fl--Open-close (car upward-objs))
- (point)))
- (pop upward-objs))))
-
-(defsubst fl--set-closes (open-obj-list)
- "Sets the close attribute of each element of OPEN-OBJ-LIST.
-
-OPEN-OBJ-LIST is a list of fl--Open. Each must be a child of the
-next in the list. This is used to scan-lists efficiently."
- ;; Note: Because fl--Open-position values come from (nth 9
- ;; (syntax-ppss)), we know they are not inside a string or comment.
- ;; Thus buf-pos inits to a valid position to start scan-lists from.
- (let ((buf-pos (and open-obj-list
- ;; scan_lists tolerates buf-pos past EOB
- (1+ (fl--Open-position (car open-obj-list))))))
- (dolist (open-i open-obj-list)
- (when buf-pos
- (setq buf-pos (condition-case nil
- (scan-lists buf-pos 1 1)
- (scan-error nil))))
- (setf (fl--Open-close open-i) (if buf-pos
- (1- buf-pos)
- 'mismatched)))))
-
-(defun fl-propertize-region (start end)
- (save-excursion
- ;; In order to correctly remove faces from parens that changed
- ;; from multiline to uniline, we clear all parens in the JIT lock
- ;; region to start with.
- (fl-unpropertize-region start end)
- (let* ((timing-info (list (current-time)))
- (start-ps (syntax-ppss start))
- ;; Open positions, outer to inner
- (ps-opens (nth 9 start-ps))
- ;; fl--Open objects, positions inner to outer
- (open-objs nil))
- (push (current-time) timing-info)
- ;; Process the broader region spanned by ps-opens. Consider only
- ;; the ps-opens, not their children which lie entirely outside
- ;; the JIT lock region.
- ;;
- ;; We mostly avoid further sexp parsing in the broader region,
- ;; except to check for a multiline string just before setting
- ;; inconsistent.
- (dolist (ps-open-i ps-opens)
- (push (make-fl--Open :position
- ps-open-i
- :column
- (progn
- (goto-char ps-open-i)
- (current-column)))
- open-objs))
- (push (current-time) timing-info)
- ;; Filter out parens which don't need consideration outside the
- ;; JIT lock region. The ones that do are currently fontified as
- ;; inconsistent, and could become consistent if all its enclosed
- ;; lines are checked.
- ;;
- ;; In addition to filtering, this passage sets close positions
- ;; and may reapply the inconsistency-face to some close parens
- ;; which were just cleared.
- (setq open-objs
- (let* ((objs-head (cons nil open-objs))
- (prev-open objs-head)
- (open-i (cdr objs-head))
- ;; Whether we've called fl--set-closes
- ;;
- ;; fl--set-closes is fairly expensive when near the
- ;; beginning of a long Lisp function. We can avoid
- ;; calling it if all open-objs are propertized as
- ;; consistent or mismatched.
- (closes-set nil))
- (while open-i
- (let* ((inconsistency-offset
- (get-text-property (fl--Open-position (car open-i))
- 'fl-inconsistency))
- (inconsistency-pos
- (and inconsistency-offset
- (+ (fl--Open-position (car open-i))
- inconsistency-offset))))
- (if (or (not inconsistency-pos)
- ;; Always nil so as "or" evaluation continues
- (unless closes-set
- ;; Lazy one-time call
- (fl--set-closes open-objs)
- (not (setq closes-set t)))
- ;; Spot check using the cached offset to
- ;; possibly avoid a complete check in
- ;; fl--region-check-opens for open-i.
- ;;
- ;; Because of buffer changes,
- ;; inconsistency-pos is not necessarily
- ;; the original. Just do a valid check.
- (and (< (fl--Open-position (car open-i))
- inconsistency-pos)
- (number-or-marker-p (fl--Open-close (car
open-i)))
- (<= inconsistency-pos
- (fl--Open-close (car open-i)))
- (progn
- (goto-char inconsistency-pos)
- (fl--line-check-opens (list (car open-i)))
- (when (fl--Open-inconsistent (car open-i))
- (fl--colorize-inconsistent (car open-i))
- t))))
- ;; Remove (car open-i) from list
- (setcdr prev-open (cdr open-i))
- (pop prev-open))
- (pop open-i)))
- (cdr objs-head)))
- (push (current-time) timing-info)
- (when open-objs
- ;; Check lists beginning before JIT lock's region (could
- ;; scan to after JIT lock's region)
- (let ((open-objs-reversed (reverse open-objs)))
- (goto-char (fl--Open-position (car open-objs-reversed)))
- (fl--region-check-opens open-objs-reversed
- nil)))
- (push (current-time) timing-info)
- (goto-char start)
- ;; Process within the inputted JIT lock region
- (let* (;; Sparse vector of open paren data, indexed by position
- ;; in buffer minus start. This benchmarked better than
- ;; keeping a stack of fl--Open objects updated from the
- ;; parse states of syntax-ppss.
- (open-paren-table (make-vector (- end start) nil)))
- (while (< (point) end)
- (let ((indent-pos (progn (back-to-indentation)
- (point)))
- ;; Column at which text starts on the line
- (indent-column (current-column))
- (line-ppss (syntax-ppss))
- (line-end (progn (end-of-line)
- (point))))
- ;; Skip whitespace only lines and lines beginning inside
- ;; string
- (unless (or (eq indent-pos line-end)
- (nth 3 line-ppss))
- ;; Iterate over list of unclosed open parens
- (dolist (open-pos (nth 9 line-ppss))
- ;; Skip the already processed ones outside the region
- (when (<= start open-pos)
- (let ((open-obj (or (aref open-paren-table
- (- open-pos start))
- (progn
- (push (make-fl--Open
- :position open-pos
- :column (progn
- (goto-char open-pos)
- (current-column)))
- open-objs)
- (aset open-paren-table
- (- open-pos start)
- (car open-objs))))))
- (when (<= indent-column
- (fl--Open-column open-obj))
- (setf (fl--Open-inconsistent open-obj)
- (- indent-pos (fl--Open-position open-obj))))))))
- ;; Go to next line. Since we already know line-end, use it
- ;; instead of rescanning the line
- (goto-char (1+ line-end))))
- (push (current-time) timing-info)
- ;; Process parens beginning in the JIT lock region but extending after
- ;;
- ;; Note: the reason we don't filter fl--Open after the JIT
- ;; lock region, as we did for the region before it, is mostly
- ;; because of the directionality of redisplay from BOB to EOB.
- ;; If we allow subsequent fl-propertize-region to propertize
- ;; the open parens in the current JIT lock region, it wouldn't
- ;; show to the user because by then redisplay has finished
- ;; this JIT lock region. An additional consideration is that
- ;; the coloring of the open paren is of more interest than the
- ;; close paren.
- (let ((ps-opens (nth 9 (syntax-ppss end)))
- ;; Inner to outer going towards the tail
- (open-obj-list nil))
- (dolist (ps-open-i ps-opens)
- (when (<= start ps-open-i)
- (push (or (aref open-paren-table
- (- ps-open-i start))
- ;; Open parens on the last line of the JIT
- ;; lock region don't have a fl--Open object
- ;; created yet.
- (progn
- (push (make-fl--Open
- :position ps-open-i
- :column (progn
- (goto-char ps-open-i)
- (current-column)))
- open-objs)
- (aset open-paren-table
- (- ps-open-i start)
- (car open-objs))))
- open-obj-list)))
- (push (current-time) timing-info)
- (fl--set-closes open-obj-list)
- (push (current-time) timing-info)
- (goto-char end)
- (fl--region-check-opens nil open-obj-list))
- (push (current-time) timing-info)
- (dolist (open-i open-objs)
- ;; Set close position
- ;;
- ;; Note: We do it here instead of when it was made so as
- ;; some benefit from the fl--set-closes function's buffer
- ;; scanning optimization. The lists processed here are
- ;; opened and closed within JIT lock's region, so the less
- ;; efficient buffer scanning is not a big deal.
- (unless (fl--Open-close open-i)
- (setf (fl--Open-close open-i)
- (condition-case nil
- (1- (scan-lists (fl--Open-position open-i) 1 0))
- (scan-error 'mismatched))))
- ;; Apply the font color via text properties
- (with-silent-modifications
- (if (eq 'mismatched (fl--Open-close open-i))
- (add-text-properties (fl--Open-position open-i)
- (1+ (fl--Open-position open-i))
- `(font-lock-face
- fl-mismatched-face
- rear-nonsticky
- t))
- (if (fl--Open-inconsistent open-i)
- (fl--colorize-inconsistent open-i)
- (dolist (pos-i (list (fl--Open-position open-i)
- (fl--Open-close open-i)))
- (remove-text-properties pos-i
- (1+ pos-i)
- '(fl-inconsistency
- nil
- font-lock-face
- nil
- rear-nonsticky
- nil)))))))
- (push (current-time) timing-info)
- ;; (my-msg "fl-propertize-region start=%s end=%s timing: %s"
- ;; start end
- ;; (my-time-diffs (nreverse timing-info)))
- ))))
-
-(defun fl-unpropertize-region (start end)
- (goto-char start)
- ;; remove-text-properties errors if (1+ (point)) is past EOB, so
- ;; adjust end
- (let ((end (min (1- (point-max))
- end)))
- (while (< (point) end)
- (skip-syntax-forward "^()" end)
- (remove-text-properties (point)
- (1+ (point))
- '(fl-inconsistency nil
- font-lock-face nil
- rear-nonsticky nil))
- (forward-char 1))))
-
-(defvar jit-lock-start)
-
-(defsubst flylisp-extend-region-after-change (start _end _old-len)
- ;; It seems redisplay works its way from before start to after end,
- ;; so it's more important to expand the start in order to get
- ;; correct redisplays.
- (save-excursion
- (setq jit-lock-start
- (or (syntax-ppss-toplevel-pos (syntax-ppss start))
- start))))
-
-(define-minor-mode flylisp-mode
- "Color unbalanced parentheses and parentheses inconsistent with
- indentation."
- nil nil nil
- (if flylisp-mode
- (progn
- (jit-lock-register 'fl-propertize-region t)
- (add-hook 'jit-lock-after-change-extend-region-functions
- #'flylisp-extend-region-after-change
- nil
- t))
- (remove-hook 'jit-lock-after-change-extend-region-functions
- #'flylisp-extend-region-after-change
- t)
- (jit-lock-unregister 'fl-propertize-region)
- (save-excursion
- (fl-unpropertize-region (point-min) (point-max)))))
-
-(provide 'flylisp)
-
-;;; flylisp.el ends here
diff --git a/packages/frame-tabs/frame-tabs.el
b/packages/frame-tabs/frame-tabs.el
deleted file mode 100644
index 6f1e8ac..0000000
--- a/packages/frame-tabs/frame-tabs.el
+++ /dev/null
@@ -1,520 +0,0 @@
-;;; frame-tabs.el --- show buffer tabs in side window -*- lexical-binding:t
-*-
-
-;; Copyright (C) 2013-2018 Free Software Foundation, Inc.
-
-;; Author: Martin Rudalics <rudalics@gmx.at>
-;; Keywords: frames, tabs
-;; Version: 1.1
-
-;; frame-tabs.el is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; frame-tabs.el 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Minor mode to display buffer tabs in a side window on each frame.
-
-;; This mode shows, in a side window on each frame, tabs listing the
-;; names of all live buffers that have been displayed on that frame.
-;; Clicking on a tab with the left mouse button switches to the
-;; corresponding buffer in a window. Clicking on a tab with the right
-;; mouse button dismisses the buffer. See 'frame-tabs-map'.
-;; Alternatively, tabs can display an additional 'x' button which
-;; permits to dismiss buffers with the left mouse button. See
-;; 'frame-tabs-x' and 'frame-tabs-x-map'.
-
-;; Caveats: Many desirable features are either underdeveloped or
-;; simply don't work. Navigating tabs windows with the keyboard has
-;; not been implemented; neither has been displaying alternative items
-;; like tabs representing window configurations. You're welcome to
-;; expand existing and/or add new features at your like.
-
-;;; Code:
-(defgroup frame-tabs nil
- "Frame tabs."
- :version "26.1"
- :group 'convenience
- :group 'frames)
-
-;; Customizable faces
-(defface frame-tabs-buffer-tab
- '((t :inherit variable-pitch
- :box (:line-width 2 :color "grey72")
- :foreground "black"
- :background "grey84"))
- "Basic frame tabs buffer tab face.
-This face is used for buffer tabs and is inherited by all other
-frame tabs faces."
- :version "26.1"
- :group 'frame-tabs)
-
-(defface frame-tabs-selected-tab
- '((t :inherit frame-tabs-buffer-tab
- :background "pink"))
- "Frame tabs face for selected window's buffer tab.
-This is the face used for the tab corresponding to the buffer
-currently shown in the selected window."
- :version "26.1"
- :group 'frame-tabs)
-
-(defface frame-tabs-higlight-tab
- '((t :inherit frame-tabs-buffer-tab
- :foreground "white"
- :background "green3"))
- "Frame tabs face for highlighting buffer tabs.
-This is the face used when the mouse cursor hovers over a buffer
-tab."
- :version "26.1"
- :group 'frame-tabs)
-
-(defface frame-tabs-x-tab
- '((t :inherit frame-tabs-buffer-tab
- :bold t))
- "Frame tabs face for 'x' buttons."
- :version "26.1"
- :group 'frame-tabs)
-
-(defface frame-tabs-x-higlight-tab
- '((t :inherit frame-tabs-item-tab
- :foreground "white"
- :background "red3"))
- "Frame tabs face for highlighting 'x' buttons.
-This face is used when the mouse cursor hovers over an 'x'
-button."
- :version "26.1"
- :group 'frame-tabs)
-
-;; Options
-(defvar frame-tabs-mode)
-
-(defun frame-tabs--set-value (symbol value)
- "Helper function for customizing frame tabs."
- (set-default symbol value)
- (when frame-tabs-mode
- (frame-tabs-mode -1)
- (frame-tabs-mode 1)))
-
-(defcustom frame-tabs-side 'top
- "Side of frame where tabs windows are located.
-Choices are 'top' (the default), 'bottom', 'left' and 'right'."
- :type '(choice (const top)
- (const bottom)
- (const left)
- (const right))
- :initialize 'custom-initialize-default
- :set 'frame-tabs--set-value
- :version "26.1"
- :group 'frame-tabs)
-
-(defcustom frame-tabs-x nil
- "Non-nil means frame tabs show an 'x' button for each buffer tab.
-The 'x' button serves to dismiss the corresponding buffer in
-various ways."
- :type 'boolean
- :initialize 'custom-initialize-default
- :set 'frame-tabs--set-value
- :version "26.1"
- :group 'frame-tabs)
-
-(defcustom frame-tabs-min-size 1
- "Mimimum size of frame tabs windows.
-For tabs windows at the top or bottom of a frame this is their
-minimum number of lines. For tabs windows at the left or right
-of a frame this is their minimum number of columns.
-
-This value may be overridden when the major side window showing
-the frame tabs window contains other windows."
- :type 'integer
- :initialize 'custom-initialize-default
- :set 'frame-tabs--set-value
- :version "26.1"
- :group 'frame-tabs)
-
-(defcustom frame-tabs-max-size 6
- "Maximum size of frame tabs windows.
-For tabs windows at the top or bottom of a frame this is their
-maximum number of lines. For tabs windows at the left or right
-of a frame this is their maximum number of columns.
-
-This value may be overridden when the major side window showing
-the frame tabs window contains other windows."
- :type 'integer
- :initialize 'custom-initialize-default
- :set 'frame-tabs--set-value
- :version "26.1"
- :group 'frame-tabs)
-
-(defcustom frame-tabs-delay 0.0
- "Frame tabs update interval, in seconds.
-This is the time Emacs waits before updating frame tabs windows."
- :type 'float
- :initialize 'custom-initialize-default
- :set 'frame-tabs--set-value
- :version "26.1"
- :group 'frame-tabs)
-
-(defun frame-tabs-default-filter (buffer _frame)
- "Default filter function for frame tabs."
- (let ((name (buffer-name buffer)))
- (unless (eq (aref name 0) ?\s)
- name)))
-
-(defcustom frame-tabs-filter-function 'frame-tabs-default-filter
- "Filter function for frame tabs.
-This is a function that takes two arguments - a buffer and a
-frame. If this function returns nil, no tab will be shown for
-the buffer in the frame's tab window. Otherwise, this function
-must return a string and the frame's tabs window will display
-that string as the buffer's tab.
-
-The default excludes buffers whose name starts with a space."
- :type 'function
- :version "26.1"
- :group 'frame-tabs)
-
-(defun frame-tabs-default-buffer-list (frame)
- "Default frame tabs function for getting a buffer list for FRAME."
- (buffer-list frame))
-
-(defcustom frame-tabs-buffer-list 'frame-tabs-default-buffer-list
- "Function for returning a buffer list for frame tabs.
-This is a function that takes one argument - a frame - and
-returns a buffer list for that frame. The default is to call
-`buffer-list' for that frame which means to return the frame's
-local buffer list. Customizing this option allows, for example,
-to return the fundamental buffer list or a list of buffer in
-alphabetical order of their names instead."
- :type 'function
- :version "26.1"
- :group 'frame-tabs)
-
-;; Internal variables and functions
-(defvar frame-tabs-timer nil
- "Frame tabs idle timer.")
-
-(defvar frame-tabs-run nil
- "Non-nil while frame tabs runs its idle timer function.")
-
-(defvar frame-tabs-buffers nil
- "List of frame tabs buffers.")
-
-(defvar frame-tabs-map
- (let ((map (make-sparse-keymap)))
- ;; Buffer switching commands.
- (define-key map [down-mouse-1] 'frame-tabs-switch-to-buffer)
- (define-key map [mouse-1] 'ignore)
- (define-key map [C-down-mouse-1] 'frame-tabs-switch-to-buffer-other-window)
- (define-key map [C-mouse-1] 'ignore)
- (define-key map [M-down-mouse-1] 'frame-tabs-switch-to-buffer-other-frame)
- (define-key map [M-mouse-1] 'ignore)
- ;; Buffer dismissal commands.
- (define-key map [down-mouse-3] 'frame-tabs-bury-buffer)
- (define-key map [mouse-3] 'ignore)
- (define-key map [C-down-mouse-3] 'frame-tabs-replace-buffer)
- (define-key map [C-mouse-3] 'ignore)
- (define-key map [M-down-mouse-3] 'frame-tabs-kill-buffer)
- (define-key map [M-mouse-3] 'ignore)
- map)
- "Frame tabs keymap.")
-
-(defvar frame-tabs-x-map
- (let ((map (make-sparse-keymap)))
- (define-key map [down-mouse-1] 'frame-tabs-bury-buffer)
- (define-key map [mouse-1] 'ignore)
- (define-key map [C-down-mouse-1] 'frame-tabs-replace-buffer)
- (define-key map [C-mouse-1] 'ignore)
- (define-key map [M-down-mouse-1] 'frame-tabs-kill-buffer)
- (define-key map [M-mouse-1] 'ignore)
- map)
- "Frame tabs 'x' keymap.
-This keymap is used when frame tabs show an 'x' button via
-`frame-tabs-x'.")
-
-(defun frame-tabs--window (&optional frame)
- "Return or create a tabs window for FRAME.
-FRAME must be a live frame and defaults to the selected one."
- (setq frame (window-normalize-frame frame))
- (let ((window-resize-pixelwise t)
- (tabs-vertical (memq frame-tabs-side '(top bottom)))
- tabs-buffer tabs-window tabs-point tabs-selected)
- ;; `tabs-buffer' is the buffer showing tabs on FRAME and
- ;; `tabs-window' is its window.
- (unless (catch 'found
- (walk-window-tree
- (lambda (window)
- (let ((buffer (window-buffer window)))
- (when (memq buffer frame-tabs-buffers)
- (setq tabs-buffer buffer)
- (setq tabs-window window)
- (if (eq tabs-window (selected-window))
- (with-current-buffer tabs-buffer
- (setq tabs-selected
- (get-text-property (point) 'buffer)))
- (setq tabs-selected (window-buffer)))
- (throw 'found t))))))
- (setq tabs-buffer (generate-new-buffer " *tabs*"))
- (setq frame-tabs-buffers (cons tabs-buffer frame-tabs-buffers))
- ;; Set `tabs-selected' to the truly selected window.
- (setq tabs-selected (window-buffer))
- (with-current-buffer tabs-buffer
- ;; Make a tabs window.
- (setq tabs-window
- (display-buffer-in-side-window
- tabs-buffer `((side . ,frame-tabs-side)
- (,(if tabs-vertical 'window-width 'window-height)
- . ,frame-tabs-min-size))))))
- ;; Display tabs in the window.
- (when tabs-window
- (with-current-buffer tabs-buffer
- (setq mode-line-format nil)
- (setq header-line-format nil)
- (setq buffer-read-only nil)
- (erase-buffer)
- (dolist (buffer (funcall frame-tabs-buffer-list frame))
- (let ((name (funcall frame-tabs-filter-function buffer frame)))
- (when name
- (insert
- (propertize
- name
- 'buffer buffer
- 'keymap frame-tabs-map
- 'face (if (eq buffer tabs-selected)
- (progn
- (setq tabs-point (point))
- 'frame-tabs-selected-tab)
- 'frame-tabs-buffer-tab)
- 'mouse-face 'frame-tabs-higlight-tab))
- (when frame-tabs-x
- (insert
- (propertize
- "×" 'buffer buffer ; U-00D7
- ;; "⌧" 'buffer buffer ; U-2327
- 'keymap frame-tabs-x-map
- 'face 'frame-tabs-x-tab
- 'mouse-face 'frame-tabs-x-higlight-tab)))
- ;; We'd like to use "" (U-200B) instead of " " in the
- ;; following form but the display-engine word-wraps only at
- ;; spaces or tabs so use a display specification instead.
- ;; Note that we can't use :width either since it would make
- ;; the spaces of the last item on each line extend to the
- ;; end of that line.
- (insert
- (if tabs-vertical
- ;; ""
- (propertize " " 'display '(space . (:relative-width 0.1)))
- "\n")))))
- ;; Delete very last space or newline inserted.
- (when (memq (char-before) '(?\s ?\n)) (delete-char -1))
- (when tabs-vertical
- ;; Make sure word wrapping takes care of buffer tabs.
- (set (make-local-variable 'truncate-lines) nil)
- (set (make-local-variable 'truncate-partial-width-windows) nil)
- (set (make-local-variable 'word-wrap) t))
- ;; Handle window.
- (set-window-margins tabs-window 0 0)
- (set-window-fringes tabs-window 0 0)
- (set-window-scroll-bars tabs-window 0)
- (setq window-size-fixed nil)
- ;; We have bound 'window-resize-pixelwise' to t to make sure
- ;; the following call handles the boxed face for our tabs as
- ;; expected.
- (fit-window-to-buffer
- tabs-window frame-tabs-max-size frame-tabs-min-size)
- (if tabs-vertical
- (setq window-size-fixed 'height)
- (setq window-size-fixed 'width))
- (set-window-start tabs-window (point-min))
- (setq cursor-type nil)
- (set-window-parameter tabs-window 'no-other-window t)
- (set (make-local-variable 'transient-mark-mode) nil)
- (set-window-point
- tabs-window
- (or tabs-point (point-min))))
- (set-window-dedicated-p tabs-window t))
- tabs-window))
-
-(defun frame-tabs--update ()
- "Update frame tabs after timer fires."
- (let ((selected-window (selected-window))
- buffer-list-update-hook)
- (unwind-protect
- (progn
- (setq frame-tabs-run t)
- ;; Sanitize frame tabs buffers.
- (dolist (buffer frame-tabs-buffers)
- (cond
- ((not (buffer-live-p buffer))
- (setq frame-tabs-buffers
- (delq buffer frame-tabs-buffers)))
- ((not (get-buffer-window buffer t))
- (setq frame-tabs-buffers
- (delq buffer frame-tabs-buffers))
- (kill-buffer buffer))))
- ;; Provide tabs window on each frame. Exclude
- ;; minibuffer-only and unsplittable frames.
- (dolist (frame (frame-list))
- (unless (or (eq (frame-parameter frame 'minibuffer) 'only)
- (frame-parameter frame 'unsplittable))
- (frame-tabs--window frame))))
- (select-window selected-window)
- (setq frame-tabs-run nil)
- (cancel-timer frame-tabs-timer))))
-
-(defun frame-tabs--enable-timer ()
- "Schedule updating frame tabs."
- (unless frame-tabs-run
- (when (timerp frame-tabs-timer)
- (cancel-timer frame-tabs-timer))
- (setq frame-tabs-timer
- (run-with-idle-timer frame-tabs-delay t 'frame-tabs--update))))
-
-(defun frame-tabs--remove ()
- "Remove frame tabs window from each frame."
- (condition-case nil
- (progn
- (setq frame-tabs-run t)
- (cancel-timer frame-tabs-timer)
- (dolist (buffer frame-tabs-buffers)
- (when (buffer-live-p buffer)
- (delete-windows-on buffer t))
- (kill-buffer buffer))
- (setq frame-tabs-buffers nil)
- (setq frame-tabs-run nil)
- (cancel-timer frame-tabs-timer))
- (error nil)))
-
-(defun frame-tabs--window-configuration-change ()
- "Run timer when a window configuration changes."
- (frame-tabs--enable-timer))
-
-(defun frame-tabs--buffer-list-update ()
- "Run timer when the buffer list has been updated."
- (frame-tabs--enable-timer))
-
-(defun frame-tabs--window-size-change (frame)
- "Run timer when the root window of FRAME changes size."
- (let ((root (frame-root-window frame)))
- (when (or (and (memq frame-tabs-side '(top bottom))
- (not (= (window-pixel-width-before-size-change root)
- (window-pixel-width root))))
- (and (memq frame-tabs-side '(left right))
- (not (= (window-pixel-height-before-size-change root)
- (window-pixel-height root)))))
- (frame-tabs--enable-timer))))
-
-;; Commands
-(defun frame-tabs--switch-to-buffer (event &optional where)
- "Switch to buffer of tab clicked on.
-EVENT is the original event associated with the click. WHERE is
-the location where the switch shall take place."
- (let* ((tabs-window (posn-window (event-end event)))
- (tabs-buffer (window-buffer tabs-window))
- buffer)
- (with-current-buffer tabs-buffer
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (setq buffer (get-text-property (point) 'buffer))
- (when (eq tabs-window (selected-window))
- (select-window (get-mru-window 0 nil t)))
- (cond
- ((not (buffer-live-p buffer))
- (message "Not a live buffer %s" buffer))
- ((eq where 'other-window)
- (switch-to-buffer-other-window buffer))
- ((eq where 'other-frame)
- (switch-to-buffer-other-frame buffer))
- (t
- (switch-to-buffer buffer)))))))
-
-(defun frame-tabs-switch-to-buffer (event)
- "In selected window switch to buffer of tab clicked on."
- (interactive "e")
- (frame-tabs--switch-to-buffer event))
-
-(defun frame-tabs-switch-to-buffer-other-window (event)
- "In other window switch to buffer of tab clicked on."
- (interactive "e")
- (frame-tabs--switch-to-buffer event 'other-window))
-
-(defun frame-tabs-switch-to-buffer-other-frame (event)
- "In other frame switch to buffer of tab clicked on."
- (interactive "e")
- (frame-tabs--switch-to-buffer event 'other-frame))
-
-(defun frame-tabs--dismiss-buffer (event &optional how)
- "Dismiss buffer of tab clicked on.
-EVENT is the original event associated with the click. HOW is
-the type of dismissal chosen."
- (let* ((tabs-window (posn-window (event-end event)))
- (tabs-buffer (window-buffer tabs-window))
- buffer)
- (with-current-buffer tabs-buffer
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (setq buffer (get-text-property (point) 'buffer))))
- (when (eq tabs-window (selected-window))
- (select-window (get-mru-window 0 nil t)))
- (cond
- ((eq how 'replace)
- (replace-buffer-in-windows buffer))
- ((eq how 'kill)
- (kill-buffer buffer))
- ((eq (window-buffer) buffer)
- ;; Must not call this with BUFFER as argument!
- (bury-buffer))
- (t
- (bury-buffer buffer)))))
-
-(defun frame-tabs-bury-buffer (event)
- "Bury buffer of tab clicked on."
- (interactive "e")
- (frame-tabs--dismiss-buffer event))
-
-(defun frame-tabs-replace-buffer (event)
- "Replace buffer of tab clicked on in all windows showing it."
- (interactive "e")
- (frame-tabs--dismiss-buffer event 'replace))
-
-(defun frame-tabs-kill-buffer (event)
- "Kill buffer of tab clicked on."
- (interactive "e")
- (frame-tabs--dismiss-buffer event 'kill))
-
-;;;###autoload
-(define-minor-mode frame-tabs-mode
- "Toggle display of a buffer tabs side window on each frame.
-With a prefix argument ARG, enable this mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
-
-When this mode is enabled, every normal frame is equipped with a
-side window showing tabs for all buffers that appeared on that
-frame."
- :global t
- :group 'frame-tabs
- :init-value nil
- :link '(emacs-commentary-link "frame-tabs.el")
- (if frame-tabs-mode
- (progn
- (add-hook 'buffer-list-update-hook 'frame-tabs--buffer-list-update
'append)
- (add-hook 'window-configuration-change-hook
'frame-tabs--window-configuration-change 'append)
- (add-hook 'window-size-change-functions 'frame-tabs--window-size-change
'append)
- (frame-tabs--enable-timer)
- (frame-tabs--update))
- (remove-hook 'buffer-list-update-hook 'frame-tabs--buffer-list-update)
- (remove-hook 'window-configuration-change-hook
'frame-tabs--window-configuration-change)
- (remove-hook 'window-size-change-functions 'frame-tabs--window-size-change)
- (frame-tabs--remove)))
-
-(provide 'frame-tabs)
-
-;;; frame-tabs.el ends here
diff --git a/packages/gnu-elpa-keyring-update/etc/gnu-elpa.gpg-keyring
b/packages/gnu-elpa-keyring-update/etc/gnu-elpa.gpg-keyring
deleted file mode 100644
index 490dee4..0000000
Binary files a/packages/gnu-elpa-keyring-update/etc/gnu-elpa.gpg-keyring and
/dev/null differ
diff --git a/packages/gnu-elpa-keyring-update/gnu-elpa-keyring-update.el
b/packages/gnu-elpa-keyring-update/gnu-elpa-keyring-update.el
deleted file mode 100644
index 6485a9d..0000000
--- a/packages/gnu-elpa-keyring-update/gnu-elpa-keyring-update.el
+++ /dev/null
@@ -1,110 +0,0 @@
-;;; gnu-elpa-keyring-update.el --- Update Emacs's GPG keyring for GNU ELPA
-*- lexical-binding: t; -*-
-
-;; Copyright (C) 2019 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: maint, tools
-;; Package-Type: multi
-;; Version: 2019.3
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package updates the GPG keys used by the ELPA package manager
-;; (a.k.a `package.el') to verify authenticity of packages downloaded
-;; from the GNU ELPA archive.
-;;
-;; Those keys have a limited validity in time (for example, the first key was
-;; valid until Sep 2019 only), so you need to install and keep this package up
-;; to date to make sure signature verification does not spuriously fail when
-;; installing packages.
-;;
-;; If your keys are already too old, causing signature verification errors when
-;; installing packages, then in order to install this package you can do the
-;; following:
-;;
-;; - Fetch the new key manually, e.g. with something like:
-;;
-;; gpg --homedir ~/.emacs.d/elpa/gnupg --receive-keys 066DAFCB81E42C40
-;;
-;; - Modify the expiration date of the old key, e.g. with something like:
-;;
-;; gpg --homedir ~/.emacs.d/elpa/gnupg \
-;; --quick-set-expire 474F05837FBDEF9B 1y
-;;
-;; - temporarily disable signature verification (see variable
-;; `package-check-signature').
-
-;;; Code:
-
-;;;###autoload
-(defvar gnu-elpa-keyring-update--keyring
- ;; FIXME: Avoid using a `.gpg' extension, because it triggers a bug in
- ;; tar-untar-buffer (which is used internally by `package.el' when installing
- ;; the package).
- (let ((kr (expand-file-name "etc/gnu-elpa.gpg-keyring"
- (file-name-directory load-file-name))))
- (if (and load-file-name (file-readable-p kr))
- kr
- "etc/gnu-elpa.gpg-keyring")))
-
-(defun gnu-elpa-keyring-update--keyring (&optional noerror)
- (if (and (file-name-absolute-p gnu-elpa-keyring-update--keyring)
- (file-readable-p gnu-elpa-keyring-update--keyring))
- gnu-elpa-keyring-update--keyring
- (let ((kr (expand-file-name
- gnu-elpa-keyring-update--keyring
- (file-name-directory
- (or (locate-library "gnu-elpa-keyring-update")
- (error
- "Can't find the gnu-elpa-keyring-update package"))))))
- (if (file-readable-p kr)
- (setq gnu-elpa-keyring-update--keyring kr)
- (unless noerror
- (error "Can't find the gpg-keyring file with the new keys"))))))
-
-;;;###autoload
-(defun gnu-elpa-keyring-update ()
- "Import new GNU ELPA keys (if any) into package.el's keyring."
- (let ((gnupghome-dir (or (bound-and-true-p package-gnupghome-dir)
- (expand-file-name "gnupg"
- package-user-dir))))
- (if (not (file-directory-p gnupghome-dir))
- (error "No keyring to update!")
- (package-import-keyring (gnu-elpa-keyring-update--keyring))
- (write-region "" nil (expand-file-name "gnu-elpa.timestamp"
gnupghome-dir)
- nil 'silent))))
-
-;;;###autoload (eval-after-load 'package
-;;;###autoload `(and (bound-and-true-p package-user-dir)
-;;;###autoload (file-directory-p package-user-dir)
-;;;###autoload (let ((ts (expand-file-name
-;;;###autoload "gnu-elpa.timestamp"
-;;;###autoload (or (bound-and-true-p package-gnupghome-dir)
-;;;###autoload (expand-file-name "gnupg"
-;;;###autoload package-user-dir))))
-;;;###autoload (kr gnu-elpa-keyring-update--keyring))
-;;;###autoload (and (file-writable-p ts)
-;;;###autoload (file-readable-p kr)
-;;;###autoload (file-newer-than-file-p kr ts)
-;;;###autoload (gnu-elpa-keyring-update)))))
-
-(eval-when-compile
- (condition-case err
- (gnu-elpa-keyring-update)
- (error (message "Skipping update: %s" (error-message-string err)))))
-
-(provide 'gnu-elpa-keyring-update)
-;;; gnu-elpa-keyring-update.el ends here
diff --git a/packages/greenbar/greenbar.el b/packages/greenbar/greenbar.el
deleted file mode 100644
index a145414..0000000
--- a/packages/greenbar/greenbar.el
+++ /dev/null
@@ -1,211 +0,0 @@
-;;; greenbar.el --- Mark comint output with "greenbar" background -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
-
-;; Author: Michael R. Mauger <michael@mauger.com>
-;; Version: 1.1
-;; Package-Type: simple
-;; Keywords: faces, terminals
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; For us old neck beards, who learned to write software on punch
-;; cards and print out our code and output on wide line printers, it
-;; was helpful to have alternating bands of subtle background coloring
-;; to guide our eyes across the line on the page. Reading long rows
-;; of text across a 14 7/8" page, it was very easy to loose your place
-;; vertically while scanning the page horizontally. The subtle
-;; background shading was often done with pale bands of green
-;; alternating with the white of the paper.
-
-;; Paper pre-printed with the pale green bars was often referred to as
-;; "green bar" and the technique is also referred to as "zebra
-;; striping." In Emacs, in `ps-print.el' (PostScript print facility),
-;; the feature is enabling with the `ps-zebra-stripes' setting.
-
-;; To enable `greenbar-mode' in your `comint-mode' buffers, add the
-;; following to your Emacs configuration:
-
-;; (add-hook 'comint-mode-hook #'greenbar-mode)
-
-;; If you want to enable `greenbar-mode' only in a single mode derived
-;; from `comint-mode', then you need to add `greenbar-mode' only to
-;; the desired derived mode hook. Adding `greenbar-mode' to
-;; `comint-mode-hook' enables it for all comint derived modes.
-
-;; The variable `greenbar-color-theme' is a list of predefined bar
-;; background colors. Each element of the list is a list: the first
-;; member of which is a symbol that is the name of the theme; the rest
-;; of the list are color names which are used as background colors for
-;; successive bands of lines.
-
-;; The variable `greenbar-color-list' controls which set of color bars
-;; are to be applied. The value is either a name from color theme
-;; defined in `greenbar-color-themes' or it is a list of color names.
-
-;; The variable `greenbar-lines-per-bar' controls how many output
-;; lines are displayed using each band's background color.
-
-;; By default, input lines are not highlighted, but if
-;; `greenbar-highlight-input' is set to a non-nil value, then input is
-;; also highlighted with green bars as well.
-
-;; Suggestions for other background color themes are always welcome.
-
-;;; Code:
-
-(require 'comint)
-(require 'cl-lib)
-
-(defgroup greenbar nil
- "Stripe comint output like \"green bar\", or \"zebra stripe\" paper."
- :group 'comint)
-
-(defvar-local greenbar-current-bar 0
- "Index into `greenbar-background-colors' that is active.")
-
-(defvar-local greenbar-current-line 0
- "The line into the bar that is active.")
-
-(defcustom greenbar-lines-per-bar 3
- "How many lines of output should be colored together."
- :type 'integer)
-
-(defvar greenbar-color-themes
- (list
- (cons 'greenbar
- (if (eq (frame-parameter nil 'background-mode) 'dark)
- '("#344034" "#343434")
- '("#e4f0e4" "#f0f0f0")))
- (cons 'graybar
- (list
- (if (eq (frame-parameter nil 'background-mode) 'dark)
- "gray30" "gray70")
- (face-background 'default)))
- (cons 'rainbow
- (let ((x (if (eq (frame-parameter nil 'background-mode) 'dark) "40"
"f0"))
- (o (if (eq (frame-parameter nil 'background-mode) 'dark) "34"
"e4")))
-
- (mapcar (lambda (c) (apply #'concat "#" c))
- `((,x ,x ,o) (,x ,o ,o) (,x ,o ,x) (,o ,o ,x) (,o ,x ,x)
(,o ,x ,o))))))
- "A list of Greenbar themes.
-
-Each member of the list starts with a symbol that identifies the
-theme followed by the list bar colors.")
-
-(defcustom greenbar-background-colors 'greenbar
- "List of background colors to be applied to output stripes."
- :type `(choice ,@(mapcar (lambda (c)
- (list 'const (car c)))
- greenbar-color-themes)
- (repeat (color :tag "Background color"))))
-
-(defcustom greenbar-highlight-input nil
- "Should prompts and command input be highlighted."
- :type 'booleanp)
-
-(defun greenbar-color-list ()
- "Get the list of greenbar background colors."
- (or (cdr (assoc greenbar-background-colors
- greenbar-color-themes))
- greenbar-background-colors))
-
-(defun greenbar-is-valid-bar (color-list)
- "Return non-nil, if COLOR-LIST is a list of valid colors."
- (and color-list
- (listp color-list)
- (cl-every #'identity
- (mapcar #'color-defined-p color-list))))
-
-(defun greenbar-is-command-input (_start end)
- "Return non-nil, if input is in region betweeen START and END."
- (= end comint-last-input-end))
-
-(defun greenbar-next-bar ()
- "Reset the local configuration if we are at the end of a bar.
-
-If `greenbar-lines' is zero, reset it to
-`greenbar-lines-per-bar', and move `greenbar-current-bar' to the
-next one."
-
- (when (zerop greenbar-current-line)
- (setq greenbar-current-bar (mod (1+ greenbar-current-bar) (length
(greenbar-color-list)))
- greenbar-current-line (default-value 'greenbar-lines-per-bar))))
-
-(defun greenbar-output-filter (string)
- "Stripe comint output in STRING with background colors.
-
-Every `greenbar-lines-per-bar' lines are colored with a rotating
-set of background colors found in
-`greenbar-background-colors'."
-
- (let ((bar (greenbar-color-list))
- (start comint-last-output-start)
- (end (process-mark (get-buffer-process (current-buffer)))))
-
- (when (and (greenbar-is-valid-bar bar)
- (not (= start end))
- (or greenbar-highlight-input
- (not (greenbar-is-command-input start end))))
-
- (greenbar-next-bar) ; make sure greenbar state is valid
- (save-excursion
- (save-restriction
- ;; Don't highlight partial last line
- (goto-char end)
- (forward-line 0)
- (setq end (point))
-
- ;; Highlight the beginning of the start line
- (goto-char start)
- (forward-line 0)
- (setq start (point))
-
- ;; Limit what we can highlight
- (narrow-to-region start end)
-
- ;; Mark every set of lines alternating among bar colors
- (while (< start end)
- (goto-char start)
- (setq greenbar-current-line (forward-line greenbar-current-line))
-
- ;; Mark the bar
- (let ((bar-bg (nth greenbar-current-bar bar)))
- (font-lock-append-text-property
- start (point)
- 'font-lock-face (list :background bar-bg
- :extend t)))
-
- ;; Get ready for the next bar
- (setq start (point))
-
- ;; When the full bar is complete, set up for next bar
- (greenbar-next-bar))))))
- string)
-
-;;;###autoload
-(define-minor-mode greenbar-mode
- "Enable \"green bar striping\" of comint output"
- nil nil nil
- (if greenbar-mode
- (add-hook 'comint-output-filter-functions
- #'greenbar-output-filter t t)
- (remove-hook 'comint-output-filter-functions
- #'greenbar-output-filter t)))
-
-(provide 'greenbar)
-
-;;; greenbar.el ends here
diff --git a/packages/iterators/iterators.el b/packages/iterators/iterators.el
deleted file mode 100644
index b165a6c..0000000
--- a/packages/iterators/iterators.el
+++ /dev/null
@@ -1,431 +0,0 @@
-;;; iterators.el --- Functions for working with iterators -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2015-2020 Free Software Foundation, Inc
-
-;; Author: Michael Heerdegen <michael_heerdegen@web.de>
-;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
-;; Created: Mar 18 2015
-;; Keywords: extensions, elisp
-;; Compatibility: GNU Emacs >=25
-;; Version: 0.1.1
-;; Package-Requires: ((emacs "25"))
-
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-;;
-;; This package extends "generator.el" with higher-level functions.
-;;
-;;
-;; TODO:
-;;
-;; - hook ilists into seq.el via `cl-defgeneric'
-
-
-;;; Code:
-
-
-(eval-when-compile (require 'cl-lib))
-(require 'generator)
-
-
-;;;; Basic stuff
-
-(defmacro iterator-make (&rest body)
- "Create an anonymous iterator.
-This is equivalent to (funcall (iter-lambda () BODY...))"
- `(funcall (iter-lambda () ,@body)))
-
-
-;;;; Special simple iterators
-
-(defun iterator-from-elts (&rest elements)
- "Return an iterator generating the ELEMENTS."
- (iterator-make (while elements (iter-yield (pop elements)))))
-
-(defun iterator-cycle-elts (&rest elements)
- "Return an iterator cycling through the ELEMENTS.
-Unlike `iterator-from-elts', after the last of the ELEMENTS has been
-generated, the resulting iterator will generate all ELEMENTS
-again ad finitum."
- (if (null elements)
- (iterator-from-elts)
- (setcdr (last elements) elements)
- (iterator-make (while t (iter-yield (pop elements))))))
-
-(defun iterator--cons (val iterator)
- (iterator-make
- (iter-yield val)
- (iter-yield-from iterator)))
-
-(defun iterator-iterate-function (function value)
- "Return an iterator of repeated applications of FUNCTION to VALUE.
-The sequence of returned elements is starting with VALUE. Any
-successive element will be found by calling FUNCTION on the
-preceding element."
- (iterator--cons
- value
- (iterator-make
- (while t (iter-yield (setq value (funcall function value)))))))
-
-(defun iterator-number-range (&optional start end inc)
- "Return an iterator of a number range.
-START denotes the first number and defaults to 0. The second,
-optional argument END specifies the upper limit (exclusively).
-If nil, the returned iterator is infinite. INC is the increment
-used between the numbers and defaults to 1."
- (let* ((inc (or inc +1))
- (start (or start 0))
- (i start))
- (if end
- (let ((comp (if (> inc 0) #'< #'>)))
- (iterator-make
- (while (funcall comp i end)
- (iter-yield (prog1 i (cl-incf i inc))))))
- (iterator-make (while t (iter-yield (prog1 i (cl-incf i))))))))
-
-(iter-defun iterator-of-directory-files-1 (directory &optional match nosort
recurse follow-links)
- "Helper for `iterator-of-directory-files'."
- (when (file-accessible-directory-p directory)
- (let ((files (directory-files directory t match nosort)) dirs non-dirs)
- (dolist (file files)
- (if (file-directory-p file)
- (push file dirs)
- (push file non-dirs)))
- (dolist (file non-dirs)
- (iter-yield file))
- (dolist (dir dirs)
- (unless (member (file-name-nondirectory (directory-file-name dir))
'("." ".."))
- (iter-yield dir)
- (when (and (or follow-links (not (file-symlink-p dir)))
- (if (functionp recurse) (funcall recurse dir) recurse))
- (iter-yield-from (iterator-of-directory-files-1
- dir match nosort recurse follow-links))))))))
-
-(defun iterator-of-directory-files (directory &optional full match nosort
recurse follow-links)
- "Return an iterator of names of files in DIRECTORY.
-Don't include files named \".\" or \"..\". The arguments FULL,
-MATCH and NOSORT are like in `directory-files'.
-
-Optional argument RECURSE non-nil means recurse on
-subdirectories. If RECURSE is a function, it should be a
-predicate accepting one argument, an absolute file name of a
-directory, and return non-nil when the returned iterator should
-recurse into that directory. Any other non-nil value means
-recurse into every readable subdirectory.
-
-Even with RECURSE non-nil, don't descent into directories by
-following symlinks unless FOLLOW-LINKS is non-nil."
- (iterator-map
- (lambda (file) (if full file (file-relative-name file directory)))
- (iterator-of-directory-files-1 directory match nosort recurse
follow-links)))
-
-
-;;;; Operations on iterators, transducers
-
-(defun iterator-filter (predicate iterator)
- "Return an iterator filtering ITERATOR with PREDICATE.
-This new iterator will return elements in the same order as
-ITERATOR, but only those that fulfill PREDICATE, a function that
-accepts one argument."
- (iterator-make
- (while t
- (let ((el (iter-next iterator)))
- (while (not (funcall predicate el))
- (setq el (iter-next iterator)))
- (iter-yield el)))))
-
-(defun iterator-delq (elt iterator)
- "Return an iterator of the elements of ITERATOR not `eq' to ELT."
- (iterator-filter (lambda (el) (not (eq el elt))) iterator))
-
-(defun iterator-concatenate (&rest iterators)
- "Concatenate the ITERATORS.
-Return a new iterator that returns the elements generated by
-each iterator in ITERATORS, in order. The ITERATORS are each
-invoked to completion, in order."
- (iterator-make
- (let (current)
- (while (setq current (pop iterators))
- (iter-yield-from current)))))
-
-(defun iterator-map (function &rest iterators)
- "Return an iterator mapping FUNCTION across ITERATORS.
-If there are several ITERATORS, FUNCTION is called with that
-many arguments. The resulting iterator will produce elements as
-long as the shortest iterator does."
- (iterator-make
- (while t (iter-yield (apply function (mapcar #'iter-next iterators))))))
-
-(defun iterator-take-while (predicate iterator)
- "Return an iterator representing a \"do-while\" loop.
-It will invoke ITERATOR to produce elements as long they fulfill
-PREDICATE and stop then."
- (iterator-make
- (let (el)
- (while (funcall predicate (setq el (iter-next iterator)))
- (iter-yield el)))))
-
-(defun iterator-take-until (predicate iterator)
- "Return an iterator representing an \"until-do\" loop.
-It will invoke ITERATOR to produce elements until one fulfills
-PREDICATE. It will stop after returning this element."
- (iterator-make
- (let (el)
- (while (not (funcall predicate (setq el (iter-next iterator))))
- (iter-yield el))
- (iter-yield el))))
-
-(defun iterator-take (n iterator)
- "Return an iterator of the first N elements of ITERATOR.
-This iterator generates at most the first N elements generated
-by ITERATOR, in order."
- (iterator-make (while (>= (cl-decf n) 0)
- (iter-yield (iter-next iterator)))))
-
-(defun iterator-scan (function init iterator)
- "Return an iterator of successive reduced values.
-If the elements generated by iterator i are i_1, i_2, ..., the
-elements s_1, s_2, ... of the iterator returned by
-\(iterator-scan f init i\) are defined recursively by
-
- s_1 = init
- s_(n+1) = (funcall f s_n i_n)
-
-as long as i_n exists.
-
-Example: (iterator-scan #\\='* 1 (iterator-number-range 1))
-returns an iterator of the factorials."
- (let ((res init))
- (iterator--cons
- res
- (iterator-map (lambda (el) (setq res (funcall function res el)))
- iterator))))
-
-
-;;;; Iteration
-
-(defun iterator-flush (iterator)
- "Request all elements from ITERATOR, for side effects only."
- (condition-case nil
- (while t (iter-next iterator))
- (iter-end-of-sequence nil)))
-
-
-;;;; Processing elements
-
-(defun iterator-reduce (function init iterator)
- "Reduce two-argument FUNCTION across ITERATOR starting with INIT.
-This is the same value as the expression
-
- (iter-last (iterator-scan function init iterator))
-
-would return."
- (let ((res init))
- (iterator-flush (iterator-map (lambda (el) (setq res (funcall function res
el))) iterator))
- res))
-
-(defun iterator-to-list (iterator)
- "Convert ITERATOR into a list.
-Run ITERATOR until it runs out of elements and return a list of
-the generated elements."
- (nreverse (iterator-reduce (lambda (x y) (cons y x)) () iterator)))
-
-(defun iterator-last (iterator)
- "Request all elements from ITERATOR and return the last one."
- (let ((el (iter-next iterator)))
- (condition-case nil
- (while t (setq el (iter-next iterator)))
- (iter-end-of-sequence el))))
-
-(defun iterator-count (iterator)
- "Request all elements from ITERATOR and return their count."
- (iterator-reduce (lambda (s _el) (1+ s)) 0 iterator))
-
-(defun iterator-some (predicate &rest iterators)
- "Return non-nil if PREDICATE is true for any element of ITER or ITERs.
-If so, return the true (non-nil) value returned by PREDICATE.
-\n(fn PREDICATE ITER...)"
- (catch 'success
- (iterator-flush
- (apply #'iterator-map
- (lambda (&rest elts) (let (res) (when (setq res (apply predicate
elts))
- (throw 'success res))))
- iterators))
- nil))
-
-(defun iterator-every (predicate &rest iterators)
- "Return non-nil if PREDICATE is true for every element of ITER or ITERs.
-\n(fn PREDICATE ITER...)"
- (not (apply #'iterator-some (lambda (&rest args) (not (apply predicate
args))) iterators)))
-
-(defun iterator-max (iterator &optional function)
- "Return an element of finite ITERATOR maximizing FUNCTION.
-Request all elements from ITERATOR and pass them to FUNCTION, a
-one-argument function that must return a number. Return an
-element for which FUNCTION was maximal. Raise an error if
-ITERATOR produced no elements. FUNCTION defaults to `identity'.
-
-Example: if ITERATOR is an iterator of lists, this would return
-a longest generated list: (iterator-max iterator #'length)."
- (let ((first (iter-next iterator))
- (function (or function #'identity)))
- (iterator-reduce
- (lambda (x y) (if (< (funcall function x) (funcall function y)) y x))
- first iterator)))
-
-(defun iterator-min (iterator &optional function)
- "Return an element of ITERATOR that minimizes FUNCTION.
-Request all elements from ITERATOR and pass them to FUNCTION, a
-one-argument function that must return a number. Return an
-element for which FUNCTION was minimal. Raise an error if
-ITERATOR produced no elements. FUNCTION defaults to `identity'."
- (let ((function (or function #'identity)))
- (iterator-max iterator (lambda (x) (- (funcall function x))))))
-
-(defun iterator-mapconcat (function iterator separator)
- "Apply FUNCTION to each element of ITERATOR, and concat the results as
strings.
-In between of each pair of results, stick in SEPARATOR. This is
-like `mapconcat', but for iterators."
- (let ((first (iter-next iterator)))
- (iterator-reduce (lambda (x y) (concat x separator y))
- (funcall function first)
- (iterator-map function iterator))))
-
-
-;;;; ILists - "Delayed" lists via iterators
-
-(defconst ilist--last-link-tag 'ilist--last-link-tag)
-
-(defun iterator-to-ilist (iterator)
- "Return an ilist using ITERATOR to produce elements."
- (cons ilist--last-link-tag iterator))
-
-(defmacro ilist-make (expr)
- "Return an ilist calling an iterator using EXPR to produce elements."
- `(iterator-to-ilist (iterator-make ,expr)))
-
-(defconst ilist-null
- (cons ilist--last-link-tag nil)
- "A distinguished empty ilist.")
-
-(defun ilistp (object)
- "Return t if OBJECT is an ilist, that is, a cons cell or nil.
-Otherwise, return nil."
- (listp object))
-
-(defun ilist-car (ilist)
- "Return the first element of ILIST.
-Error if arg is not nil and not a cons cell."
- (if (eq (car ilist) ilist--last-link-tag)
- (let ((iterator (cdr ilist)) new-el)
- (if (null iterator) nil
- (condition-case nil
- (prog1 (setq new-el (iter-next iterator))
- (setcar ilist new-el)
- (setcdr ilist (cons ilist--last-link-tag iterator)))
- (iter-end-of-sequence (setcdr ilist nil)
- nil))))
- (car ilist)))
-
-(defun ilist-empty-p (ilist)
- "Return t if ILIST is empty."
- (ignore (ilist-car ilist))
- (null (cdr ilist)))
-
-(defun ilist-cdr (ilist)
- "Return the `ilist-cdr' of ILIST.
-Error if arg is not nil and not a cons cell."
- (if (ilist-empty-p ilist) ilist (cdr ilist)))
-
-(defun ilist-cons (el ilist)
- "Return a new ilist with EL as `ilist-car' ILIST as `ilist-cdr'."
- (cons el ilist))
-
-(defun ilist-nthcdr (n ilist)
- "Take `ilist-cdr' N times on ILIST, return the result."
- (cl-dotimes (_ n) (cl-callf ilist-cdr ilist))
- ilist)
-
-(defun ilist-nth (n ilist)
- "Return the Nth element of ILIST.
-N counts from zero. If ILIST is not that long, nil is returned."
- (ilist-car (ilist-nthcdr n ilist)))
-
-(defun ilist-to-iterator (ilist)
- "Return an iterator generating the elements of ILIST.
-The structure of ILIST is updated as side effect if new elements
-are generated by the returned iterator which were not yet
-created in ILIST."
- (iterator-make
- (while (not (ilist-empty-p ilist))
- (prog1 (iter-yield (ilist-car ilist))
- (cl-callf ilist-cdr ilist)))))
-
-(defun ilist-mapcar (function ilist)
- "Apply FUNCTION to each element of ILIST, and make an ilist of the results.
-The result is an ilist just as long as ILIST."
- (iterator-to-ilist
- (iterator-map function (ilist-to-iterator ilist))))
-
-(defun ilist (&rest objects)
- "Return a newly created ilist with specified arguments as elements."
- (nconc objects ilist-null))
-
-(defun list-to-ilist (list)
- "Convert LIST into an ilist.
-The result is an ilist containing the same elements as LIST in
-the same order. This is a destructive operation modifying LIST."
- (nconc list ilist-null))
-
-(defun ilist-to-list (ilist)
- "Return a list of all elements of ILIST.
-All elements of ILIST are generated as side effect."
- (let ((elts '()))
- (while (not (ilist-empty-p ilist))
- (push (ilist-car ilist) elts)
- (cl-callf ilist-cdr ilist))
- (nreverse elts)))
-
-(defun ilist-concatenate (&rest ilists)
- "Concatenate the ILISTS into a new ilist and return the result.
-New elements in the argument ilists are generated when being
-referenced in the concatenated ilist. Apart from that, the
-argument ilists are not modified."
- (iterator-to-ilist
- (apply #'iterator-concatenate
- (mapcar #'ilist-to-iterator ilists))))
-
-(define-error 'empty-ilist "Empty ilist")
-
-(defun ilist-setcar (ilist object)
- "Set the first element of ILIST to OBJECT.
-Error if ILIST is empty. Return OBJECT."
- (if (ilist-empty-p ilist)
- (signal 'empty-ilist nil)
- (setcar ilist object)))
-
-(defun ilist-setcdr (ilist newcdr)
- "Set the `ilist-cdr' of ILIST to NEWCDR.
-Error if ILIST is empty. Return NEWCDR."
- (if (ilist-empty-p ilist)
- (signal 'empty-ilist nil)
- (setcdr ilist newcdr)))
-
-
-(provide 'iterators)
-
-;;; iterators.el ends here
diff --git a/packages/jumpc/jumpc.el b/packages/jumpc/jumpc.el
deleted file mode 100644
index bf28d0c..0000000
--- a/packages/jumpc/jumpc.el
+++ /dev/null
@@ -1,235 +0,0 @@
-;;; jumpc.el --- jump to previous insertion points -*- coding: utf-8;
lexical-binding: t -*-
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Ivan Kanis <ivan@kanis.fr>
-;; Version: 3.0
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This implements the jump cursor feature found in vim.
-
-;; A jump is added every time you insert a character on a different
-;; line.
-
-;; Jumps are remembered in a jump list. With the C-o and C-i
-;; command you can go to cursor positions before older jumps, and back
-;; again. Thus you can move up and down the list.
-
-;; Jumps are read and saved in the same configuration file as vim so
-;; you can switch back and forth between the two editors
-
-;;;; THANKS:
-
-;; Bram Moolenaar for writing a fine editor and helping needy children
-;; in Uganda
-
-;; Stefan Monnier for telling me how to add C-i binding
-
-;; Ted Zlatanov for suggesting to use less agressive key bindings
-
-;;;; BUGS:
-
-;;;; INSTALLATION:
-
-;; put this file somewhere in your load path then put the put the
-;; following in your .emacs:
-;;
-;; (require 'jumpc)
-;; (jumpc)
-;;
-;; Then either:
-;;
-;; (jumpc-bind-vim-key)
-;;
-;; Or:
-;;
-;; (global-set-key (kbd "<f8>") 'jumpc-jump-backward)
-;; (global-set-key (kbd "<f9>") 'jumpc-jump-forward)
-;;
-;; The first will bind C-i and C-o just like vim. The second bind
-;; function keys 8 and 9. Of course you can pick any keys you like. If
-;; you use Emacs on a console you will have to pick the second form as
-;; C-i and TAB are the same thing.
-;;
-;; If you use autoload you don't need to require the file
-
-;;;; TODO
-
-;; search for TODO within the file
-
-;; Add rotate jump list feature in vim
-;; defined as JUMPLIST_ROTATE in mark.c
-;; "If last used entry is not at the top, put it at the top by
-;; rotating the stack until it is (the newer entries will be at
-;; the bottom). Keep one entry (the last used one) at the top."
-
-;; Add a bit of looseness. For example do not add jump points within
-;; three lines of the last one.
-
-;; Add jump list displaying each jump with the file and line in the
-;; file. Clicking on a line takes you to the jump location.
-
-;; Add more commands that will insert jump. Vim does: "'", "`", "G",
-;; "/", "?", "n", "N", "%", "(", ")", "[[", "]]", "{", "}", ":s",
-;; ":tag", "L", "M", "H"
-
-;; Remove files that do not exist when reading and writing from
-;; configuration file
-
-;;;; VERSION
-
-;; version 1
-
-;; version 2
-;; - don't force vim key bindings
-;; - remove debugging message
-;; - insert a jump moves the index back to top of list
-;; - insert jumps goes back to top of list
-
-;; version 3
-;; - remove deleted files
-
-;;; Code:
-
-(defvar jumpc-file "~/.viminfo"
- "File where jump information is written.")
-
-(defvar jumpc-list nil
- "List of filenames and position to jump to.")
-
-(defvar jumpc-index 0
- "Index of jump, 0 is the newest entry.")
-
-(defun jumpc-read-list ()
- "Read jump list from file."
- (when (file-exists-p jumpc-file)
- (with-temp-buffer
- (insert-file-contents jumpc-file)
- (goto-char (point-min))
- (when (re-search-forward "# Jumplist (newest first):" nil t)
- (while (re-search-forward
- "-' \\([0-9]*\\) \\([0-9]*\\) \\(.*\\)" nil t)
- (add-to-list 'jumpc-list
- (list (string-to-number (match-string 1))
- (string-to-number (match-string 2))
- (expand-file-name (match-string 3)))
- jumpc-list)))))
- jumpc-list)
-
-(defun jumpc-write-list ()
- "Write jump list to file."
- (let (bgn end)
- (jumpc-remove-deleted-file)
- (find-file jumpc-file)
- (goto-char (point-min))
- (setq bgn (re-search-forward "# Jumplist (newest first):" nil t))
- (if bgn
- (progn
- (setq end (re-search-forward "^$"))
- (delete-region bgn end))
- ;; looks like the entry doesn't exist, tack it at the end
- (goto-char (point-max))
- (insert "# Jumplist (newest first):"))
- (insert "\n")
- (dolist (line jumpc-list)
- (insert (format "-' %d %d %s\n"
- (nth 0 line) (nth 1 line)
- (abbreviate-file-name (nth 2 line)))))
- (save-buffer)))
-
-(defun jumpc-jump-backward ()
- "Jump backward in list of jumps."
- (interactive)
- (jumpc-jump 1))
-
-(defun jumpc-jump-forward ()
- "Jump forward in list of jumps."
- (interactive)
- (jumpc-jump -1))
-
-;; TODO make it interactive with COUNT as argument
-(defun jumpc-jump (count)
- "Jump COUNT from current index."
- (jumpc-remove-deleted-file)
- (let ((length (length jumpc-list)) file-name)
- ;; first backward motion adds current point in the list
- (when (and (> count 0) (= jumpc-index 0))
- (jumpc-insert))
- (setq jumpc-index (+ jumpc-index count))
- ;; fix index if it's out of boundary
- (cond
- ((< jumpc-index 0)
- (setq jumpc-index 0))
- ((> jumpc-index length)
- (setq jumpc-index length))
- (t
- (setq file-name (nth 2 (nth jumpc-index jumpc-list)))
- (find-file file-name)
- (goto-char (point-min))
- (forward-line (1- (nth 0 (nth jumpc-index jumpc-list))))
- (move-to-column (nth 0 (nth jumpc-index jumpc-list)))))))
-
-(defun jumpc-insert ()
- "Insert jump location."
- ;; It means we are going back to the top of the list
- (setq jumpc-index 0)
- (when buffer-file-name
- (when (not (= (line-number-at-pos) (nth 0 (car jumpc-list))))
- (setq jumpc-list
- (cons (list (line-number-at-pos) (current-column) buffer-file-name)
- jumpc-list)))))
-
-(defun jumpc-remove-deleted-file ()
- "Remove deleted file in the list.
-Returns list minus deleted files."
- (let ((length (length jumpc-list))
- (index 0)
- reduced-list element)
- (while (< index length)
- (setq element (nth index jumpc-list))
- (when (file-exists-p (nth 2 element))
- (setq reduced-list (cons element reduced-list)))
- (setq index (1+ index)))
- (setq jumpc-list reduced-list)))
-
-(defun jumpc-bind-vim-key ()
- "Bind keys just like vim."
- (global-set-key (kbd "C-o") 'jumpc-jump-backward)
- (define-key input-decode-map [?\C-i] [control-i])
- (global-set-key [control-i] 'jumpc-jump-forward))
-
-;;;###autoload
-(defun jumpc ()
- "Initialize jump cursor."
- (interactive)
- (setq jumpc-list (jumpc-read-list))
- (defadvice self-insert-command
- (after jumpc-insert activate)
- "Insert jump position after insertion."
- (jumpc-insert))
- (add-hook 'kill-emacs-hook 'jumpc-write-list))
-
-
-;; vi:et:sw=4:ts=4:
-;; Local Variables:
-;; compile-command: "make"
-;; End:
-
-(provide 'jumpc)
-;;; jumpc.el ends here
diff --git a/packages/kmb/kmb.el b/packages/kmb/kmb.el
deleted file mode 100644
index 5798699..0000000
--- a/packages/kmb/kmb.el
+++ /dev/null
@@ -1,160 +0,0 @@
-;;; kmb.el --- Kill buffers matching a regexp w/o confirmation -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2017 Free Software Foundation, Inc.
-
-;; Author: Tino Calancha <tino.calancha@gmail.com>
-;; Keywords: lisp, convenience
-
-;; Maintainer: Tino Calancha
-;; Created: Wed May 24 13:19:18 JST 2017
-;; Version: 0.1
-;; Package-Requires: ((emacs "24.1"))
-;; Last-Updated: Fri May 26 21:17:10 JST 2017
-;; By: calancha
-;; Update #: 1
-;; Compatibility: GNU Emacs 24.x
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This file is 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 <http://www.gnu.org/licenses/>.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;; Commentary:
-;;
-;; This library provides the commands `kmb-kill-matching-buffers-no-ask'
-;; and `kmb-delete-process-and-kill-buffer-no-ask'. The former kills
-;; buffers whose name matches a regular expression. The latter,
-;; interactively kills the current buffer and if called from Lisp,
-;; then accepts a list of buffers to kill.
-;; Any of these commands ask for confirmation to kill the buffers.
-;; If one of the buffers is running a process, then the process is
-;; deleted before kill the buffer.
-;;
-;; This file also defines the commands `kmb-list-matching-buffers' and
-;; `kmb-list-buffers-matching-content' to list the buffers whose name
-;; or content match a regexp.
-;;
-;;
-;; Commands defined here:
-;;
-;; `kmb-delete-process-and-kill-buffer-no-ask',
-;; `kmb-kill-matching-buffers-no-ask', `kmb-list-buffers-matching-content',
-;; `kmb-list-matching-buffers'.
-;;
-;; Non-interactive functions defined here:
-;;
-;; `kmb--show-matches'.
-;;
-
-;;
-;;; Code:
-
-
-(defun kmb--show-matches (buffers &optional count)
- "Show the name of BUFFERS in the echo area.
-
-BUFFERS is a list of buffers.
-If optional arg COUNT is non-nil, then it's the length
-of BUFFERS."
- (if (null buffers)
- (message "No buffers matching regexp")
- (message "Found %d match%s: %s"
- (or count (length buffers))
- (if (cdr buffers) "es" "")
- (mapconcat #'buffer-name buffers ", "))))
-
-(defun kmb-list-matching-buffers (regexp &optional with-process)
- "Return list of buffers whose name matching REGEXP.
-If optional arg WITH-PROCESS is non-nil, then list just buffers
-running a process."
- (interactive
- (let* ((prefix current-prefix-arg)
- (regexp
- (if prefix
- (read-string "List buffers running a process \
-and matching regexp: ")
- (read-string "List buffers matching regexp: "))))
- (list regexp prefix)))
- (let ((buffers
- (delq nil
- (mapcar
- (lambda (x)
- (when (string-match regexp (buffer-name x))
- (cond (with-process
- (and (get-buffer-process x) x))
- (t x))))
- (buffer-list)))))
- (kmb--show-matches buffers)
- buffers))
-
-(defun kmb-kill-matching-buffers-no-ask (regexp)
- "Kill all buffers whose name matching REGEXP without confirmation.
-If a buffer is running a process, then delete the process before
-kill the buffer."
- (interactive "sKill buffers matching regexp: ")
- (dolist (b (buffer-list))
- (when (string-match regexp (buffer-name b))
- (kmb-delete-process-and-kill-buffer-no-ask b))))
-
-(defalias 'kmb-kill-matching-buffers 'kmb-kill-matching-buffers-no-ask)
-
-(defun kmb-list-buffers-matching-content (regexp)
- "Return list of buffers whose content match REGEXP."
- (interactive "sList buffers whose content matches regexp: ")
- (let* ((count 0)
- (buffers
- (delq nil
- (mapcar
- (lambda (b)
- (let (str)
- (with-current-buffer b
- (setq str (buffer-substring-no-properties
- (point-min) (point-max))))
- (when (string-match regexp str)
- (setq count (1+ count)) b)))
- (buffer-list)))))
- (kmb--show-matches buffers count)
- buffers))
-
-(defun kmb-delete-process-and-kill-buffer-no-ask (&optional buffer)
- "Delete BUFFER without confirmation.
-BUFFER is a buffer or a list of buffers.
-If the buffer is running a process, then delete the processes
-before kill the buffer.
-Interactivelly, delete the current buffer."
- (interactive "i")
- (let* ((def (or buffer (current-buffer)))
- (buffers
- (delq nil
- (mapcar #'get-buffer (if (nlistp def) (list def) def))))
- (processes (process-list)))
- (dolist (buf buffers)
- (when (get-buffer-process buf)
- (dolist (proc processes)
- (when (eq buf (process-buffer proc))
- (set-process-query-on-exit-flag proc nil))))
- (when (buffer-modified-p buf)
- (with-current-buffer buf
- (set-buffer-modified-p nil)))
- (kill-buffer buf))))
-
-(defalias 'kmb-kill-buffer 'kmb-delete-process-and-kill-buffer-no-ask)
-
-(provide 'kmb)
-
-;;; kmb.el ends here
diff --git a/packages/landmark/landmark.el b/packages/landmark/landmark.el
deleted file mode 100644
index e15da78..0000000
--- a/packages/landmark/landmark.el
+++ /dev/null
@@ -1,1686 +0,0 @@
-;;; landmark.el --- Neural-network robot that learns landmarks -*-
lexical-binding:t -*-
-
-;; Copyright (C) 1996-2018 Free Software Foundation, Inc.
-
-;; Author: Terrence Brannon <metaperl@gmail.com>
-;; Created: December 16, 1996 - first release to usenet
-;; Keywords: games, neural network, adaptive search, chemotaxis
-;; Maintainer: emacs-devel@gnu.org
-;; Version: 1.0
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; To try this, just type: M-x landmark-test-run
-
-;; Landmark is a relatively non-participatory game in which a robot
-;; attempts to maneuver towards a tree at the center of the window
-;; based on unique olfactory cues from each of the 4 directions. If
-;; the smell of the tree increases, then the weights in the robot's
-;; brain are adjusted to encourage this odor-driven behavior in the
-;; future. If the smell of the tree decreases, the robots weights are
-;; adjusted to discourage that odor-driven behavior.
-
-;; In laymen's terms, the search space is initially flat. The point
-;; of training is to "turn up the edges of the search space" so that
-;; the robot rolls toward the center.
-
-;; Further, do not become alarmed if the robot appears to oscillate
-;; back and forth between two or a few positions. This simply means
-;; it is currently caught in a local minimum and is doing its best to
-;; work its way out.
-
-;; The version of this program as described has a small problem. a
-;; move in a net direction can produce gross credit assignment. for
-;; example, if moving south will produce positive payoff, then, if in
-;; a single move, one moves east,west and south, then both east and
-;; west will be improved when they shouldn't
-
-;; The source code was developed as part of a course on Brain Theory
-;; and Neural Networks at the University of Southern California. The
-;; original problem description and solution appeared in 1981 in the
-;; paper "Landmark Learning: An Illustration of Associative
-;; Search" authored by Andrew G. Barto and Richard S. Sutton and
-;; published to Biological Cybernetics.
-
-;; Many thanks to Yuri Pryadkin <yuri@rana.usc.edu> for this
-;; concise problem description.
-
-;;;_* Require
-(eval-when-compile (require 'cl-lib))
-
-;;;_* From Gomoku
-
-;;; Code:
-
-(defgroup landmark nil
- "Neural-network robot that learns landmarks."
- :prefix "landmark-"
- :group 'games)
-
-;;;_ + THE BOARD.
-
-;; The board is a rectangular grid. We code empty squares with 0, X's with 1
-;; and O's with 6. The rectangle is recorded in a one dimensional vector
-;; containing padding squares (coded with -1). These squares allow us to
-;; detect when we are trying to move out of the board. We denote a square by
-;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The
-;; leftmost topmost square has coords (1,1) and index landmark-board-width + 2.
-;; Similarly, vectors between squares may be given by two DX, DY coords or by
-;; one DEPL (the difference between indexes).
-
-(defvar landmark-board-width nil
- "Number of columns on the Landmark board.")
-(defvar landmark-board-height nil
- "Number of lines on the Landmark board.")
-
-(defvar landmark-board nil
- "Vector recording the actual state of the Landmark board.")
-
-(defvar landmark-vector-length nil
- "Length of landmark-board vector.")
-
-(defvar landmark-draw-limit nil
- ;; This is usually set to 70% of the number of squares.
- "After how many moves will Emacs offer a draw?")
-
-(defvar landmark-cx 0
- "This is the x coordinate of the center of the board.")
-
-(defvar landmark-cy 0
- "This is the y coordinate of the center of the board.")
-
-(defvar landmark-m 0
- "This is the x dimension of the playing board.")
-
-(defvar landmark-n 0
- "This is the y dimension of the playing board.")
-
-
-(defun landmark-xy-to-index (x y)
- "Translate X, Y cartesian coords into the corresponding board index."
- (+ (* y landmark-board-width) x y))
-
-(defun landmark-index-to-x (index)
- "Return corresponding x-coord of board INDEX."
- (% index (1+ landmark-board-width)))
-
-(defun landmark-index-to-y (index)
- "Return corresponding y-coord of board INDEX."
- (/ index (1+ landmark-board-width)))
-
-(defun landmark-init-board ()
- "Create the landmark-board vector and fill it with initial values."
- (setq landmark-board (make-vector landmark-vector-length 0))
- ;; Every square is 0 (i.e. empty) except padding squares:
- (let ((i 0) (ii (1- landmark-vector-length)))
- (while (<= i landmark-board-width) ; The squares in [0..width] and in
- (aset landmark-board i -1) ; [length - width -
1..length - 1]
- (aset landmark-board ii -1) ; are padding squares.
- (setq i (1+ i)
- ii (1- ii))))
- (let ((i 0))
- (while (< i landmark-vector-length)
- (aset landmark-board i -1) ; and also all k*(width+1)
- (setq i (+ i landmark-board-width 1)))))
-
-;;;_ + DISPLAYING THE BOARD.
-
-;; You may change these values if you have a small screen or if the squares
-;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1).
-
-(defconst landmark-square-width 2
- "Horizontal spacing between squares on the Landmark board.")
-
-(defconst landmark-square-height 1
- "Vertical spacing between squares on the Landmark board.")
-
-(defconst landmark-x-offset 3
- "Number of columns between the Landmark board and the side of the window.")
-
-(defconst landmark-y-offset 1
- "Number of lines between the Landmark board and the top of the window.")
-
-
-;;;_ + LANDMARK MODE AND KEYMAP.
-
-(defcustom landmark-mode-hook nil
- "If non-nil, its value is called on entry to Landmark mode."
- :type 'hook)
-
-(defvar landmark-mode-map
- (let ((map (make-sparse-keymap)))
- ;; Key bindings for cursor motion.
- (define-key map "y" 'landmark-move-nw) ; y
- (define-key map "u" 'landmark-move-ne) ; u
- (define-key map "b" 'landmark-move-sw) ; b
- (define-key map "n" 'landmark-move-se) ; n
- (define-key map "h" 'backward-char) ; h
- (define-key map "l" 'forward-char) ; l
- (define-key map "j" 'landmark-move-down) ; j
- (define-key map "k" 'landmark-move-up) ; k
-
- (define-key map [kp-7] 'landmark-move-nw)
- (define-key map [kp-9] 'landmark-move-ne)
- (define-key map [kp-1] 'landmark-move-sw)
- (define-key map [kp-3] 'landmark-move-se)
- (define-key map [kp-4] 'backward-char)
- (define-key map [kp-6] 'forward-char)
- (define-key map [kp-2] 'landmark-move-down)
- (define-key map [kp-8] 'landmark-move-up)
-
- (define-key map "\C-n" 'landmark-move-down) ; C-n
- (define-key map "\C-p" 'landmark-move-up) ; C-p
-
- ;; Key bindings for entering Human moves.
- (define-key map "X" 'landmark-human-plays) ; X
- (define-key map "x" 'landmark-human-plays) ; x
-
- (define-key map " " 'landmark-start-robot) ; SPC
- (define-key map [down-mouse-1] 'landmark-start-robot)
- (define-key map [drag-mouse-1] 'landmark-click)
- (define-key map [mouse-1] 'landmark-click)
- (define-key map [down-mouse-2] 'landmark-click)
- (define-key map [mouse-2] 'landmark-mouse-play)
- (define-key map [drag-mouse-2] 'landmark-mouse-play)
-
- (define-key map [remap previous-line] 'landmark-move-up)
- (define-key map [remap next-line] 'landmark-move-down)
- (define-key map [remap beginning-of-line] 'landmark-beginning-of-line)
- (define-key map [remap end-of-line] 'landmark-end-of-line)
- (define-key map [remap undo] 'landmark-human-takes-back)
- (define-key map [remap advertised-undo] 'landmark-human-takes-back)
- map)
- "Local keymap to use in Landmark mode.")
-
-
-
-(defvar landmark-emacs-won ()
- "For making font-lock use the winner's face for the line.")
-
-(defface landmark-font-lock-face-O '((((class color)) :foreground "red")
- (t :weight bold))
- "Face to use for Emacs's O."
- :version "22.1")
-
-(defface landmark-font-lock-face-X '((((class color)) :foreground "green")
- (t :weight bold))
- "Face to use for your X."
- :version "22.1")
-
-(defvar landmark-font-lock-keywords
- '(("O" . 'landmark-font-lock-face-O)
- ("X" . 'landmark-font-lock-face-X)
- ("[-|/\\]" 0 (if landmark-emacs-won
- 'landmark-font-lock-face-O
- 'landmark-font-lock-face-X)))
- "Font lock rules for Landmark.")
-
-;; This one is for when they set view-read-only to t: Landmark cannot
-;; allow View Mode to be activated in its buffer.
-(define-derived-mode landmark-mode special-mode "Lm"
- "Major mode for playing Lm against Emacs.
-You and Emacs play in turn by marking a free square. You mark it with X
-and Emacs marks it with O. The winner is the first to get five contiguous
-marks horizontally, vertically or in diagonal.
-
-You play by moving the cursor over the square you choose and hitting
\\[landmark-human-plays].
-
-Other useful commands:
-\\{landmark-mode-map}
-Entry to this mode calls the value of `landmark-mode-hook' if that value
-is non-nil. One interesting value is `turn-on-font-lock'."
- (landmark-display-statistics)
- (setq-local font-lock-defaults '(landmark-font-lock-keywords t))
- (setq buffer-read-only t)
- (add-hook 'post-command-hook #'landmark--intangible nil t))
-
-
-;;;_ + THE SCORE TABLE.
-
-
-;; Every (free) square has a score associated to it, recorded in the
-;; LANDMARK-SCORE-TABLE vector. The program always plays in the square having
-;; the highest score.
-
-(defvar landmark-score-table nil
- "Vector recording the actual score of the free squares.")
-
-
-;; The key point point about the algorithm is that, rather than considering
-;; the board as just a set of squares, we prefer to see it as a "space" of
-;; internested 5-tuples of contiguous squares (called qtuples).
-;;
-;; The aim of the program is to fill one qtuple with its O's while preventing
-;; you from filling another one with your X's. To that effect, it computes a
-;; score for every qtuple, with better qtuples having better scores. Of
-;; course, the score of a qtuple (taken in isolation) is just determined by
-;; its contents as a set, i.e. not considering the order of its elements. The
-;; highest score is given to the "OOOO" qtuples because playing in such a
-;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
-;; not playing in it is just losing the game, and so on. Note that a
-;; "polluted" qtuple, i.e. one containing at least one X and at least one O,
-;; has score zero because there is no more any point in playing in it, from
-;; both an attacking and a defending point of view.
-;;
-;; Given the score of every qtuple, the score of a given free square on the
-;; board is just the sum of the scores of all the qtuples to which it belongs,
-;; because playing in that square is playing in all its containing qtuples at
-;; once. And it is that function which takes into account the internesting of
-;; the qtuples.
-;;
-;; This algorithm is rather simple but anyway it gives a not so dumb level of
-;; play. It easily extends to "n-dimensional Landmark", where a win should not
-;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !)
-;; should be preferred.
-
-
-;; Here are the scores of the nine "non-polluted" configurations. Tuning
-;; these values will change (hopefully improve) the strength of the program
-;; and may change its style (rather aggressive here).
-
-(defconst landmark-nil-score 7 "Score of an empty qtuple.")
-
-(defconst landmark-score-trans-table
- (let ((Xscore 15) ; Score of a qtuple containing one X.
- (XXscore 400) ; Score of a qtuple containing two X's.
- (XXXscore 1800) ; Score of a qtuple containing three X's.
- (XXXXscore 100000) ; Score of a qtuple containing four X's.
- (Oscore 35) ; Score of a qtuple containing one O.
- (OOscore 800) ; Score of a qtuple containing two O's.
- (OOOscore 15000) ; Score of a qtuple containing three O's.
- (OOOOscore 800000)) ; Score of a qtuple containing four O's.
-
- ;; These values are not just random: if, given the following situation:
- ;;
- ;; . . . . . . . O .
- ;; . X X a . . . X .
- ;; . . . X . . . X .
- ;; . . . X . . . X .
- ;; . . . . . . . b .
- ;;
- ;; you want Emacs to play in "a" and not in "b", then the parameters must
- ;; satisfy the inequality:
- ;;
- ;; 6 * XXscore > XXXscore + XXscore
- ;;
- ;; because "a" mainly belongs to six "XX" qtuples (the others are less
- ;; important) while "b" belongs to one "XXX" and one "XX" qtuples.
- ;; Other conditions are required to obtain sensible moves, but the
- ;; previous example should illustrate the point. If you manage to
- ;; improve on these values, please send me a note. Thanks.
-
-
- ;; As we chose values 0, 1 and 6 to denote empty, X and O squares,
- ;; the contents of a qtuple are uniquely determined by the sum of
- ;; its elements and we just have to set up a translation table.
- (vector landmark-nil-score Xscore XXscore XXXscore XXXXscore 0
- Oscore 0 0 0 0 0
- OOscore 0 0 0 0 0
- OOOscore 0 0 0 0 0
- OOOOscore 0 0 0 0 0
- 0))
- "Vector associating qtuple contents to their score.")
-
-
-;; If you do not modify drastically the previous constants, the only way for a
-;; square to have a score higher than OOOOscore is to belong to a "OOOO"
-;; qtuple, thus to be a winning move. Similarly, the only way for a square to
-;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX"
-;; qtuple. We may use these considerations to detect when a given move is
-;; winning or losing.
-
-(defconst landmark-winning-threshold
- (aref landmark-score-trans-table (+ 6 6 6 6)) ;; OOOOscore
- "Threshold score beyond which an Emacs move is winning.")
-
-(defconst landmark-losing-threshold
- (aref landmark-score-trans-table (+ 1 1 1 1)) ;; XXXXscore
- "Threshold score beyond which a human move is winning.")
-
-
-(defun landmark-strongest-square ()
- "Compute index of free square with highest score, or nil if none."
- ;; We just have to loop other all squares. However there are two problems:
- ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed
- ;; up future searches, we set the score of padding or occupied squares
- ;; to -1 whenever we meet them.
- ;; 2/ We want to choose randomly between equally good moves.
- (let ((score-max 0)
- (count 0) ; Number of equally good moves
- (square (landmark-xy-to-index 1 1)) ; First square
- (end (landmark-xy-to-index landmark-board-width
landmark-board-height))
- best-square score)
- (while (<= square end)
- (cond
- ;; If score is lower (i.e. most of the time), skip to next:
- ((< (aref landmark-score-table square) score-max))
- ;; If score is better, beware of non free squares:
- ((> (setq score (aref landmark-score-table square)) score-max)
- (if (zerop (aref landmark-board square)) ; is it free ?
- (setq count 1 ; yes: take it !
- best-square square
- score-max score)
- (aset landmark-score-table square -1))) ; no: kill it !
- ;; If score is equally good, choose randomly. But first check freedom:
- ((not (zerop (aref landmark-board square)))
- (aset landmark-score-table square -1))
- ((zerop (random (setq count (1+ count))))
- (setq best-square square
- score-max score)))
- (setq square (1+ square))) ; try next square
- best-square))
-
-;;;_ - INITIALIZING THE SCORE TABLE.
-
-;; At initialization the board is empty so that every qtuple amounts for
-;; nil-score. Therefore, the score of any square is nil-score times the number
-;; of qtuples that pass through it. This number is 3 in a corner and 20 if you
-;; are sufficiently far from the sides. As computing the number is time
-;; consuming, we initialize every square with 20*nil-score and then only
-;; consider squares at less than 5 squares from one side. We speed this up by
-;; taking symmetry into account.
-;; Also, as it is likely that successive games will be played on a board with
-;; same size, it is a good idea to save the initial SCORE-TABLE configuration.
-
-(defvar landmark-saved-score-table nil
- "Recorded initial value of previous score table.")
-
-(defvar landmark-saved-board-width nil
- "Recorded value of previous board width.")
-
-(defvar landmark-saved-board-height nil
- "Recorded value of previous board height.")
-
-
-(defun landmark-init-score-table ()
- "Create the score table vector and fill it with initial values."
- (if (and landmark-saved-score-table ; Has it been stored last time ?
- (= landmark-board-width landmark-saved-board-width)
- (= landmark-board-height landmark-saved-board-height))
- (setq landmark-score-table (copy-sequence landmark-saved-score-table))
- ;; No, compute it:
- (setq landmark-score-table
- (make-vector landmark-vector-length (* 20 landmark-nil-score)))
- (let (i j maxi maxj maxi2 maxj2)
- (setq maxi (/ (1+ landmark-board-width) 2)
- maxj (/ (1+ landmark-board-height) 2)
- maxi2 (min 4 maxi)
- maxj2 (min 4 maxj))
- ;; We took symmetry into account and could use it more if the board
- ;; would have been square and not rectangular !
- ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U
- ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the
- ;; board may well be less than 8 by 8 !
- (setq i 1)
- (while (<= i maxi2)
- (setq j 1)
- (while (<= j maxj)
- (landmark-init-square-score i j)
- (setq j (1+ j)))
- (setq i (1+ i)))
- (while (<= i maxi)
- (setq j 1)
- (while (<= j maxj2)
- (landmark-init-square-score i j)
- (setq j (1+ j)))
- (setq i (1+ i))))
- (setq landmark-saved-score-table (copy-sequence landmark-score-table)
- landmark-saved-board-width landmark-board-width
- landmark-saved-board-height landmark-board-height)))
-
-(defun landmark-nb-qtuples (i j)
- "Return the number of qtuples containing square I,J."
- ;; This function is complicated because we have to deal
- ;; with ugly cases like 3 by 6 boards, but it works.
- ;; If you have a simpler (and correct) solution, send it to me. Thanks !
- (let ((left (min 4 (1- i)))
- (right (min 4 (- landmark-board-width i)))
- (up (min 4 (1- j)))
- (down (min 4 (- landmark-board-height j))))
- (+ -12
- (min (max (+ left right) 3) 8)
- (min (max (+ up down) 3) 8)
- (min (max (+ (min left up) (min right down)) 3) 8)
- (min (max (+ (min right up) (min left down)) 3) 8))))
-
-(defun landmark-init-square-score (i j)
- "Give initial score to square I,J and to its mirror images."
- (let ((ii (1+ (- landmark-board-width i)))
- (jj (1+ (- landmark-board-height j)))
- (sc (* (landmark-nb-qtuples i j) (aref landmark-score-trans-table 0))))
- (aset landmark-score-table (landmark-xy-to-index i j) sc)
- (aset landmark-score-table (landmark-xy-to-index ii j) sc)
- (aset landmark-score-table (landmark-xy-to-index i jj) sc)
- (aset landmark-score-table (landmark-xy-to-index ii jj) sc)))
-;;;_ - MAINTAINING THE SCORE TABLE.
-
-
-;; We do not provide functions for computing the SCORE-TABLE given the
-;; contents of the BOARD. This would involve heavy nested loops, with time
-;; proportional to the size of the board. It is better to update the
-;; SCORE-TABLE after each move. Updating needs not modify more than 36
-;; squares: it is done in constant time.
-
-(defun landmark-update-score-table (square dval)
- "Update score table after SQUARE received a DVAL increment."
- ;; The board has already been updated when this function is called.
- ;; Updating scores is done by looking for qtuples boundaries in all four
- ;; directions and then calling update-score-in-direction.
- ;; Finally all squares received the right increment, and then are up to
- ;; date, except possibly for SQUARE itself if we are taking a move back for
- ;; its score had been set to -1 at the time.
- (let* ((x (landmark-index-to-x square))
- (y (landmark-index-to-y square))
- (imin (max -4 (- 1 x)))
- (jmin (max -4 (- 1 y)))
- (imax (min 0 (- landmark-board-width x 4)))
- (jmax (min 0 (- landmark-board-height y 4))))
- (landmark-update-score-in-direction imin imax
- square 1 0 dval)
- (landmark-update-score-in-direction jmin jmax
- square 0 1 dval)
- (landmark-update-score-in-direction (max imin jmin) (min imax jmax)
- square 1 1 dval)
- (landmark-update-score-in-direction (max (- 1 y) -4
- (- x landmark-board-width))
- (min 0 (- x 5)
- (- landmark-board-height y 4))
- square -1 1 dval)))
-
-(defun landmark-update-score-in-direction (left right square dx dy dval)
- "Update scores for all squares in the qtuples in range.
-That is, those between the LEFTth square and the RIGHTth after SQUARE,
-along the DX, DY direction, considering that DVAL has been added on SQUARE."
- ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well
- ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that
- ;; DX,DY direction.
- (cond
- ((> left right)) ; Quit
- (t ; Else ..
- (let (depl square0 square1 square2 count delta)
- (setq depl (landmark-xy-to-index dx dy)
- square0 (+ square (* left depl))
- square1 (+ square (* right depl))
- square2 (+ square0 (* 4 depl)))
- ;; Compute the contents of the first qtuple:
- (setq square square0
- count 0)
- (while (<= square square2)
- (setq count (+ count (aref landmark-board square))
- square (+ square depl)))
- (while (<= square0 square1)
- ;; Update the squares of the qtuple beginning in SQUARE0 and ending
- ;; in SQUARE2.
- (setq delta (- (aref landmark-score-trans-table count)
- (aref landmark-score-trans-table (- count dval))))
- (cond ((not (zerop delta)) ; or else nothing to update
- (setq square square0)
- (while (<= square square2)
- (if (zerop (aref landmark-board square)) ; only for free
squares
- (aset landmark-score-table square
- (+ (aref landmark-score-table square) delta)))
- (setq square (+ square depl)))))
- ;; Then shift the qtuple one square along DEPL, this only requires
- ;; modifying SQUARE0 and SQUARE2.
- (setq square2 (+ square2 depl)
- count (+ count (- (aref landmark-board square0))
- (aref landmark-board square2))
- square0 (+ square0 depl)))))))
-
-;;;
-;;; GAME CONTROL.
-;;;
-
-;; Several variables are used to monitor a game, including a GAME-HISTORY (the
-;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back
-;; (anti-updating the score table) and to compute the table from scratch in
-;; case of an interruption.
-
-(defvar landmark-game-in-progress nil
- "Non-nil if a game is in progress.")
-
-(defvar landmark-game-history nil
- "A record of all moves that have been played during current game.")
-
-(defvar landmark-number-of-moves nil
- "Number of moves already played in current game.")
-
-(defvar landmark-number-of-human-moves nil
- "Number of moves already played by human in current game.")
-
-(defvar landmark-emacs-played-first nil
- "Non-nil if Emacs played first.")
-
-(defvar landmark-human-took-back nil
- "Non-nil if Human took back a move during the game.")
-
-(defvar landmark-human-refused-draw nil
- "Non-nil if Human refused Emacs offer of a draw.")
-
-(defvar landmark-emacs-is-computing nil
- ;; This is used to detect interruptions. Hopefully, it should not be needed.
- "Non-nil if Emacs is in the middle of a computation.")
-
-
-(defun landmark-start-game (n m)
- "Initialize a new game on an N by M board."
- (setq landmark-emacs-is-computing t) ; Raise flag
- (setq landmark-game-in-progress t)
- (setq landmark-board-width n
- landmark-board-height m
- landmark-vector-length (1+ (* (+ m 2) (1+ n)))
- landmark-draw-limit (/ (* 7 n m) 10))
- (setq landmark-emacs-won nil
- landmark-game-history nil
- landmark-number-of-moves 0
- landmark-number-of-human-moves 0
- landmark-emacs-played-first nil
- landmark-human-took-back nil
- landmark-human-refused-draw nil)
- (landmark-init-display n m) ; Display first: the rest takes time
- (landmark-init-score-table) ; INIT-BOARD requires that the score
- (landmark-init-board) ; table be already created.
- (setq landmark-emacs-is-computing nil))
-
-(defun landmark-play-move (square val &optional dont-update-score)
- "Go to SQUARE, play VAL and update everything."
- (setq landmark-emacs-is-computing t) ; Raise flag
- (cond ((= 1 val) ; a Human move
- (setq landmark-number-of-human-moves (1+
landmark-number-of-human-moves)))
- ((zerop landmark-number-of-moves) ; an Emacs move. Is it first ?
- (setq landmark-emacs-played-first t)))
- (setq landmark-game-history
- (cons (cons square (aref landmark-score-table square))
- landmark-game-history)
- landmark-number-of-moves (1+ landmark-number-of-moves))
- (landmark-plot-square square val)
- (aset landmark-board square val) ; *BEFORE* UPDATE-SCORE !
- (if dont-update-score nil
- (landmark-update-score-table square val) ; previous val was 0: dval = val
- (aset landmark-score-table square -1))
- (setq landmark-emacs-is-computing nil))
-
-(defun landmark-take-back ()
- "Take back last move and update everything."
- (setq landmark-emacs-is-computing t)
- (let* ((last-move (car landmark-game-history))
- (square (car last-move))
- (oldval (aref landmark-board square)))
- (if (= 1 oldval)
- (setq landmark-number-of-human-moves (1-
landmark-number-of-human-moves)))
- (setq landmark-game-history (cdr landmark-game-history)
- landmark-number-of-moves (1- landmark-number-of-moves))
- (landmark-plot-square square 0)
- (aset landmark-board square 0) ; *BEFORE* UPDATE-SCORE !
- (landmark-update-score-table square (- oldval))
- (aset landmark-score-table square (cdr last-move)))
- (setq landmark-emacs-is-computing nil))
-
-
-;;;_ + SESSION CONTROL.
-
-(defvar landmark-number-of-trials 0
- "The number of times that landmark has been run.")
-
-(defvar landmark-sum-of-moves 0
- "The total number of moves made in all games.")
-
-(defvar landmark-number-of-emacs-wins 0
- "Number of games Emacs won in this session.")
-
-(defvar landmark-number-of-human-wins 0
- "Number of games you won in this session.")
-
-(defvar landmark-number-of-draws 0
- "Number of games already drawn in this session.")
-
-
-(defun landmark-terminate-game (result)
- "Terminate the current game with RESULT."
- (setq landmark-number-of-trials (1+ landmark-number-of-trials))
- (setq landmark-sum-of-moves (+ landmark-sum-of-moves
landmark-number-of-moves))
- (if (eq result 'crash-game)
- (message
- "Sorry, I have been interrupted and cannot resume that game..."))
- (landmark-display-statistics)
- ;;(ding)
- (setq landmark-game-in-progress nil))
-
-(defun landmark-crash-game ()
- "What to do when Emacs detects it has been interrupted."
- (setq landmark-emacs-is-computing nil)
- (landmark-terminate-game 'crash-game)
- (sit-for 4) ; Let's see the message
- (landmark-prompt-for-other-game))
-
-
-;;;_ + INTERACTIVE COMMANDS.
-
-(defun landmark-emacs-plays ()
- "Compute Emacs next move and play it."
- (interactive)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((not landmark-game-in-progress)
- (landmark-prompt-for-other-game))
- (t
- (message "Let me think...")
- (let ((square (landmark-strongest-square))
- score)
- (cond ((null square)
- (landmark-terminate-game 'nobody-won))
- (t
- (setq score (aref landmark-score-table square))
- (landmark-play-move square 6)
- (cond ((>= score landmark-winning-threshold)
- (setq landmark-emacs-won t) ; for font-lock
- (landmark-find-filled-qtuple square 6)
- (landmark-terminate-game 'emacs-won))
- ((zerop score)
- (landmark-terminate-game 'nobody-won))
- ((and (> landmark-number-of-moves landmark-draw-limit)
- (not landmark-human-refused-draw)
- (landmark-offer-a-draw))
- (landmark-terminate-game 'draw-agreed))
- (t
- (landmark-prompt-for-move)))))))))
-
-;; For small square dimensions this is approximate, since though measured in
-;; pixels, event's (X . Y) is a character's top-left corner.
-(defun landmark-click (click)
- "Position at the square where you click."
- (interactive "e")
- (and (windowp (posn-window (setq click (event-end click))))
- (numberp (posn-point click))
- (select-window (posn-window click))
- (setq click (posn-col-row click))
- (landmark-goto-xy
- (min (max (/ (+ (- (car click)
- landmark-x-offset
- 1)
- (window-hscroll)
- landmark-square-width
- (% landmark-square-width 2)
- (/ landmark-square-width 2))
- landmark-square-width)
- 1)
- landmark-board-width)
- (min (max (/ (+ (- (cdr click)
- landmark-y-offset
- 1)
- (count-lines (point-min) (window-start))
- landmark-square-height
- (% landmark-square-height 2)
- (/ landmark-square-height 2))
- landmark-square-height)
- 1)
- landmark-board-height))))
-
-(defun landmark-mouse-play (click)
- "Play at the square where you click."
- (interactive "e")
- (if (landmark-click click)
- (landmark-human-plays)))
-
-(defun landmark-human-plays ()
- "Signal to the Landmark program that you have played.
-You must have put the cursor on the square where you want to play.
-If the game is finished, this command requests for another game."
- (interactive)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((not landmark-game-in-progress)
- (landmark-prompt-for-other-game))
- (t
- (let ((square (landmark-point-square))
- score)
- (cond ((null square)
- (error "Your point is not on a square. Retry!"))
- ((not (zerop (aref landmark-board square)))
- (error "Your point is not on a free square. Retry!"))
- (t
- (setq score (aref landmark-score-table square))
- (landmark-play-move square 1)
- (cond ((and (>= score landmark-losing-threshold)
- ;; Just testing SCORE > THRESHOLD is not enough for
- ;; detecting wins, it just gives an indication that
- ;; we confirm with LANDMARK-FIND-FILLED-QTUPLE.
- (landmark-find-filled-qtuple square 1))
- (landmark-terminate-game 'human-won))
- (t
- (landmark-emacs-plays)))))))))
-
-(defun landmark-human-takes-back ()
- "Signal to the Landmark program that you wish to take back your last move."
- (interactive)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((not landmark-game-in-progress)
- (message "Too late for taking back...")
- (sit-for 4)
- (landmark-prompt-for-other-game))
- ((zerop landmark-number-of-human-moves)
- (message "You have not played yet... Your move?"))
- (t
- (message "One moment, please...")
- ;; It is possible for the user to let Emacs play several consecutive
- ;; moves, so that the best way to know when to stop taking back moves is
- ;; to count the number of human moves:
- (setq landmark-human-took-back t)
- (let ((number landmark-number-of-human-moves))
- (while (= number landmark-number-of-human-moves)
- (landmark-take-back)))
- (landmark-prompt-for-move))))
-
-(defun landmark-human-resigns ()
- "Signal to the Landmark program that you may want to resign."
- (interactive)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((not landmark-game-in-progress)
- (message "There is no game in progress"))
- ((y-or-n-p "You mean, you resign? ")
- (landmark-terminate-game 'human-resigned))
- ((y-or-n-p "You mean, we continue? ")
- (landmark-prompt-for-move))
- (t
- (landmark-terminate-game 'human-resigned)))) ; OK. Accept it
-
-;;;_ + PROMPTING THE HUMAN PLAYER.
-
-(defun landmark-prompt-for-move ()
- "Display a message asking for Human's move."
- (message (if (zerop landmark-number-of-human-moves)
- "Your move? (move to a free square and hit X, RET ...)"
- "Your move?")))
-
-(defun landmark-prompt-for-other-game ()
- "Ask for another game, and start it."
- (if (y-or-n-p "Another game? ")
- (if (y-or-n-p "Retain learned weights ")
- (landmark 2)
- (landmark 1))
- (message "Chicken!")))
-
-(defun landmark-offer-a-draw ()
- "Offer a draw and return t if Human accepted it."
- (or (y-or-n-p "I offer you a draw. Do you accept it? ")
- (not (setq landmark-human-refused-draw t))))
-
-
-(defun landmark-max-width ()
- "Largest possible board width for the current window."
- (1+ (/ (- (window-width)
- landmark-x-offset landmark-x-offset 1)
- landmark-square-width)))
-
-(defun landmark-max-height ()
- "Largest possible board height for the current window."
- (1+ (/ (- (window-height)
- landmark-y-offset landmark-y-offset 2)
- ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line !
- landmark-square-height)))
-
-(defun landmark-point-y ()
- "Return the board row where point is."
- (1+ (/ (- (count-lines (point-min) (point))
- landmark-y-offset (if (bolp) 0 1))
- landmark-square-height)))
-
-(defun landmark-point-square ()
- "Return the index of the square point is on."
- (landmark-xy-to-index (1+ (/ (- (current-column) landmark-x-offset)
- landmark-square-width))
- (landmark-point-y)))
-
-(defun landmark-goto-square (index)
- "Move point to square number INDEX."
- (landmark-goto-xy (landmark-index-to-x index) (landmark-index-to-y index)))
-
-(defun landmark-goto-xy (x y)
- "Move point to square at X, Y coords."
- (goto-char (point-min))
- (forward-line (+ landmark-y-offset (* landmark-square-height (1- y))))
- (move-to-column (+ landmark-x-offset (* landmark-square-width (1- x)))))
-
-(defun landmark-plot-square (square value)
- "Draw `X', `O' or `.' on SQUARE depending on VALUE, leave point there."
- (or (= value 1)
- (landmark-goto-square square))
- (let ((inhibit-read-only t))
- (insert (cond ((= value 1) ?.)
- ((= value 2) ?N)
- ((= value 3) ?S)
- ((= value 4) ?E)
- ((= value 5) ?W)
- ((= value 6) ?^)))
-
- (and (zerop value)
- (add-text-properties (1- (point)) (point)
- '(mouse-face highlight
- help-echo "\
-mouse-1: get robot moving, mouse-2: play on this square")))
- (delete-char 1)
- (backward-char 1))
- (sit-for 0)) ; Display NOW
-
-(defun landmark-init-display (n m)
- "Display an N by M Landmark board."
- (buffer-disable-undo (current-buffer))
- (let ((inhibit-read-only t)
- (point (point-min)) opoint
- (i m) j x)
- ;; Try to minimize number of chars (because of text properties)
- (setq tab-width
- (if (zerop (% landmark-x-offset landmark-square-width))
- landmark-square-width
- (max (/ (+ (% landmark-x-offset landmark-square-width)
- landmark-square-width 1)
- 2)
- 2)))
- (erase-buffer)
- (insert-char ?\n landmark-y-offset)
- (while (progn
- (setq j n
- x (- landmark-x-offset landmark-square-width))
- (while (>= (setq j (1- j)) 0)
- (insert-char ?\t (/ (- (setq x (+ x landmark-square-width))
- (current-column))
- tab-width))
- (insert-char ?\s (- x (current-column)))
- (and (zerop j)
- (= i (- m 2))
- (progn
- (while (>= i 3)
- (append-to-buffer (current-buffer) opoint (point))
- (setq i (- i 2)))
- (goto-char (point-max))))
- (setq point (point))
- (insert ?=)
- (add-text-properties point (point)
- '(mouse-face highlight help-echo "\
-mouse-1: get robot moving, mouse-2: play on this square")))
- (> (setq i (1- i)) 0))
- (if (= i (1- m))
- (setq opoint point))
- (insert-char ?\n landmark-square-height))
- (insert-char ?\n))
- (landmark-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
- (sit-for 0)) ; Display NOW
-
-(defun landmark-display-statistics ()
- "Obnoxiously display some statistics about previous games in mode line."
- ;; We store this string in the mode-line-process local variable.
- ;; This is certainly not the cleanest way out ...
- (setq mode-line-process
- (format ": Trials: %d, Avg#Moves: %d"
- landmark-number-of-trials
- (if (zerop landmark-number-of-trials)
- 0
- (/ landmark-sum-of-moves landmark-number-of-trials))))
- (force-mode-line-update))
-
-(defun landmark-switch-to-window ()
- "Find or create the Landmark buffer, and display it."
- (interactive)
- (let ((buff (get-buffer "*Landmark*")))
- (if buff ; Buffer exists:
- (switch-to-buffer buff) ; no problem.
- (if landmark-game-in-progress
- (landmark-crash-game)) ; buffer has been killed or
something
- (switch-to-buffer "*Landmark*") ; Anyway, start anew.
- (landmark-mode))))
-
-
-;;;_ + CROSSING WINNING QTUPLES.
-
-;; When someone succeeds in filling a qtuple, we draw a line over the five
-;; corresponding squares. One problem is that the program does not know which
-;; squares ! It only knows the square where the last move has been played and
-;; who won. The solution is to scan the board along all four directions.
-
-(defun landmark-find-filled-qtuple (square value)
- "Return t if SQUARE belongs to a qtuple filled with VALUEs."
- (or (landmark-check-filled-qtuple square value 1 0)
- (landmark-check-filled-qtuple square value 0 1)
- (landmark-check-filled-qtuple square value 1 1)
- (landmark-check-filled-qtuple square value -1 1)))
-
-(defun landmark-check-filled-qtuple (square value dx dy)
- "Return t if SQUARE belongs to a qtuple filled with VALUEs along DX, DY."
- (let ((a 0) (b 0)
- (left square) (right square)
- (depl (landmark-xy-to-index dx dy)))
- (while (and (> a -4) ; stretch tuple left
- (= value (aref landmark-board (setq left (- left depl)))))
- (setq a (1- a)))
- (while (and (< b (+ a 4)) ; stretch tuple right
- (= value (aref landmark-board (setq right (+ right depl)))))
- (setq b (1+ b)))
- (cond ((= b (+ a 4)) ; tuple length = 5 ?
- (landmark-cross-qtuple (+ square (* a depl)) (+ square (* b depl))
- dx dy)
- t))))
-
-(defun landmark-cross-qtuple (square1 square2 dx dy)
- "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction."
- (save-excursion ; Not moving point from last square
- (let ((depl (landmark-xy-to-index dx dy))
- (inhibit-read-only t))
- ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1
- (while (/= square1 square2)
- (landmark-goto-square square1)
- (setq square1 (+ square1 depl))
- (cond
- ((= dy 0) ; Horizontal
- (forward-char 1)
- (insert-char ?- (1- landmark-square-width) t)
- (delete-region (point) (progn
- (skip-chars-forward " \t")
- (point))))
- ((= dx 0) ; Vertical
- (let ((landmark-n 1)
- (column (current-column)))
- (while (< landmark-n landmark-square-height)
- (setq landmark-n (1+ landmark-n))
- (forward-line 1)
- (indent-to column)
- (insert ?|))))
- ((= dx -1) ; 1st Diagonal
- (indent-to (prog1 (- (current-column) (/ landmark-square-width 2))
- (forward-line (/ landmark-square-height 2))))
- (insert ?/))
- (t ; 2nd Diagonal
- (indent-to (prog1 (+ (current-column) (/ landmark-square-width 2))
- (forward-line (/ landmark-square-height 2))))
- (insert ?\\))))))
- (sit-for 0)) ; Display NOW
-
-
-;;;_ + CURSOR MOTION.
-
-(defvar-local landmark--last-pos 0)
-
-(defconst landmark--intangible-chars "- \t\n|/\\\\")
-
-(defun landmark--intangible ()
- (when (or (eobp)
- (save-excursion
- (not (zerop (skip-chars-forward landmark--intangible-chars)))))
- (if (<= landmark--last-pos (point)) ;Moving forward.
- (progn
- (skip-chars-forward landmark--intangible-chars)
- (when (eobp)
- (skip-chars-backward landmark--intangible-chars)
- (forward-char -1)))
- (skip-chars-backward landmark--intangible-chars)
- (if (bobp)
- (skip-chars-forward landmark--intangible-chars)
- (forward-char -1))))
- (setq landmark--last-pos (point)))
-
-;; previous-line and next-line don't work right with intangible newlines
-(defun landmark-move-down ()
- "Move point down one row on the Landmark board."
- (interactive)
- (if (< (landmark-point-y) landmark-board-height)
- (let ((col (current-column)))
- (forward-line 1) ;;; landmark-square-height
- (move-to-column col))))
-
-(defun landmark-move-up ()
- "Move point up one row on the Landmark board."
- (interactive)
- (if (> (landmark-point-y) 1)
- (let ((col (current-column)))
- (forward-line (- landmark-square-height))
- (move-to-column col))))
-
-(defun landmark-move-ne ()
- "Move point North East on the Landmark board."
- (interactive)
- (landmark-move-up)
- (forward-char))
-
-(defun landmark-move-se ()
- "Move point South East on the Landmark board."
- (interactive)
- (landmark-move-down)
- (forward-char))
-
-(defun landmark-move-nw ()
- "Move point North West on the Landmark board."
- (interactive)
- (landmark-move-up)
- (backward-char))
-
-(defun landmark-move-sw ()
- "Move point South West on the Landmark board."
- (interactive)
- (landmark-move-down)
- (backward-char))
-
-(defun landmark-beginning-of-line ()
- "Move point to first square on the Landmark board row."
- (interactive)
- (move-to-column landmark-x-offset))
-
-(defun landmark-end-of-line ()
- "Move point to last square on the Landmark board row."
- (interactive)
- (move-to-column (+ landmark-x-offset
- (* landmark-square-width (1- landmark-board-width)))))
-
-
-;;;_ + Simulation variables
-
-;;;_ - landmark-nvar
-(defvar landmark-nvar 0.0075
- "Not used.
-Affects a noise generator which was used in an earlier incarnation of
-this program to add a random element to the way moves were made.")
-;;;_ - lists of cardinal directions
-;;;_ :
-(defvar landmark-ns '(landmark-n landmark-s)
- "Used when doing something relative to the north and south axes.")
-(defvar landmark-ew '(landmark-e landmark-w)
- "Used when doing something relative to the east and west axes.")
-(defvar landmark-directions '(landmark-n landmark-s landmark-e landmark-w)
- "The cardinal directions.")
-(defvar landmark-8-directions
- '((landmark-n) (landmark-n landmark-w) (landmark-w) (landmark-s landmark-w)
- (landmark-s) (landmark-s landmark-e) (landmark-e) (landmark-n landmark-e))
- "The full 8 possible directions.")
-
-(defvar landmark-number-of-moves
- "The number of moves made by the robot so far.")
-
-
-;;;_* Terry's mods to create lm.el
-
-;;;(setq landmark-debug nil)
-(defvar landmark-debug nil
- "If non-nil, debugging is printed.")
-(defcustom landmark-one-moment-please nil
- "If non-nil, print \"One moment please\" when a new board is generated.
-The drawback of this is you don't see how many moves the last run took
-because it is overwritten by \"One moment please\"."
- :type 'boolean)
-(defcustom landmark-output-moves t
- "If non-nil, output number of moves so far on a move-by-move basis."
- :type 'boolean)
-
-
-(defun landmark-weights-debug ()
- (if landmark-debug
- (progn (landmark-print-wts) (landmark-blackbox)
(landmark-print-y-s-noise)
- (landmark-print-smell))))
-
-;;;_ - Printing various things
-(defun landmark-print-distance-int (direction)
- (interactive)
- (insert (format "%S %S " direction (get direction 'distance))))
-
-
-(defun landmark-print-distance ()
- (insert (format "tree: %S \n" (landmark-calc-distance-of-robot-from
'landmark-tree)))
- (mapc #'landmark-print-distance-int landmark-directions))
-
-
-;;(setq direction 'landmark-n)
-;;(get 'landmark-n 'landmark-s)
-(defun landmark-nslify-wts-int (direction)
- (mapcar (lambda (target-direction)
- (get direction target-direction))
- landmark-directions))
-
-
-(defun landmark-nslify-wts ()
- (interactive)
- (let ((l (apply #'append
- (mapcar #'landmark-nslify-wts-int landmark-directions))))
- (insert (format "set data_value WTS \n %s \n" l))
- (insert (format "/* max: %S min: %S */"
- (apply #'max l) (apply #'min l)))))
-
-(defun landmark-print-wts-int (direction)
- (mapc (lambda (target-direction)
- (insert (format "%S %S %S "
- direction
- target-direction
- (get direction target-direction))))
- landmark-directions)
- (insert "\n"))
-
-(defun landmark-print-wts ()
- (interactive)
- (with-current-buffer "*landmark-wts*"
- (insert "==============================\n")
- (mapc #'landmark-print-wts-int landmark-directions)))
-
-(defun landmark-print-moves (moves)
- (interactive)
- (with-current-buffer "*landmark-moves*"
- (insert (format "%S\n" moves))))
-
-
-(defun landmark-print-y-s-noise-int (direction)
- (insert (format "%S:landmark-y %S, s %S, noise %S \n"
- (symbol-name direction)
- (get direction 'y_t)
- (get direction 's)
- (get direction 'noise)
- )))
-
-(defun landmark-print-y-s-noise ()
- (interactive)
- (with-current-buffer "*landmark-y,s,noise*"
- (insert "==============================\n")
- (mapc #'landmark-print-y-s-noise-int landmark-directions)))
-
-(defun landmark-print-smell-int (direction)
- (insert (format "%S: smell: %S \n"
- (symbol-name direction)
- (get direction 'smell))))
-
-(defun landmark-print-smell ()
- (interactive)
- (with-current-buffer "*landmark-smell*"
- (insert "==============================\n")
- (insert (format "tree: %S \n" (get 'z 't)))
- (mapc #'landmark-print-smell-int landmark-directions)))
-
-(defun landmark-print-w0-int (direction)
- (insert (format "%S: w0: %S \n"
- (symbol-name direction)
- (get direction 'w0))))
-
-(defun landmark-print-w0 ()
- (interactive)
- (with-current-buffer "*landmark-w0*"
- (insert "==============================\n")
- (mapc #'landmark-print-w0-int landmark-directions)))
-
-(defun landmark-blackbox ()
- (with-current-buffer "*landmark-blackbox*"
- (insert "==============================\n")
- (insert "I smell: ")
- (mapc (lambda (direction)
- (if (> (get direction 'smell) 0)
- (insert (format "%S " direction))))
- landmark-directions)
- (insert "\n")
-
- (insert "I move: ")
- (mapc (lambda (direction)
- (if (> (get direction 'y_t) 0)
- (insert (format "%S " direction))))
- landmark-directions)
- (insert "\n")
- (landmark-print-wts-blackbox)
- (insert (format "z_t-z_t-1: %S" (- (get 'z 't) (get 'z 't-1))))
- (landmark-print-distance)
- (insert "\n")))
-
-(defun landmark-print-wts-blackbox ()
- (interactive)
- (mapc #'landmark-print-wts-int landmark-directions))
-
-;;;_ - learning parameters
-(defcustom landmark-bound 0.005
- "The maximum that w0j may be."
- :type 'number)
-(defcustom landmark-c 1.0
- "A factor applied to modulate the increase in wij.
-Used in the function landmark-update-normal-weights."
- :type 'number)
-(defcustom landmark-c-naught 0.5
- "A factor applied to modulate the increase in w0j.
-Used in the function landmark-update-naught-weights."
- :type 'number)
-(defvar landmark-initial-w0 0.0)
-(defvar landmark-initial-wij 0.0)
-(defcustom landmark-no-payoff 0
- "The amount of simulation cycles that have occurred with no movement.
-Used to move the robot when he is stuck in a rut for some reason."
- :type 'integer)
-(defcustom landmark-max-stall-time 2
- "The maximum number of cycles that the robot can remain stuck in a place.
-After this limit is reached, landmark-random-move is called to push him out of
it."
- :type 'integer)
-
-
-;;;_ + Randomizing functions
-;;;_ - landmark-flip-a-coin ()
-(defun landmark-flip-a-coin ()
- (if (> (random 5000) 2500)
- -1
- 1))
-;;;_ : landmark-very-small-random-number ()
-;(defun landmark-very-small-random-number ()
-; (/
-; (* (/ (random 900000) 900000.0) .0001)))
-;;;_ : landmark-randomize-weights-for (direction)
-(defun landmark-randomize-weights-for (direction)
- (mapc (lambda (target-direction)
- (put direction
- target-direction
- (* (landmark-flip-a-coin) (/ (random 10000) 10000.0))))
- landmark-directions))
-;;;_ : landmark-noise ()
-(defun landmark-noise ()
- (* (- (/ (random 30001) 15000.0) 1) landmark-nvar))
-
-;;;_ : landmark-fix-weights-for (direction)
-(defun landmark-fix-weights-for (direction)
- (mapc (lambda (target-direction)
- (put direction
- target-direction
- landmark-initial-wij))
- landmark-directions))
-
-
-;;;_ + Plotting functions
-;;;_ - landmark-plot-internal (sym)
-(defun landmark-plot-internal (sym)
- (landmark-plot-square (landmark-xy-to-index
- (get sym 'x)
- (get sym 'y))
- (get sym 'sym)))
-;;;_ - landmark-plot-landmarks ()
-(defun landmark-plot-landmarks ()
- (setq landmark-cx (/ landmark-board-width 2))
- (setq landmark-cy (/ landmark-board-height 2))
-
- (put 'landmark-n 'x landmark-cx)
- (put 'landmark-n 'y 1)
- (put 'landmark-n 'sym 2)
-
- (put 'landmark-tree 'x landmark-cx)
- (put 'landmark-tree 'y landmark-cy)
- (put 'landmark-tree 'sym 6)
-
- (put 'landmark-s 'x landmark-cx)
- (put 'landmark-s 'y landmark-board-height)
- (put 'landmark-s 'sym 3)
-
- (put 'landmark-w 'x 1)
- (put 'landmark-w 'y (/ landmark-board-height 2))
- (put 'landmark-w 'sym 5)
-
- (put 'landmark-e 'x landmark-board-width)
- (put 'landmark-e 'y (/ landmark-board-height 2))
- (put 'landmark-e 'sym 4)
-
- (mapc #'landmark-plot-internal
- '(landmark-n landmark-s landmark-e landmark-w landmark-tree)))
-
-
-
-;;;_ + Distance-calculation functions
-
-;;;_ - distance (x x0 y y0)
-(defun landmark--distance (x x0 y y0)
- (let ((dx (- x x0)) (dy (- y y0)))
- (sqrt (+ (* dx dx) (* dy dy)))))
-
-;;;_ - landmark-calc-distance-of-robot-from (direction)
-(defun landmark-calc-distance-of-robot-from (direction)
- (put direction 'distance
- (landmark--distance (get direction 'x)
- (landmark-index-to-x (landmark-point-square))
- (get direction 'y)
- (landmark-index-to-y (landmark-point-square)))))
-
-;;;_ - landmark-calc-smell-internal (sym)
-(defun landmark-calc-smell-internal (sym)
- (let ((r (get sym 'r))
- (d (landmark-calc-distance-of-robot-from sym)))
- (if (> (* 0.5 (- 1 (/ d r))) 0)
- (* 0.5 (- 1 (/ d r)))
- 0)))
-
-
-;;;_ + Learning (neural) functions
-(defun landmark-f (x)
- (cond
- ((> x landmark-bound) landmark-bound)
- ((< x 0.0) 0.0)
- (t x)))
-
-(defun landmark-y (direction)
- (put direction 'noise (landmark-noise))
- (put direction 'y_t
- (if (> (get direction 's) 0.0)
- 1.0
- 0.0)))
-
-(defun landmark-update-normal-weights (direction)
- (mapc (lambda (target-direction)
- (put direction target-direction
- (+
- (get direction target-direction)
- (* landmark-c
- (- (get 'z 't) (get 'z 't-1))
- (get target-direction 'y_t)
- (get direction 'smell)))))
- landmark-directions))
-
-(defun landmark-update-naught-weights (direction)
- (mapc (lambda (_target-direction)
- (put direction 'w0
- (landmark-f
- (+
- (get direction 'w0)
- (* landmark-c-naught
- (- (get 'z 't) (get 'z 't-1))
- (get direction 'y_t))))))
- landmark-directions))
-
-
-;;;_ + Statistics gathering and creating functions
-
-(defun landmark-calc-current-smells ()
- (mapc (lambda (direction)
- (put direction 'smell (landmark-calc-smell-internal direction)))
- landmark-directions))
-
-(defun landmark-calc-payoff ()
- (put 'z 't-1 (get 'z 't))
- (put 'z 't (landmark-calc-smell-internal 'landmark-tree))
- (if (= (- (get 'z 't) (get 'z 't-1)) 0.0)
- (cl-incf landmark-no-payoff)
- (setf landmark-no-payoff 0)))
-
-(defun landmark-store-old-y_t ()
- (mapc (lambda (direction)
- (put direction 'y_t-1 (get direction 'y_t)))
- landmark-directions))
-
-
-;;;_ + Functions to move robot
-
-(defun landmark-confidence-for (target-direction)
- (apply #'+
- (get target-direction 'w0)
- (mapcar (lambda (direction)
- (*
- (get direction target-direction)
- (get direction 'smell)))
- landmark-directions)))
-
-
-(defun landmark-calc-confidences ()
- (mapc (lambda (direction)
- (put direction 's (landmark-confidence-for direction)))
- landmark-directions))
-
-(defun landmark-move ()
- (if (and (= (get 'landmark-n 'y_t) 1.0) (= (get 'landmark-s 'y_t) 1.0))
- (progn
- (mapc (lambda (dir) (put dir 'y_t 0)) landmark-ns)
- (if landmark-debug
- (message "n-s normalization."))))
- (if (and (= (get 'landmark-w 'y_t) 1.0) (= (get 'landmark-e 'y_t) 1.0))
- (progn
- (mapc (lambda (dir) (put dir 'y_t 0)) landmark-ew)
- (if landmark-debug
- (message "e-w normalization"))))
-
- (mapc (lambda (pair)
- (when (> (get (car pair) 'y_t) 0)
- (funcall (car (cdr pair)))
- (landmark--intangible)))
- '(
- (landmark-n landmark-move-up)
- (landmark-s landmark-move-down)
- (landmark-e forward-char)
- (landmark-w backward-char)))
- (landmark-plot-square (landmark-point-square) 1)
- (cl-incf landmark-number-of-moves)
- (if landmark-output-moves
- (message "Moves made: %d" landmark-number-of-moves)))
-
-
-(defun landmark-random-move ()
- (mapc
- (lambda (direction) (put direction 'y_t 0))
- landmark-directions)
- (dolist (direction (nth (random 8) landmark-8-directions))
- (put direction 'y_t 1.0))
- (landmark-move))
-
-(defun landmark-amble-robot ()
- (interactive)
- (while (> (landmark-calc-distance-of-robot-from 'landmark-tree) 0)
-
- (landmark-store-old-y_t)
- (landmark-calc-current-smells)
-
- (if (> landmark-no-payoff landmark-max-stall-time)
- (landmark-random-move)
- (progn
- (landmark-calc-confidences)
- (mapc #'landmark-y landmark-directions)
- (landmark-move)))
-
- (landmark-calc-payoff)
-
- (mapc #'landmark-update-normal-weights landmark-directions)
- (mapc #'landmark-update-naught-weights landmark-directions)
- (if landmark-debug
- (landmark-weights-debug)))
- (landmark-terminate-game nil))
-
-
-;;;_ - landmark-start-robot ()
-(defun landmark-start-robot ()
- "Signal to the Landmark program that you have played.
-You must have put the cursor on the square where you want to play.
-If the game is finished, this command requests for another game."
- (interactive)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((not landmark-game-in-progress)
- (landmark-prompt-for-other-game))
- (t
- (let ((square (landmark-point-square)))
- (cond ((null square)
- (error "Your point is not on a square. Retry!"))
- ((not (zerop (aref landmark-board square)))
- (error "Your point is not on a free square. Retry!"))
- (t
- (progn
- (landmark-plot-square square 1)
-
- (landmark-store-old-y_t)
- (landmark-calc-current-smells)
- (put 'z 't (landmark-calc-smell-internal 'landmark-tree))
-
- (landmark-random-move)
-
- (landmark-calc-payoff)
-
- (mapc #'landmark-update-normal-weights landmark-directions)
- (mapc #'landmark-update-naught-weights landmark-directions)
- (landmark-amble-robot)
- )))))))
-
-
-;;;_ + Misc functions
-;;;_ - landmark-init (auto-start save-weights)
-(defvar landmark-tree-r "")
-
-(defun landmark-init (auto-start save-weights)
-
- (setq landmark-number-of-moves 0)
-
- (landmark-plot-landmarks)
-
- (if landmark-debug
- (save-current-buffer
- (set-buffer (get-buffer-create "*landmark-w0*"))
- (erase-buffer)
- (set-buffer (get-buffer-create "*landmark-moves*"))
- (set-buffer (get-buffer-create "*landmark-wts*"))
- (erase-buffer)
- (set-buffer (get-buffer-create "*landmark-y,s,noise*"))
- (erase-buffer)
- (set-buffer (get-buffer-create "*landmark-smell*"))
- (erase-buffer)
- (set-buffer (get-buffer-create "*landmark-blackbox*"))
- (erase-buffer)
- (set-buffer (get-buffer-create "*landmark-distance*"))
- (erase-buffer)))
-
-
- (landmark-set-landmark-signal-strengths)
-
- (dolist (direction landmark-directions)
- (put direction 'y_t 0.0))
-
- (if (not save-weights)
- (progn
- (mapc #'landmark-fix-weights-for landmark-directions)
- (dolist (direction landmark-directions)
- (put direction 'w0 landmark-initial-w0)))
- (message "Weights preserved for this run."))
-
- (if auto-start
- (progn
- (landmark-goto-xy (1+ (random landmark-board-width)) (1+ (random
landmark-board-height)))
- (landmark-start-robot))))
-
-
-;;;_ - something which doesn't work
-; no-a-worka!!
-;(defun landmark-sum-list (list)
-; (if (> (length list) 0)
-; (+ (car list) (landmark-sum-list (cdr list)))
-; 0))
-; this a worka!
-; (eval (cons '+ list))
-;;;_ - landmark-set-landmark-signal-strengths ()
-;; on a screen higher than wide, I noticed that the robot would amble
-;; left and right and not move forward. examining *landmark-blackbox*
-;; revealed that there was no scent from the north and south
-;; landmarks, hence, they need less factoring down of the effect of
-;; distance on scent.
-
-(defun landmark-set-landmark-signal-strengths ()
- (setq landmark-tree-r (* (sqrt (+ (* landmark-cx landmark-cx)
- (* landmark-cy landmark-cy)))
- 1.5))
- (mapc (lambda (direction)
- (put direction 'r (* landmark-cx 1.1)))
- landmark-ew)
- (mapc (lambda (direction)
- (put direction 'r (* landmark-cy 1.1)))
- landmark-ns)
- (put 'landmark-tree 'r landmark-tree-r))
-
-
-;;;_ + landmark-test-run ()
-
-;;;###autoload
-(defalias 'landmark-repeat 'landmark-test-run)
-;;;###autoload
-(defun landmark-test-run ()
- "Run 100 Landmark games, each time saving the weights from the previous
game."
- (interactive)
- (landmark 1)
- (dotimes (_ 100)
- (landmark 2)))
-
-;;;###autoload
-(defun landmark (parg)
- "Start or resume an Landmark game.
-If a game is in progress, this command allows you to resume it.
-Here is the relation between prefix args and game options:
-
-prefix arg | robot is auto-started | weights are saved from last game
----------------------------------------------------------------------
-none / 1 | yes | no
- 2 | yes | yes
- 3 | no | yes
- 4 | no | no
-
-You start by moving to a square and typing \\[landmark-start-robot],
-if you did not use a prefix arg to ask for automatic start.
-Use \\[describe-mode] for more info."
- (interactive "p")
-
- (setf landmark-n nil landmark-m nil)
- (landmark-switch-to-window)
- (cond
- (landmark-emacs-is-computing
- (landmark-crash-game))
- ((or (not landmark-game-in-progress)
- (<= landmark-number-of-moves 2))
- (let ((max-width (landmark-max-width))
- (max-height (landmark-max-height)))
- (or landmark-n (setq landmark-n max-width))
- (or landmark-m (setq landmark-m max-height))
- (cond ((< landmark-n 1)
- (error "I need at least 1 column"))
- ((< landmark-m 1)
- (error "I need at least 1 row"))
- ((> landmark-n max-width)
- (error "I cannot display %d columns in that window" landmark-n)))
- (if (and (> landmark-m max-height)
- (not (eq landmark-m landmark-saved-board-height))
- ;; Use EQ because SAVED-BOARD-HEIGHT may be nil
- (not (y-or-n-p (format "Do you really want %d rows? "
landmark-m))))
- (setq landmark-m max-height)))
- (if landmark-one-moment-please
- (message "One moment, please..."))
- (landmark-start-game landmark-n landmark-m)
- (apply #'landmark-init
- (cond
- ((= parg 1) '(t nil))
- ((= parg 2) '(t t))
- ((= parg 3) '(nil t))
- ((= parg 4) '(nil nil))
- (t '(nil t)))))))
-
-
-;;;_ + Local variables
-
-;;; The following `allout-layout' local variable setting:
-;;; - closes all topics from the first topic to just before the third-to-last,
-;;; - shows the children of the third to last (config vars)
-;;; - and the second to last (code section),
-;;; - and closes the last topic (this local-variables section).
-;;;Local variables:
-;;;allout-layout: (0 : -1 -1 0)
-;;;End:
-
-(provide 'landmark)
-
-;;; landmark.el ends here
diff --git a/packages/lex/lex-parse-re.el b/packages/lex/lex-parse-re.el
deleted file mode 100644
index e5e954a..0000000
--- a/packages/lex/lex-parse-re.el
+++ /dev/null
@@ -1,258 +0,0 @@
-;;; lex-parse-re.el --- Parse Emacs regexps using Lex
-
-;; Copyright (C) 2008,2013 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This exports lex-parse-re, but it also defines lex--parse-charset which is
-;; used internally by lex-compile to handle charsets specified as a string.
-
-;;; Code:
-
-(require 'lex)
-
-;;; Regexp parsers.
-
-(defun lex--tokenizer (lex string)
- (let ((tokens ())
- (i 0)
- tmp)
- (while (and (< i (length string))
- (setq tmp (lex-match-string lex string i)))
- (push (cons (car tmp) (substring string i (setq i (cadr tmp)))) tokens))
- (nreverse tokens)))
-
-(defun lex--parse-charset (string)
- (let ((i 0)
- (ranges ()))
- (when (eq (aref string i) ?^)
- (push 'not ranges)
- (setq i (1+ i)))
- (let ((op nil)
- (case-fold-search nil))
- (while (not (eq op 'stop))
- (lex-case string i
- ((seq "[:" (0+ (char (?a . ?z) (?A . ?Z))) ":]")
- (push (intern (substring string (+ 2 (match-beginning 0))
- (- (match-end 0) 2)))
- ranges))
- ((seq anything "-" anything)
- (push (cons (aref string (match-beginning 0))
- (aref string (1- (match-end 0))))
- ranges))
- (anything (push (aref string (1- (match-end 0))) ranges))
- (eob (setq op 'stop))))
-
- `(char ,@(nreverse ranges)))))
-
-(defconst lex--parse-re-lexspec
- '(((or "*" "+" "?" "*?" "+?" "??") . suffix)
- ((seq "[" (opt "^") (opt "]")
- (0+ (or (seq (char not ?\]) "-" (char not ?\]))
- (seq "[:" (1+ (char (?a . ?z) (?A . ?Z))) ":]")
- (char not ?\]))) "]") . charset)
- ((seq "\\c" anything) . category)
- ((seq "\\C" anything) . not-category)
- ((seq "\\s" anything) . syntax)
- ((seq "\\S" anything) . not-syntax)
- ((seq "\\" (char (?1 . ?9))) . backref)
- ("\\'" . eob)
- ("\\`" . bob)
- ("." . dot)
- ("^" . bol)
- ("$" . eol)
- ("." . dot)
- ("\\<" . bow)
- ("\\>" . eow)
- ("\\_<" . symbol-start)
- ("\\_>" . symbol-end)
- ("\\w" . wordchar)
- ("\\W" . not-wordchar)
- ("\\b" . word-boundary)
- ("\\B" . not-word-boundary)
- ("\\=" . point)
- ((or (seq ?\\ anything) anything) . char)))
-
-
-(defconst lex--parse-ere-lexer
- (let ((case-fold-search nil))
- (lex-compile
- (append '(("(?:" . shy-group)
- ("|" . or)
- ((seq "{" (0+ (char (?0 . ?9)))
- (opt (seq "," (0+ (char (?0 . ?9))))) "}") . repeat)
- ((or ")" eob) . stop)
- ("(" . group))
- lex--parse-re-lexspec))))
-
-(defconst lex--parse-bre-lexer
- (let ((case-fold-search nil))
- (lex-compile
- (append '(("\\(?:" . shy-group)
- ("\\|" . or)
- ((seq "\\{" (0+ (char (?0 . ?9)))
- (opt (seq "," (0+ (char (?0 . ?9))))) "\\}") . repeat)
- ((or "\\)" eob) . stop)
- ("\\(" . group))
- lex--parse-re-lexspec))))
-
-(defun lex--parse-re (string i lexer)
- (let ((stack ())
- (op nil)
- (res nil)
- tmp)
- (while (and (not (eq op 'stop))
- (setq tmp (lex-match-string lexer string i)))
- (pcase (car tmp)
- (`shy-group
- (setq tmp (lex--parse-re string (cadr tmp) lexer))
- (unless (eq (aref string (1- (cadr tmp))) ?\))
- (error "Unclosed shy-group"))
- (push (car tmp) res))
- (`group
- (setq tmp (lex--parse-re string (cadr tmp) lexer))
- (unless (eq (aref string (1- (cadr tmp))) ?\))
- (error "Unclosed group"))
- (push (list 'group (car tmp)) res))
- (`suffix
- (if (null res) (error "Non-prefixed suffix operator")
- (setq res (cons (list (cdr (assoc (substring string i (cadr tmp))
- '(("*" . 0+)
- ("+" . 1+)
- ("?" . opt)
- ("*?" . *\?)
- ("+?" . +\?)
- ("??" . \?\?))))
- (car res))
- (cdr res)))))
- (`or (push `(or (seq ,@(nreverse res))) stack)
- (setq res nil))
- (`charset
- (push (lex--parse-charset (substring string (1+ i) (1- (cadr tmp))))
- res))
- (`repeat
- ;; Here we would like to have sub-matches :-(
- (let* ((min (string-to-number
- (substring string (+ i (if (eq (aref string i) ?\\) 2 1))
- (cadr tmp))))
- (max (let ((comma (string-match "," string i)))
- (if (not (and comma (< comma (cadr tmp))))
- min
- (if (= comma (- (cadr tmp) 2))
- nil
- (string-to-number (substring string (1+
comma))))))))
- (if (null res) (error "Non-prefixed repeat operator")
- (setq res (cons `(repeat ,min ,max ,(car res)) (cdr res))))))
- (`stop (setq op 'stop))
- ((or `syntax `category `not-syntax `not-category)
- (push (list (car tmp) (aref string (1- (cadr tmp)))) res))
- (`backref
- (push (list (car tmp) (- (aref string (1- (cadr tmp))) ?0)) res))
- (`char
- (push (aref string (1- (cadr tmp))) res))
- (_ (push (car tmp) res)))
- (setq i (cadr tmp)))
- (let ((re `(seq ,@(nreverse res))))
- (while stack (setq re (nconc (pop stack) (list re))))
- (list re i))))
-
-;;;###autoload
-(defun lex-parse-re (string &optional lexer)
- "Parse STRING as a regular expression.
-LEXER specifies the regexp syntax to use. It can be `ere', or `bre'
-and it defaults to `bre'."
- (setq lexer (cond ((eq lexer 'ere) lex--parse-ere-lexer)
- ((memq lexer '(bre re nil)) lex--parse-bre-lexer)
- (t lexer)))
- (let ((res (lex--parse-re string 0 lexer)))
- (if (< (cadr res) (length string))
- (error "Regexp parsing failed around %d: ...%s..."
- (cadr res) (substring string (1- (cadr res)) (1+ (cadr res))))
- (car res))))
-
-
-;; (defun lex--parse-re (string i)
-;; (let ((stack ())
-;; (op nil)
-;; (res nil))
-;; (while (and (not (eq op 'stop)))
-;; (lex-case string i
-;; ("(?:" ;shy-group.
-;; (let ((tmp (lex--parse-re string i)))
-;; (setq i (car tmp))
-;; (unless (eq (aref string (1- i)) ?\)) (error "Unclosed
shy-group"))
-;; (push (cdr tmp) res)))
-;; ((or "*?" "+?" "??")
-;; (error "Greediness control unsupported `%s'" (match-string 0
string)))
-;; ((or "*" "+" "?")
-;; (if (null res) (error "Non-prefixed suffix operator")
-;; (setq res (cons (list (cdr (assq (aref string (1- i))
-;; '((?* . 0+)
-;; (?+ . 1+)
-;; (?? . opt))))
-;; (car res))
-;; (cdr res)))))
-;; ("|" (push `(or (seq ,@(nreverse res))) stack)
-;; (setq res nil))
-;; ((seq "[" (opt "^") (opt "]")
-;; (0+ (or (seq (char not ?\]) "-" (char not ?\]))
-;; (seq "[:" (1+ (char (?a . ?z) (?A . ?Z))) ":]")
-;; (char not ?\]))) "]")
-;; (push (lex--parse-charset
-;; (substring string (1+ (match-beginning 0))
-;; (1- (match-end 0))))
-;; res))
-;; ((seq "{" (0+ (char (?0 . ?9)))
-;; (opt (seq "," (0+ (char (?0 . ?9))))) "}")
-;; ;; Here we would like to have sub-matches :-(
-;; (let* ((min (string-to-number (substring string
-;; (1+ (match-beginning 0))
-;; (match-end 0))))
-;; (max (let ((comma (string-match "," string (match-beginning
0))))
-;; (if (not (and comma (< comma (match-end 0))))
-;; min
-;; (if (= comma (- (match-end 0) 2))
-;; nil
-;; (string-to-number (substring string (1+
comma))))))))
-;; (if (null res) (error "Non-prefixed repeat operator")
-;; (setq res (cons `(repeat ,min ,max ,(car res)) (cdr res))))))
-;; ((or ")" eob) (setq op 'stop))
-;; ("\\'" (push 'eob res))
-;; ("\\`" (push 'bob res))
-;; ("^" (push 'bol res))
-;; ("$" (push 'eol res))
-;; ("." (push 'dot res))
-
-;; ((or "(" "\\<" "\\>" "\\_<" "\\_>" "\\c" "\\s" "\\C" "\\S" "\\w"
"\\W"
-;; "\\b" "\\B" "\\=" (seq "\\" (char (?1 . ?9))))
-;; (error "Unsupported construct `%s'" (match-string 0 string)))
-
-;; ((or (seq ?\\ anything) anything)
-;; (push (aref string (1- (match-end 0))) res))
-;; ("" (error "This should not be reachable"))))
-;; (let ((re `(seq ,@(nreverse res))))
-;; (while stack (setq re (nconc (pop stack) (list re))))
-;; (cons i re))))
-
-
-
-
-
-(provide 'lex-parse-re)
-;;; lex-parse-re.el ends here
diff --git a/packages/lex/lex.el b/packages/lex/lex.el
deleted file mode 100644
index 6ba8123..0000000
--- a/packages/lex/lex.el
+++ /dev/null
@@ -1,1269 +0,0 @@
-;;; lex.el --- Lexical analyser construction -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008,2013,2014,2015 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
-;; Version: 1.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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Format of regexps is the same as used for `rx' and `sregex'.
-;; Additions:
-;; - (ere RE) specify regexps using the ERE syntax.
-;; - (inter REs...) (aka `&') make a regexp that only matches
-;; if all its branches match. E.g. (inter (ere ".*a.*") (ere ".*b.*"))
-;; match any string that contain both an "a" and a "b", in any order.
-;; - (case-fold REs...) and (case-sensitive REs...) make a regexp that
-;; is case sensitive or not, regardless of case-fold-search.
-
-;; Input format of lexers:
-;;
-;; ALIST of the form ((RE . VAL) ...)
-
-;; Format of compiled DFA lexers:
-;;
-;; nil ; The trivial lexer that fails
-;; (CHAR . LEXER)
-;; (table . CHAR-TABLE)
-;; (stop VAL . LEXER) ; Match the empty string at point or LEXER.
-;; (check (PREDICATE . ARG) SUCCESS-LEXER . FAILURE-LEXER)
-
-;; Intermediate NFA nodes may additionally look like:
-;; (or LEXERs...)
-;; (orelse LEXERs...)
-;; (and LEXERs...)
-;; (join CONT . EXIT)
-;; Note: we call those things "NFA"s but they're not really NFAs.
-
-;;; Bugs:
-
-;; - `inter' doesn't work right. Matching `join' to the corresponding `and'
-;; is done incorrectly in some cases.
-;; - since `negate' uses intersections, it doesn't work right either.
-;; - "(\<)*" leads to a DFA that gets stuck in a cycle.
-
-;;; Todo:
-
-;; - dfa "no-fail" simplifier
-;; - dfa minimization
-;; - dfa compaction (different representation)
-;; - submatches
-;; - backrefs?
-;; - search rather than just match
-;; - extensions:
-;; - repeated submatches
-;; - negation
-;; - lookbehind and lookahead
-;; - match(&search?) backward
-;; - agrep
-
-;;; Notes
-
-
-
-;; Search
-;; ------
-
-;; To turn a match into a search, the basic idea is to use ".*RE" to get
-;; a search-DFA as opposed to the match-DFA generated from "RE".
-
-;; Search in Plan9's regexp library is done as follows: match ".*RE" until
-;; reaching the first match and then continue with only "RE". The first
-;; ".*RE" match corresponds to a search success for the leftmost shortest
-;; match. If we want the longest match, we need to continue. But if we
-;; continue with ".*RE" then we have no idea when to stop, so we should only
-;; continue with "RE".
-;; Downside: we may still match things after the "leftmost longest" match,
-;; but hopefully will stop soon after. I.e. we may look at chars past the
-;; end of the leftmost longest match, but hopefully not too many.
-
-;; Alternatives:
-;; - Like emacs/src/regexp.c, we can just start a match at every buffer
-;; position. Advantage: no need for submatch info in order to find
-;; (match-beginning 0), no need for a separate search-DFA.
-;; Downsize: O(N^2) rather than O(N). But it's no worse than what we live
-;; with for decades in src/regexp.c.
-;;
-;; - After the shortest-search, stop the search and do a longest-match
-;; starting at position (match-beginning 0). The good thing is that we
-;; will not look at any char further than needed. Also we don't need to
-;; figure out how to switch from ".*RE" to "RE" in the middle of the search.
-;; The downside is that we end up looking twice at the chars common to the
-;; shortest and longest matches. Also this doesn't work: the shortest
-;; match may not be the leftmost match, so we can't just start the match
-;; at (match-beginning 0).
-;;
-;; - Generate a specialized search&match-DFA which encodes the job done by
-;; Plan9's regexp library. I.e. do a specialized merge on
-;; (or LEXER (anything . LEXER)) where whenever we get a `stop' we don't
-;; merge any more. After matching such a lexer, we still have to figure
-;; which of the matches we had is the leftmost longest match, of course.
-;; Actually, it's not that easy: the tail of a `stop' in the match-DFA can
-;; only match things whose (match-beginning 0) may be the same as the one
-;; of the `stop', whereas we also want to accept longer matches that start
-;; before (match-beginning 0). So we want to keep merging on the tail of
-;; `stop' nodes, but only "partially" (whatever that means).
-
-;; - Better yet, do what TRE does: after the shortest-search, use the
-;; submatch data to figure out the NFA states (corresponding to the
-;; current search-DFA state) which are only reachable from later starting
-;; positions than (match-beginning 0), remove them and figure out from
-;; that the match-DFA state to which to switch. Problem is: there might
-;; not be any such state in the match-DFA.
-;;
-;; - In the end I do a mix of the last 2: .*?RE
-;; This uses the `orelse' merge operator, which contrary to `or' only
-;; matches the righthand side when the lefthand side fails to match.
-;; It turns out to be fairly simple to implement, and is optimal.
-;;
-;; Lookahead
-;; ---------
-
-;; I suspect that the (?=<RE>) lookahead can be encoded using something like
-;; `andalso'. Of course, it can also trivially be encoded as a predicate,
-;; but then we get an O(N^2) complexity.
-
-;; Merging operators.
-;; ------------------
-
-;; The NFA merging operators (or, and, orelse) seem to work fine on their own,
-;; but I'm not convinced they always DTRT when combined. It's not even
-;; clear that the NFA->DFA conversion terminates in all such cases.
-
-;; Intersection
-;; ------------
-
-;; Implementing the `inter' regexp operator turns out to be more difficult
-;; than it seemed. The problem is basically in the `join'. Each `and' has
-;; to have its own matching `join', but preserving this invariant is
-;; tricky. Among other things, we cannot flatten nested `and's like we do
-;; for `or's and `orelse's.
-
-;; Submatch info
-;; -------------
-
-;; Keeping track of submatch info with a DFA is tricky business and can slow
-;; down the matcher or make it use algorithmically more memory
-;; (e.g. O(textsize)). Here are some approaches:
-
-;; - Reproduce what an NFA matcher would do: when compiling the DFA, keep
-;; track of the NFA nodes corresponding to each DFA node, and for every
-;; transition, check the mapping between "incoming NFA nodes" and
-;; "outgoing NFA nodes" to maintain the list of submatch-info (one element
-;; per NFA node).
-
-;; - Keep a log of the states traversed during matching, so at the end it
-;; can be used to reproduce the parse tree or submatch info, based on
-;; auxiliary tables constructed during the DFA construction.
-
-;; - Some submatch info can be maintained cheaply: basically a submatch
-;; position can be represented by a single global variable in the case
-;; where we have the following property: every ε transition in the NFA
-;; which corresponds to this submatch point has the following property:
-;; no other ε transition for this same submatch can be traversed between
-;; the text position where this transition is traversed and the position
-;; where the target NFA subgraph fails to match.
-
-;;
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-
-(eval-and-compile
- (unless (fboundp 'case-table-get-table)
- ;; Copied from 24.4
- (defun case-table-get-table (case-table table)
- "Return the TABLE of CASE-TABLE.
-TABLE can be `down', `up', `eqv' or `canon'."
- (let ((slot-nb (cdr (assq table '((up . 0) (canon . 1) (eqv . 2))))))
- (or (if (eq table 'down) case-table)
- (char-table-extra-slot case-table slot-nb)
- (let ((old (standard-case-table)))
- (unwind-protect
- (progn
- (set-standard-case-table case-table)
- (char-table-extra-slot case-table slot-nb))
- (or (eq case-table old)
- (set-standard-case-table old)))))))))
-
-(defun copy-char-table (ct1)
- (let* ((subtype (char-table-subtype ct1))
- (ct2 (make-char-table subtype)))
- (map-char-table (lambda (c v) (set-char-table-range ct2 c v)) ct1)
- (dotimes (i (or (get subtype 'char-table-extra-slots) 0))
- (set-char-table-extra-slot ct2 i (char-table-extra-slot ct1 i)))
- ct2))
-
-(defun lex--char-table->alist (ct)
- (let ((res ()))
- (map-char-table (lambda (k v)
- (push (cons (if (consp k)
- ;; If k is a cons cell, we have to
- ;; copy it because map-char-table
- ;; reuses it.
- (cons (car k) (cdr k))
- ;; Otherwise, create a trivial cons-cell
- ;; so we have fewer cases to handle.
- (cons k k))
- v)
- res))
- ct)
- res))
-
-(defun lex--merge-into (op al1 al2 ct)
- (cl-assert (memq op '(and or orelse)))
- ;; We assume that map-char-table calls its function with increasing
- ;; `key' arguments.
- (while (and al1 al2)
- (let ((k1 (caar al1)) (k2 (caar al2)))
- (cond
- ;; Perfect overlap.
- ((equal k1 k2)
- (set-char-table-range ct k1
- (lex--merge op (cdr (pop al1)) (cdr (pop al2)))))
- ;; k1 strictly greater than k2.
- ((and (consp k1) (consp k2) (> (car k1) (cdr k2)))
- (let ((v (cdr (pop al1))))
- (if (not (eq op 'and)) (set-char-table-range ct k1 v))))
- ;; k2 strictly greater than k1.
- ((and (consp k1) (consp k2) (> (car k2) (cdr k1)))
- (let ((v (cdr (pop al2))))
- (if (not (eq op 'and)) (set-char-table-range ct k2 v))))
- ;; There's partial overlap.
- ((and (consp k1) (consp k2) (> (cdr k1) (cdr k2)))
- (if (not (eq op 'and))
- (set-char-table-range ct (cons (1+ (cdr k2)) (cdr k1)) (cdar al1)))
- (setcdr k1 (cdr k2)))
- ((and (consp k1) (consp k2) (< (cdr k1) (cdr k2)))
- (if (not (eq op 'and))
- (set-char-table-range ct (cons (1+ (cdr k1)) (cdr k2)) (cdar al2)))
- (setcdr k2 (cdr k1)))
- ;; Now the tails are equal.
- ((and (consp k1) (consp k2) (> (car k1) (car k2)))
- (set-char-table-range ct k1 (lex--merge op (cdr (pop al1)) (cdar al2)))
- (setcdr k2 (1- (car k1))))
- ((and (consp k1) (consp k2) (< (car k1) (car k2)))
- (set-char-table-range ct k2 (lex--merge op (cdar al1) (cdr (pop al2))))
- (setcdr k1 (1- (car k2))))
- (t (cl-assert nil)))))
- (if (not (eq op 'and))
- (dolist (x (or al1 al2))
- (set-char-table-range ct (car x) (cdr x))))
- ct)
-
-(defvar lex--states)
-(defvar lex--memoize)
-
-(defun lex--set-eq (l1 l2)
- (let ((len (length l2)))
- (setq l2 (copy-sequence l2))
- (while (consp l1)
- (cl-assert (= len (length l2)))
- (unless (> len
- (setq len (length (setq l2 (delq (pop l1) l2)))))
- (setq l1 t)))
- (not l1)))
-
-(define-hash-table-test 'lex--set-eq 'lex--set-eq
- (lambda (l)
- (let ((hash 0))
- (while l
- (let ((x (pop l)))
- (if (memq x l) (progn (debug) nil)
- (setq hash (+ hash (sxhash x))))))
- hash)))
-
-
-(defun lex--flatten-state (state)
- (cl-assert (memq (car state) '(and or orelse)))
- (let ((op (car state))
- (todo (cdr state))
- (done (list state))
- (res nil))
- (while todo
- (setq state (pop todo))
- (cond
- ((null state) (if (eq op 'and) (setq res nil todo nil)))
- ((memq state done) nil)
- ((eq (car-safe state) op)
- (push state done)
- (setq todo (append (cdr state) todo)))
- (t (unless (memq state res) (push state res)))))
- (cons op (nreverse res))))
-
-(defun lex--merge-2 (op lex1 lex2)
- (cl-assert (memq op '(and or orelse)))
- ;; The order between lex1 and lex2 matters: preference is given to lex1.
- (cond
- ;; `lex1' and `lex2' might actually be the same when we use this code to
- ;; cancel out the `and' and the `join' from lex--merge-and-join.
- ;; ((eq lex1 lex2) (debug) lex1) ;CHECK: ruled out by `lex--flatten-state'?
- ;; ((equal lex1 lex2) lex1) ;Stack overflow :-(
-
- ;; Handle the 2 possible nil cases.
- ;; CHECK: ruled out by `lex--flatten-state'?
- ((null lex1) (debug) (if (eq op 'and) nil lex2))
- ((null lex2) (debug) (if (eq op 'and) nil lex1))
-
- ;; Do the predicate cases before the `stop' because the stop should
- ;; always come after the checks.
- ;; TODO: add optimizations for pairs of `checks' which are redundant,
- ;; or mutually exclusive, ... although we can also do it in lex-optimize.
- ((and (eq (car lex1) 'check) (eq (car lex2) 'check)
- (equal (nth 1 lex1) (nth 1 lex2))) ; Same predicate.
- (cl-list* 'check (nth 1 lex1)
- (lex--merge op (nth 2 lex1) (nth 2 lex2))
- (lex--merge op (nthcdr 3 lex1) (nthcdr 3 lex2))))
- ((eq (car lex1) 'check)
- (cl-list* 'check (nth 1 lex1)
- (lex--merge op (nth 2 lex1) lex2)
- (lex--merge op (nthcdr 3 lex1) lex2)))
- ((eq (car lex2) 'check)
- (cl-list* 'check (nth 1 lex2)
- (lex--merge op lex1 (nth 2 lex2))
- (lex--merge op lex1 (nthcdr 3 lex2))))
-
- ;; Joins have the form (join CONT . EXIT) where EXIT is a lexer
- ;; corresponding to the rest of the regexp after the `and' sub-regexp.
- ;; All the joins corresponding to the same `and' have the same EXIT.
- ;; CONT is a lexer that contains another join inside, it corresponds to
- ;; the decision to not yet leave the `and'.
- ((and (eq (car lex1) 'join) (eq (car lex2) 'join))
- (cl-assert (eq (cddr lex1) (cddr lex2))) ;Check they're the same join.
- (let ((in (lex--merge op (cadr lex1) (cadr lex2))))
- (if (eq op 'and)
- ;; Eliminate the join once it was all merged.
- ;; FIXME: This arbitrarily chooses `or' instead of `orelse',
- ;; and it arbitrarily gives CONT precedence over EXIT.
- (lex--merge 'or in (cddr lex1))
- `(join ,in ,@(cddr lex1)))))
- ;; If one the two lex's is a join but the other not, the other must
- ;; contain a corresponding join somewhere inside.
- ((eq (car lex1) 'join)
- (let ((next (lex--merge op (nth 1 lex1) lex2)))
- ;; lex1 is a valid exit point but lex2 isn't.
- (if (eq op 'and)
- next
- ;; FIXME: lex1 is implicitly an `or(else)' between (cadr lex1) and
- ;; (cddr lex1). Here we construct an `or(else)' between `next' and
- ;; (cddr lex1). I.e. we lose the `op' and we do not preserve the
- ;; ordering between lex2 and (cddr lex1).
- `(join ,next ,@(cddr lex1)))))
- ((eq (car lex2) 'join)
- (let ((next (lex--merge op lex1 (nth 1 lex2))))
- (if (eq op 'and) next `(join ,next ,@(cddr lex2)))))
-
- ;; The three `stop' cases.
- ((and (eq (car lex1) 'stop) (eq (car lex2) 'stop))
- ;; Here is where we give precedence to `lex1'.
- (if (eq op 'orelse) lex1
- (cl-list* 'stop (cadr lex1) (lex--merge op (cddr lex1) (cddr lex2)))))
- ((eq (car lex1) 'stop)
- (let ((next (lex--merge op (cddr lex1) lex2)))
- (pcase op
- (`or (cl-list* 'stop (cadr lex1) next))
- (`orelse lex1)
- ;; CHECK: We should have hit a `join' before reaching a `stop'.
- (`and (debug) next)
- (_ (error "lex.el: got %S but expected one of or/and/orelse"
- op)))))
- ((eq (car lex2) 'stop)
- (let ((next (lex--merge op lex1 (cddr lex2))))
- ;; For `orelse', we want here to delay the `stop' until the point
- ;; where we know that lex1 doesn't match. Sadly, I don't know how to
- ;; do it.
- (pcase op
- ;; FIXME: One thing we can do is to mark the value attached to the
- ;; `stop' so as to indicate that an earlier match may finish later.
- ;; This way, if the match is not `earlystop', we know it's one of
- ;; the leftmost ones, and maybe the search loop can avoid some work
- ;; when determining which is the leftmost longest match.
- (`orelse (cl-list* 'stop `(earlystop ,(cadr lex2)) next))
- ((or `or `orelse) (cl-list* 'stop (cadr lex2) next))
- ;; CHECK: We should have hit a `join' before reaching a `stop'.
- (`and (debug) next)
- (_ (error "lex.el: got %S but expected one of or/and/orelse"
- op)))))
-
- ;; The most general case.
- ((and (eq (car lex1) 'table) (eq (car lex2) 'table))
- (let ((al1 (lex--char-table->alist (cdr lex1)))
- (al2 (lex--char-table->alist (cdr lex2)))
- (ct (make-char-table 'lexer)))
- (lex--merge-into op al1 al2 ct)
- (cons 'table ct)))
-
- ((and (characterp (car lex1)) (characterp (car lex2))
- (eq (car lex1) (car lex2)))
- (cons (car lex1) (lex--merge op (cdr lex1) (cdr lex2))))
- ((and (characterp (car lex1)) (characterp (car lex2)))
- (unless (eq op 'and)
- (let ((ct (make-char-table 'lexer)))
- (aset ct (car lex1) (cdr lex1))
- (aset ct (car lex2) (cdr lex2))
- (cons 'table ct))))
- ((and (characterp (car lex1)) (eq (car lex2) 'table))
- (let ((next (lex--merge op (cdr lex1) (aref (cdr lex2) (car lex1)))))
- (if (eq op 'and)
- (if next (cons (car lex1) next))
- (let ((ct (copy-sequence (cdr lex2))))
- (aset ct (car lex1) next)
- (cons 'table ct)))))
- ((and (eq (car lex1) 'table) (characterp (car lex2)))
- (let ((next (lex--merge op (aref (cdr lex1) (car lex2)) (cdr lex2))))
- (if (eq op 'and)
- (if next (cons (car lex2) next))
- (let ((ct (copy-sequence (cdr lex1))))
- (aset ct (car lex2) next)
- (cons 'table ct)))))
-
- ((or (memq (car lex1) '(or orelse and)) ;state
- (memq (car lex2) '(or orelse and))) ;state
- ;; `state' nodes are nodes whose content is not known yet, so we
- ;; have to delay the merge via the memoization table.
- ;; `or' and `and' nodes should only happen when the other `op' is being
- ;; performed, in which case we can't do the merge either before lex1
- ;; and lex2 have both been merged.
- (lex--merge op lex1 lex2))
- (t (cl-assert nil))))
-
-(defun lex--merge-now (&rest state)
- (cl-assert (memq (car state) '(and or orelse)))
- ;; Re-flatten, in case one of the sub-states was changed.
- (setq state (lex--flatten-state state))
- (if (<= (length state) 2)
- (if (eq (car state) 'and)
- ;; Need to strip out the `join's.
- (lex--merge-and-join (cadr state))
- (cadr state))
- (let ((op (pop state))
- (res (pop state)))
- (dolist (lex state)
- ;; CHECK: we fold the lexers using left-associativity.
- ;; For `orelse', that means that `earlystop' never accumulates,
- ;; whereas if we folded in a right-associative way, we could get
- ;; some (earlystop (earlystop (earlystop V))). Not sure which one's
- ;; preferable, so let's stick with what we have for now.
- (setq res (lex--merge-2 op res lex)))
- res)))
-
-(defun lex--merge-and-join (lex)
- (lex--merge-2 'and lex lex))
-
-
-(defun lex--merge (&rest state)
- (cl-assert (memq (car state) '(and or orelse)))
- (setq state (lex--flatten-state state))
- (if (and (<= (length state) 2)
- (not (eq (car state) 'and)))
- (cadr state)
- (or (gethash state lex--memoize)
- (progn
- ;; (debug)
- (cl-assert (memq (car state) '(and or orelse)))
- (push state lex--states)
- ;; The `state' node will be later on modified via setcar/setcdr,
- ;; se be careful to use a copy of it for the key.
- (puthash (cons (car state) (cdr state)) state lex--memoize)
- state))))
-
-(defun lex--compile-category (category)
- (if (and (integerp category) (< category 128))
- category
- (if (symbolp category)
- (if (= 1 (length (symbol-name category)))
- (aref (symbol-name category) 0)
- (require 'rx)
- (defvar rx-categories)
- (cdr (assq category rx-categories))))))
-
-(defun lex--compile-syntax (&rest syntaxes)
- (mapcar (lambda (x)
- (if (and (integerp x) (< x 32)) x
- (if (symbolp x)
- (setq x (if (= 1 (length (symbol-name x)))
- (symbol-name x)
- (require 'rx)
- (defvar rx-syntax)
- (cdr (assq x rx-syntax)))))
- (if (characterp x) (setq x (string x)))
- (car (string-to-syntax x))))
- syntaxes))
-
-(defconst lex--char-classes
- `((alnum alpha digit)
- (alpha word (?a . ?z) (?A . ?Z))
- (blank ?\s ?\t)
- (cntrl (?\0 . ?\C-_))
- (digit (?0 . ?9))
- ;; Include all multibyte chars, plus all the bytes except 128-159.
- (graph (?! . ?~) multibyte (#x3fffa0 . #x3fffff))
- ;; src/regexp.c handles case-folding inconsistently: lower and upper
- ;; match both lower- and uppercase ascii chars, but lower also matches
- ;; uppercase non-ascii chars whereas upper does not match lowercase
- ;; nonascii chars. Here I simply ignore case-fold for [:lower:] and
- ;; [:upper:] because it's simpler and doesn't seem worse.
- (lower (check (lex--match-lower)))
- (upper (check (lex--match-upper)))
- (print graph ?\s)
- (punct (check (not (lex--match-syntax . ,(lex--compile-syntax "w"))))
- (?! . ?/) (?: . ?@) (?\[ . ?`) (?\{ . ?~))
- (space (check (lex--match-syntax . ,(lex--compile-syntax " "))))
- (xdigit digit (?a . ?f) (?A . ?F))
- (ascii (?\0 . ?\177))
- (nonascii (?\200 . #x3fffff))
- (unibyte ascii (#x3fff00 . #x3fffff))
- (multibyte (#x100 . #x3ffeff))
- (word (check (lex--match-syntax . ,(lex--compile-syntax "w"))))
- ;; `rx' alternative names.
- (numeric digit)
- (num digit)
- (control cntrl)
- (hex-digit xdigit)
- (hex xdigit)
- (graphic graph)
- (printing print)
- (alphanumeric alnum)
- (letter alpha)
- (alphabetic alpha)
- (lower-case lower)
- (upper-case upper)
- (punctuation punct)
- (whitespace space)
- (white space))
- "Definition of char classes.
-Each element has the form (CLASS . DEFINITION) where definition
-is a list of elements that can be either CHAR or (CHAR . CHAR),
-or CLASS (another char class) or (check (PREDICATE . ARG))
-or (check (not (PREDICATE . ARG))).")
-
-(defvar lex--char-equiv-table nil
- "Equiv-case table to use to compile case-insensitive regexps.")
-
-(defun lex--char-equiv (char)
- (when lex--char-equiv-table
- (let ((chars ())
- (tmp char))
- (while (and (setq tmp (aref lex--char-equiv-table tmp))
- (not (eq tmp char)))
- (push tmp chars))
- (if chars (cons char chars)))))
-
-;; For convenience we use lex itself to tokenize charset strings, so we
-;; define it in another file.
-(autoload 'lex--parse-charset "lex-parse-re")
-
-(defun lex--nfa (re state)
- (cl-assert state) ;If `state' is nil we can't match anyway.
- (cond
- ((characterp re)
- (let ((chars (lex--char-equiv re)))
- (if (null chars)
- (cons re state)
- (let ((ct (make-char-table 'lexer)))
- (dolist (char chars) (aset ct char state))
- (cons 'table ct)))))
- ((stringp re)
- (if (null lex--char-equiv-table)
- ;; (Very) minor optimization.
- (nconc (mapcar 'identity re) state)
- (lex--nfa `(seq ,@(mapcar 'identity re)) state)))
- (t
- (pcase (or (car-safe re) re)
- ((or `: `seq `sequence
- ;; Hack!
- `group)
- (dolist (elem (reverse (cdr re)))
- (setq state (lex--nfa elem state)))
- state)
- ((or `char `in `not-char)
- (let ((chars (cdr re))
- (checks nil)
- (fail nil)
- (char nil) ;The char seen, or nil if none, or t if more than one.
- (ct (make-char-table 'lexer)))
- (when (or (eq 'not (car chars)) (eq 'not-char (car re)))
- (setq chars (cdr chars))
- (set-char-table-range ct t state)
- (setq fail state)
- (setq state nil))
- (while chars
- (let ((range (pop chars)))
- (cond
- ((stringp range)
- (setq chars (append (cdr (lex--parse-charset range)) chars)))
- ((symbolp range)
- (setq range (or (cdr (assq range lex--char-classes))
- (error "Uknown char class `%s'" range)))
- (setq chars (append range chars)))
- ((and (consp range) (eq 'check (car range)))
- (push (cadr range) checks))
- (t
- (setq char (if (or char (not (characterp range))
- (and lex--char-equiv-table
- (lex--char-equiv range)))
- t range))
- ;; Set the range, first, regardless of case-folding. This is
- ;; important because case-tables like to be set with few
- ;; large ranges rather than many small ones, as is done in
- ;; the case-fold loop.
- (set-char-table-range ct range state)
- (when (and lex--char-equiv-table
- ;; Avoid looping over all characters.
- (not (equal range '(#x100 . #x3ffeff))))
- ;; Add all the case-equiv chars.
- (let ((i (if (consp range) (car range) range))
- (max (if (consp range) (cdr range) range))
- char)
- (while (<= i max)
- (setq char i)
- (while (and (setq char (aref lex--char-equiv-table char))
- (not (eq char i)))
- (aset ct char state))
- (setq i (1+ i)))))))))
-
- (let ((res (if (or (eq char t) fail)
- (cons 'table ct)
- (if char (cons char state)))))
- (if (and (not fail) checks)
- (setq state (lex--nfa 'anything state)))
- (dolist (check checks)
- (setq res
- (if fail
- ;; We do an `and' of the negation of the check and res.
- (if (eq (car-safe check) 'not)
- (list 'check (cadr check) res)
- (cl-list* 'check check nil res))
- ;; An `or' of the check and res.
- (if (eq (car-safe check) 'not)
- (list 'check (cadr check) res state)
- (cl-list* 'check check state res)))))
- res)))
-
- ((or `union `or `| `orelse)
- (let ((newstate
- (cons (if (eq (car re) 'orelse) 'orelse 'or)
- (mapcar (lambda (re) (lex--nfa re state)) (cdr re)))))
- (push newstate lex--states)
- newstate))
-
- ((or `inter `intersection `&)
- (if (<= (length re) 2)
- ;; Avoid constructing degenerate `and' nodes.
- (lex--nfa (cadr re) state)
- ;; Just using `and' is not enough because we have to enforce that the
- ;; sub-regexps (rather than the whole regexp) match the same string.
- ;; So we need to mark the juncture point.
- (let* ((join `(join nil ,@state))
- (newstate
- `(and ,@(mapcar (lambda (re) (lex--nfa re join)) (cdr re)))))
- (push newstate lex--states)
- newstate)))
-
- ((or `0+ `zero-or-more `* `*\?)
- (let ((newstate (list 'state)))
- (let ((lexer (lex--nfa (cons 'seq (cdr re)) newstate)))
- (setcdr newstate (if (memq (car re) '(*\?))
- (list state lexer)
- (list lexer state))))
- (setcar newstate (if (memq (car re) '(*\?)) 'orelse 'or))
- (push newstate lex--states)
- newstate))
-
- ((or `string-end `eos `eot `buffer-end `eob)
- `(check (lex--match-eobp) ,state))
- ((or `string-start `bos `bot `buffer-start `bob)
- `(check (lex--match-bobp) ,state))
- ((or `line-end `eol) `(check (lex--match-eolp) ,state))
- ((or `line-start `bol) `(check (lex--match-bolp) ,state))
- ((or `word-start `bow) `(check (lex--match-bowp) ,state))
- ((or `word-end `eow) `(check (lex--match-eowp) ,state))
- (`symbol-start `(check (lex--match-bosp) ,state))
- (`symbol-end `(check (lex--match-eosp) ,state))
- (`not-word-boundary `(check (lex--match-not-word-boundary) ,state))
- (`word-boundary `(check (lex--match-not-word-boundary) nil . ,state))
- (`syntax `(check (lex--match-syntax
- . ,(apply 'lex--compile-syntax (cdr re)))
- ,(lex--nfa 'anything state)))
- (`not-syntax `(check (lex--match-syntax
- . ,(apply 'lex--compile-syntax (cdr re)))
- nil . ,(lex--nfa 'anything state)))
- (`category `(check (lex--match-category
- . ,(lex--compile-category (cadr re)))
- ,(lex--nfa 'anything state)))
- (`not-category `(check (lex--match-category
- . ,(lex--compile-category (cadr re)))
- nil . ,(lex--nfa 'anything state)))
-
- ;; `rx' accepts char-classes directly as regexps. Let's reluctantly
- ;; do the same.
- ((or `digit `numeric `num `control `cntrl `hex-digit `hex `xdigit `blank
- `graphic `graph `printing `print `alphanumeric `alnum `letter
- `alphabetic `alpha `ascii `nonascii `lower `lower-case `upper
- `upper-case `punctuation `punct `space `whitespace `white)
- (lex--nfa `(char ,re) state))
-
- (`case-sensitive
- (let ((lex--char-equiv-table nil))
- (lex--nfa `(seq ,@(cdr re)) state)))
-
- (`case-fold
- (let ((lex--char-equiv-table
- (case-table-get-table (current-case-table) 'eqv)))
- (lex--nfa `(seq ,@(cdr re)) state)))
-
- ((or `point
- ;; Sub groups!
- `submatch `group `backref
- ;; Greediness control
- `minimal-match `maximal-match)
- (error "`%s' Not implemented" (or (car-safe re) re)))
-
- ((or `not-newline `nonl `dot) (lex--nfa '(char not ?\n) state))
- (`anything (lex--nfa '(char not) state))
- ((or `word `wordchar) (lex--nfa '(syntax w) state))
- (`not-wordchar (lex--nfa '(not-syntax w) state))
-
- (`any
- ;; `rx' uses it for (char ...) sets, and sregex uses it for `dot'.
- (lex--nfa (if (consp re) (cons 'char (cdr re)) '(char not ?\n)) state))
-
- (`negate
- ;; We could define negation directly on regexps, but it's easier to
- ;; do it on NFAs since those have fewer cases to deal with.
- (let ((posnfa
- ;; Trow away the mergable states generated while computing the
- ;; posnfa, since it's only an intermediate datastructure.
- (let (lex--states)
- (lex--nfa `(seq ,@(cdr re)) '(stop negate)))))
- (lex-negate posnfa state)))
-
- (`not
- ;; The `not' as used in `rx' should be deprecated so we can make it
- ;; an alias for `negate', whose semantics is different. E.g.
- ;; (negate (char ...)) matches the empty string and 2-char strings.
- (setq re (cadr re))
- (pcase (or (car-safe re) re)
- (`word-boundary
- (message "`not' deprecated: use not-word-boundary")
- (lex--nfa 'not-word-boundary state))
- ((or `any `in `char)
- (message "`not' deprecated: use (%s not ...)" (or (car-safe re) re))
- (lex--nfa (cl-list* (car re) 'not (cdr re)) state))
- ((or `category `syntax)
- (message "`not' deprecated: use not-%s" (car re))
- (lex--nfa (cons (intern (format "not-%s" (car re))) (cdr re)) state))
- (elem (error "lex.el: unexpected argument `%S' to `not'." elem))))
-
- (`and
- ;; `rx' defined `and' as `sequence', but we may want to define it
- ;; as intersection instead.
- (error "`and' is deprecated, use `seq', `:', or `sequence' instead"))
-
- ((or `1+ `one-or-more `+ `+\?)
- (lex--nfa `(seq (seq ,@(cdr re))
- (,(if (memq (car re) '(+\?)) '*\? '0+) ,@(cdr re)))
- state))
- ((or `opt `zero-or-one `optional `\?)
- (lex--nfa `(or (seq ,@(cdr re)) "") state))
- (`\?\?
- (lex--nfa `(orelse "" (seq ,@(cdr re))) state))
- ((or `repeat `** `=)
- (let ((min (nth 1 re))
- (max (nth 2 re))
- (res (nthcdr 3 re)))
- (unless res
- (setq res (list max)) (setq max min))
- (lex--nfa `(seq ,@(append (make-list (or min 0)
- (if (eq (length res) 1)
- (car res)
- (cons 'seq res)))
- (if (null max)
- `((0+ ,@res))
- (make-list (- max (or min 0))
- `(opt ,@res)))))
- state)))
- (`>= (lex--nfa `(repeat ,(nth 1 re) nil ,@(nthcdr 2 re)) state))
-
- ((or `bre `re `ere)
- (lex--nfa (lex-parse-re (nth 1 re) (car re)) state))
- (elem (error "lex.el: unknown RE element %S" elem))))))
-
-(defun lex--negate-inftail (state howmany)
- ;; We hashcons the infinite tails and store them in the memoize table.
- ;; This is an abuse, but saves us from passing it around as an
- ;; extra argument.
- (let ((inftail-1+ (gethash state lex--memoize)))
- (unless inftail-1+
- ;; Precompute the final infinitely repeating tail.
- (setq inftail-1+ `(table . ,(make-char-table 'lexer)))
- (set-char-table-range (cdr inftail-1+) t `(or ,state ,inftail-1+))
- (push (aref (cdr inftail-1+) 0) lex--states)
- (puthash state inftail-1+ lex--memoize))
- (pcase howmany
- (`1+ inftail-1+)
- (`0+ (aref (cdr inftail-1+) 0))
- (_ (error "lex.el: howmany is `%S' instead of one of 1+/0+" howmany)))))
-
-(defun lex--negate-now (nfa state)
- (pcase (car nfa)
- (`nil (lex--negate-inftail state '0+))
- (`check
- `(check ,(nth 1 nfa) ,(lex--negate-memo (nth 2 nfa) state)
- ,@(lex--negate-memo (nthcdr 3 nfa) state)))
- (`stop
- (if (cddr nfa)
- ;; This is valid but should normally not happen.
- (lex--negate-now `(or (stop ,(cadr nfa)) ,(cddr nfa)) state)
- (lex--negate-inftail state '1+)))
-
- ((or `or `orelse)
- (let ((join `(join nil . ,state)))
- `(and ,@(mapcar (lambda (nfa) (lex--negate-memo nfa join)) (cdr nfa)))))
-
- (`and
- `(or ,@(mapcar (lambda (nfa) (lex--negate-memo nfa state)) (cdr nfa))))
-
- (`join
- ;; The join says: either exit the `and' because we matched all branches,
- ;; or keep matching further. Negation makes the synchrony between
- ;; `and' branches irrelevant, so we can consider it as an `or(else)'.
- (if (cadr nfa)
- ;; This is valid but should normally not happen.
- (lex--negate-now `(or ,(cadr nfa) ,(cddr nfa)) state)
- (lex-negate (cddr nfa) state)))
- (_
- (let ((ct (make-char-table 'lexer)))
- ;; Get inftail-0+ from the hashtable.
- (set-char-table-range ct t (lex--negate-inftail state '0+))
- (if (characterp (car nfa))
- (aset ct (car nfa) (lex--negate-memo (cdr nfa) state))
- (cl-assert (eq 'table (car nfa)))
- (map-char-table (lambda (range nfa)
- (set-char-table-range ct range
- (lex--negate-memo nfa state)))
- (cdr nfa)))
- `(or ,state (table ,@ct))))))
-
-(defun lex--negate-memo (nfa state)
- ;; Make sure our `inftail' abuse of the hastable doesn't break anything.
- (cl-assert (not (eq nfa state)))
- (or (gethash nfa lex--memoize)
- (let ((newstate (cons 'state nil)))
- (puthash nfa newstate lex--memoize)
- (let ((res (lex--negate-now nfa state)))
- (when (memq (car res) '(or and orelse))
- (push newstate lex--states))
- (if (null res)
- (setq res '(?a))
- (setcar newstate (car res))
- (setcdr newstate (cdr res))
- newstate)))))
-
-(defun lex-negate (nfa state)
- "Concatenate the negation of NFA with STATE.
-Returns a new NFA."
- (let ((lex--memoize (make-hash-table :test 'eq)))
- (lex--negate-memo nfa state)))
-
-(defun lex--dfa-wrapper (f)
- (let* ((lex--states ())
- (res (funcall f))
- (postponed ())
- (lex--memoize (make-hash-table :test 'lex--set-eq))
- (states-dfa (make-hash-table :test 'eq)))
-
- (while lex--states
- (dolist (state (prog1 lex--states (setq lex--states nil)))
- (let ((merged (apply 'lex--merge-now state)))
- (if (memq (car merged) '(and or orelse))
- ;; The merge could not be performed for some reason:
- ;; let's re-schedule it.
- (push state postponed)
- (puthash state merged states-dfa))))
-
- (unless lex--states
- ;; If states-dfa is empty it means we haven't made any progress,
- ;; so we're stuck in an infinite loop. Hopefully this cannot happen?
- (cl-assert (not (zerop (hash-table-count states-dfa))))
- (maphash (lambda (k v)
- (unless v
- ;; With `intersection', lex--merge may end up returning
- ;; nil if the intersection is empty, so `v' can be
- ;; nil here. In since `k' is necessarily a cons cell,
- ;; we can't turn it into nil, so we turn it into
- ;; a more costly lexer that also fails for all inputs.
- (setq v '(?a)))
- (setcar k (car v))
- (setcdr k (cdr v)))
- states-dfa)
- (clrhash states-dfa)
- (setq lex--states postponed)
- (setq postponed nil)))
-
- res))
-
-;;;###autoload
-(defun lex-compile (alist)
- "Compile a set of regular expressions.
-ALIST is a list of elements of the form (REGEXP . VALUE).
-The compiled automaton will match all those regexps at the same time
-and will return the VALUE fof the leftmost longest match.
-
-Each REGEXP object should be in the sexp form described in the
-Commentary section."
- (lex--dfa-wrapper
- (lambda ()
- (let* ((lex--char-equiv-table
- (if case-fold-search
- (case-table-get-table (current-case-table) 'eqv)))
- (newstate
- `(or
- ,@(mapcar (lambda (x) (lex--nfa (car x) (list 'stop (cdr x))))
- alist))))
- (push newstate lex--states)
- newstate))))
-
-(defun lex-search-dfa (match-dfa)
- ;; This constructs a search-DFA whose last match should be the leftmost
- ;; longest match.
- (lex--dfa-wrapper
- (lambda ()
- (lex--nfa '(*\? (char not)) match-dfa))))
-
-
-(defun lex--terminate-if (new old)
- (cond
- ((eq new t) t)
- ((eq old t) t)
- (t (while new (let ((x (pop new))) (if (not (memq x old)) (push x old))))
- old)))
-
-(defun lex--optimize-1 (lexer)
- (let ((terminate nil))
- (cons
- (pcase (car lexer)
- (`table
- (let ((ct (cdr lexer))
- (char nil))
- ;; Optimize each entry.
- (map-char-table
- (lambda (range v)
- (let ((cell (lex--optimize v)))
- (setq terminate (lex--terminate-if (cdr cell) terminate))
- (set-char-table-range ct range (car cell))))
- ct)
- ;; Optimize the internal representation of the table.
- (optimize-char-table (cdr lexer) 'eq)
- ;; Eliminate the table if possible.
- (map-char-table
- (lambda (range _v)
- (setq char
- (if (and (characterp range) (null char))
- range t)))
- ct)
- (pcase char
- (`nil nil)
- (`t lexer)
- (_ (setcar lexer 'char) (setcdr lexer (aref ct char)) lexer))))
- (`stop
- (let ((cell (lex--optimize (cddr lexer))))
- (setq terminate t)
- (setf (cddr lexer) (car cell)))
- lexer)
- (`check
- (let* ((test (nth 1 lexer))
- (cellf (lex--optimize (nthcdr 3 lexer)))
- (fail (setf (nthcdr 3 lexer) (car cellf)))
- (cells (lex--optimize (nth 2 lexer)))
- (succ (setf (nth 2 lexer) (car cells))))
- (setq terminate (lex--terminate-if (cdr cellf) terminate))
- (setq terminate (lex--terminate-if (cdr cells) terminate))
- ;; TODO: the check-optimizations below only work on consecutive
- ;; pairs of checks. We need to be more agressive and make sure
- ;; the optimized DFA never does twice the same test at the same
- ;; position. Most importantly: don't do the same test in
- ;; a tight loop as in "(^\<)*".
- (when (eq 'check (car succ))
- (cond
- ((equal test (nth 1 succ)) ;Same successful test.
- (setf (nth 2 lexer) (setq succ (nth 2 succ))))
- ;; TODO: we can add rules such as bobp -> eolp,
- ;; bosp -> bowp, (syntax X) -> (syntax Y X), ...
- ))
- (when (eq 'check (car fail))
- (cond
- ((equal test (nth 1 fail)) ;Same failing test.
- (setf (nthcdr 3 lexer) (setq fail (nthcdr 3 succ))))
- ;; TODO: we can add rules such as !eolp -> !bobp,
- ;; !bowp -> !bosp, !(syntax Y X) -> !(syntax X), ...
- ))
- (if (or succ fail) lexer)))
- (_
- (cl-assert (characterp (car lexer)))
- (let ((cell (lex--optimize (cdr lexer))))
- (setq terminate (lex--terminate-if (cdr cell) terminate))
- (if (setf (cdr lexer) (car cell))
- lexer))))
- (if (consp terminate)
- (delq lexer terminate)
- terminate))))
-
-(defun lex--optimize (lexer)
- (when lexer
- ;; The lex--memoize cache maps lexer states to (LEXER . TERMINATE) where
- ;; TERMINATE is either t to say that LEXER can terminate or a list of
- ;; lexers which means that LEXER terminates only if one of the lexers in
- ;; the list terminates.
- (let ((cache (gethash lexer lex--memoize)))
- (if cache
- ;; Optimize (char C) to nil.
- (if (and (characterp (caar cache)) (null (cdar cache))) nil cache)
- ;; Store a value indicating that we're in the process of computing it,
- ;; so when we encounter a loop, we don't recurse indefinitely.
- ;; Not knowing any better, we start by stating the tautology that
- ;; `lexer' terminates if and only if `lexer' terminates.
- (let ((cell (cons lexer (list lexer))))
- (puthash lexer cell lex--memoize)
- (let ((res (lex--optimize-1 lexer)))
- (if (and (car res) (cdr res))
- res
- (setcar lexer ?a)
- (setcdr lexer nil)
- (puthash lexer '(nil) lex--memoize)
- nil)))))))
-
-(defun lex-optimize (lexer)
- (let ((lex--memoize (make-hash-table :test 'eq)))
- (prog1 (car (lex--optimize lexer))
- (message "Visited %d states" (hash-table-count lex--memoize)))))
-
-(defmacro lex-case (object posvar &rest cases)
- (declare (indent 2))
- (let* ((i -1)
- (alist (mapcar (lambda (case) (cons (car case) (cl-incf i))) cases))
- (lex (lex-compile alist))
- (tmpsym (make-symbol "tmp")))
- (setq i -1)
- `(let ((,tmpsym (lex-match-string ',lex ,object ,posvar)))
- (pcase (car ,tmpsym)
- ,@(mapcar (lambda (case)
- `(,(cl-incf i)
- (set-match-data
- (list ,posvar (setq ,posvar (cadr ,tmpsym))))
- ,@(cdr case)))
- cases)))))
-
-;;; Matching engine
-
-(defun lex--match-bobp (_arg pos &optional string)
- (= pos (if string 0 (point-min))))
-
-(defun lex--match-eobp (_arg pos &optional string)
- (= pos (if string (length string) (point-max))))
-
-(defun lex--match-bolp (_arg pos &optional string)
- (if string (or (= pos 0) (eq ?\n (aref string (1- pos))))
- (memq (char-before pos) '(nil ?\n))))
-
-(defun lex--match-eolp (_arg pos &optional string)
- (if string (or (= pos (length string)) (eq ?\n (aref string pos)))
- (memq (char-after pos) '(nil ?\n))))
-
-(defun lex--match-bowp (_arg pos &optional string)
- (and (not (if string (and (> pos 0)
- (eq ?w (char-syntax (aref string (1- pos)))))
- (and (> pos (point-min)) (eq 2 (car (syntax-after (1- pos)))))))
- (if string (and (< pos (length string))
- (eq ?w (char-syntax (aref string pos))))
- (eq 2 (car (syntax-after pos))))))
-
-(defun lex--match-eowp (_arg pos &optional string)
- (and (if string (and (> pos 0)
- (eq ?w (char-syntax (aref string (1- pos)))))
- (and (> pos (point-min)) (eq 2 (car (syntax-after (1- pos))))))
- (not (if string (and (< pos (length string))
- (eq ?w (char-syntax (aref string pos))))
- (eq 2 (car (syntax-after pos)))))))
-
-(defun lex--match-bosp (_arg pos &optional string)
- (and (not (if string
- (and (> pos 0)
- (memq (char-syntax (aref string (1- pos))) '(?w ?_)))
- (and (> pos (point-min))
- (memq (car (syntax-after (1- pos))) '(2 3)))))
- (if string (and (< pos (length string))
- (memq (char-syntax (aref string pos)) '(?w ?_)))
- (memq (car (syntax-after pos)) '(2 3)))))
-
-(defun lex--match-eosp (_arg pos &optional string)
- (and (if string (and (> pos 0)
- (memq (char-syntax (aref string (1- pos))) '(?w ?_)))
- (and (> pos (point-min)) (memq (car (syntax-after (1- pos))) '(2 3))))
- (not (if string (and (< pos (length string))
- (memq (char-syntax (aref string pos)) '(?w ?_)))
- (memq (car (syntax-after pos)) '(2 3))))))
-
-(defun lex--match-not-word-boundary (_arg pos &optional string)
- (eq (if string (and (> pos 0)
- (eq ?w (char-syntax (aref string (1- pos)))))
- (and (> pos (point-min)) (eq 2 (car (syntax-after (1- pos))))))
- (if string (and (< pos (length string))
- (eq ?w (char-syntax (aref string pos))))
- (eq 2 (car (syntax-after pos))))))
-
-(defun lex--match-upper (_arg pos &optional string)
- (when (< pos (if string (length string) (point-max)))
- (let ((char (if string (aref string pos) (char-after pos))))
- (not (eq (downcase char) char)))))
-
-(defun lex--match-lower (_arg pos &optional string)
- (when (< pos (if string (length string) (point-max)))
- (let ((char (if string (aref string pos) (char-after pos))))
- (not (eq (upcase char) char)))))
-
-
-(defun lex--match-category (category pos &optional string)
- (when (< pos (if string (length string) (point-max)))
- (aref (char-category-set (if string (aref string pos)
- (char-after pos)))
- category)))
-
-(defun lex--match-syntax (syntaxes pos &optional string)
- (when (< pos (if string (length string) (point-max)))
- (memq (car (if string (aref (syntax-table) (aref string pos))
- (syntax-after pos)))
- syntaxes)))
-
-
-(defun lex-match-string (lex string &optional start stop)
- "Match LEX against STRING between START and STOP.
-Return a triplet (VALUE ENDPOS . LEXER) where VALUE is the
-value of returned by the lexer for the match found (or nil), ENDPOS
-is the end position of the match found (or nil), and LEXER is the
-state of the engine at STOP, which can be passed back to
-`lex-match-string' to continue the match elsewhere."
- ;; FIXME: Move this to C.
- (unless start (setq start 0))
- (unless stop (setq stop (length string)))
- (let ((match (list nil nil))
- (lastlex lex))
- (while
- (progn
- (while (eq (car lex) 'check)
- (setq lex (if (funcall (car (nth 1 lex)) (cdr (nth 1 lex))
- start string)
- (nth 2 lex) (nthcdr 3 lex))))
- (when (eq (car lex) 'stop)
- ;; Don't stop yet, we're looking for the longest match.
- (setq match (list (cadr lex) start))
- (message "Found match: %s" match)
- (setq lex (cddr lex)))
- (cl-assert (not (eq (car lex) 'stop)))
- (and lex (< start stop)))
- (let ((c (aref string start)))
- (setq start (1+ start))
- (setq lex (cond
- ((eq (car lex) 'table) (aref (cdr lex) c))
- ((integerp (car lex)) (if (eq c (car lex)) (cdr lex)))))
- (setq lastlex lex)))
- (message "Final search pos considered: %s" start)
- ;; The difference between `lex' and `lastlex' is basically that `lex'
- ;; may depend on data after `stop' (if there was an `end-of-file' or
- ;; `word-boundary' or basically any `check'). So let's return `lastlex'
- ;; so it can be correctly used to continue the match with a different
- ;; content than what's after `stop'.
- (nconc match lastlex)))
-
-(defun lex-match-string-first (lex string &optional start stop)
- "Match LEX against STRING between START and STOP.
-Return a triplet (VALUE ENDPOS . LEXER) where VALUE is the
-value of returned by the lexer for the match found (or nil), ENDPOS
-is the end position of the match found (or nil), and LEXER is the
-state of the engine at STOP, which can be passed back to
-`lex-match-string' to continue the match elsewhere."
- ;; FIXME: Move this to C.
- (unless start (setq start 0))
- (unless stop (setq stop (length string)))
- (let ((match (list nil nil))
- (lastlex lex))
- (catch 'found
- (while
- (progn
- (while (eq (car lex) 'check)
- (setq lex (if (funcall (car (nth 1 lex)) (cdr (nth 1 lex))
- start string)
- (nth 2 lex) (nthcdr 3 lex))))
- (when (eq (car lex) 'stop)
- (throw 'found (cl-list* (cadr lex) start (cddr lex))))
- (cl-assert (not (eq (car lex) 'stop)))
- (and (not match) lex (< start stop)))
- (let ((c (aref string start)))
- (setq start (1+ start))
- (setq lex (cond
- ((eq (car lex) 'table) (aref (cdr lex) c))
- ((integerp (car lex)) (if (eq c (car lex)) (cdr lex)))))
- (setq lastlex lex)))
- ;; The difference between `lex' and `lastlex' is basically that `lex'
- ;; may depend on data after `stop' (if there was an `end-of-file' or
- ;; `word-boundary' or basically any `check'). So let's return `lastlex'
- ;; so it can be correctly used to continue the match with a different
- ;; content than what's after `stop'.
- (cl-list* nil start lastlex))))
-
-(defun lex-match-buffer (lex &optional stop)
- "Match LEX against buffer between point and STOP.
-Return a triplet (VALUE ENDPOS . LEXER) where VALUE is the
-value of returned by the lexer for the match found (or nil), ENDPOS
-is the end position of the match found (or nil), and LEXER is the
-state of the engine at STOP, which can be passed back to
-continue the match elsewhere."
- ;; FIXME: Move this to C.
- (unless stop (setq stop (point-max)))
- (let ((start (point))
- (match (list nil nil))
- (lastlex lex))
- (while
- (progn
- (while (eq (car lex) 'check)
- (setq lex (if (funcall (car (nth 1 lex)) (cdr (nth 1 lex))
- start)
- (nth 2 lex) (nthcdr 3 lex))))
- (when (eq (car lex) 'stop)
- ;; Don't stop yet, we're looking for the longest match.
- (setq match (list (cadr lex) start))
- (message "Found match: %s" match)
- (setq lex (cddr lex)))
- (cl-assert (not (eq (car lex) 'stop)))
- (and lex (< start stop)))
- (let ((c (char-after start)))
- (setq start (1+ start))
- (setq lex (cond
- ((eq (car lex) 'table) (aref (cdr lex) c))
- ((integerp (car lex)) (if (eq c (car lex)) (cdr lex)))))
- (setq lastlex lex)))
- (message "Final search pos considered: %s" start)
- ;; The difference between `lex' and `lastlex' is basically that `lex'
- ;; may depend on data after `stop' (if there was an `end-of-file' or
- ;; `word-boundary' or basically any `check'). So let's return `lastlex'
- ;; so it can be correctly used to continue the match with a different
- ;; content than what's after `stop'.
- (nconc match lastlex)))
-
-(provide 'lex)
-;;; lex.el ends here
diff --git a/packages/memory-usage/memory-usage.el
b/packages/memory-usage/memory-usage.el
deleted file mode 100644
index dd7571e..0000000
--- a/packages/memory-usage/memory-usage.el
+++ /dev/null
@@ -1,179 +0,0 @@
-;;; memory-usage.el --- Analyze the memory usage of Emacs in various ways
-
-;; Copyright (C) 2002, 2004, 2012 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@cs.yale.edu>
-;; Keywords: maint
-;; Version: 0.2
-
-;; 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:
-
-;; This package provides the command `memory-usage', which lists all
-;; buffers and how much memory they use.
-
-;;; Code:
-
-(defvar memory-usage-word-size (ceiling (/ (log most-positive-fixnum 2) 8))
- "Size of a Lisp word box in bytes.")
-
-(defun memory-usage-buffer-size-bytes (b)
- "Return total number of bytes in the buffer contents."
- (with-current-buffer b
- (save-restriction
- (widen)
- (- (position-bytes (point-max)) (position-bytes (point-min))))))
-
-(defun memory-usage-buffer-gap-bytes (b)
- "Return total number of bytes in the buffer gap."
- (with-current-buffer b
- (gap-size)))
-
-(defun memory-usage-buffer-total-bytes (b)
- "Return total number of ralloc bytes used by buffer."
- (with-current-buffer b
- (save-restriction
- (widen)
- (+ (position-bytes (point-max))
- (- (position-bytes (point-min)))
- (gap-size)))))
-
-(defun memory-usage-mult-cons (n c)
- (setq n (* n memory-usage-word-size))
- (cons (* n (car c)) (* n (cdr c))))
-
-(defun memory-usage-format (bytes)
- (setq bytes (/ bytes 1024.0))
- (let ((units '(;; "B"
- "kB" "MB" "GB" "TB")))
- (while (>= bytes 1024)
- (setq bytes (/ bytes 1024.0))
- (setq units (cdr units)))
- (cond
- ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
- ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
- ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
- (t (format "%4.2f%s" bytes (car units))))))
-
-;;;###autoload
-(defun memory-usage ()
- "List all buffers and their memory usage."
- (interactive)
- (pop-to-buffer (get-buffer-create "*Buffer Details*"))
- (erase-buffer)
- (let* ((bufs (buffer-list))
- (num (length bufs))
- (gc-stats (garbage-collect))
- (gc-stats (if (numberp (caar gc-stats))
- (mapcar (lambda (x)
- `(,(car x)
- ,(max (* memory-usage-word-size (cadr x))
- 1)
- ,@(let ((stat (nth (cddr x) gc-stats)))
- (if (consp stat)
- (list (car stat) (cdr stat))
- (list stat)))))
- '((cons 2 . 0)
- (symbol 6 . 1)
- (marker 5 . 2)
- (string 4 . 7)
- (string-byte 0 . 3)
- (vector-slot 1 . 4)
- (float 2 . 5)
- (interval 7 . 6)))
- gc-stats)))
- (insert (format "Garbage collection stats:\n%s\n\n =>" gc-stats))
- (let ((live 0)
- (dead 0))
- (dolist (x gc-stats)
- (let* ((size (nth 1 x))
- (xlive (* size (nth 2 x)))
- (xdead (if (nth 3 x) (* size (nth 3 x)))))
- (insert (if xdead
- (format "\t%s (+ %s dead) in %s\n"
- (memory-usage-format xlive)
- (memory-usage-format xdead)
- (car x))
- (format "\t%s in %s\n"
- (memory-usage-format xlive)
- (car x))))
- (setq live (+ live xlive))
- (if xdead (setq dead (+ dead xdead)))))
-
- (insert (format "\nTotal in lisp objects: %s (live %s, dead %s)\n\n"
- (memory-usage-format (+ dead live))
- (memory-usage-format live)
- (memory-usage-format dead))))
-
- (insert
- (format "Buffer ralloc memory usage:\n%d buffers\n%s total (%s in gaps)\n"
- num
- (memory-usage-format
- (apply #'+ (mapcar #'memory-usage-buffer-total-bytes bufs)))
- (memory-usage-format
- (apply #'+ (mapcar #'memory-usage-buffer-gap-bytes bufs)))))
- (insert (format "%10s\t%s\t%s\n\n" "Size" "Gap" "Name"))
- (insert (mapconcat
- (lambda (b)
- (format "%10d\t%s\t%s"
- (memory-usage-buffer-size-bytes b)
- (memory-usage-buffer-gap-bytes b)
- (buffer-name b)))
- (sort bufs (lambda (b1 b2)
- (> (memory-usage-buffer-size-bytes b1)
- (memory-usage-buffer-size-bytes b2))))
- "\n"))
- (insert "\n"))
- (goto-char (point-min)))
-
-(defun memory-usage-find-large-variables ()
- "Find variables whose printed representation takes over 100KB."
- (interactive)
- (let ((min-size (* 100 1024)))
- (pop-to-buffer "*Memory Explorer*")
- (delete-region (point-min) (point-max))
- ;; First find large global variables.
- (mapatoms
- (lambda (sym)
- (let ((size (or (and (boundp sym)
- (length (prin1-to-string (symbol-value sym))))
- 0)))
- (when (> size min-size)
- (insert (format "%d\tGlobal\t%s\n"
- size
- (symbol-name sym)))))))
- ;; Second find large buffer-local variables.
- (mapc
- (lambda (buffer)
- (let ((holder ""))
- (with-current-buffer buffer
- (mapc
- (lambda (var-cons)
- (let ((size (or (and (consp var-cons)
- (length (prin1-to-string (cdr var-cons))))
- 0)))
- (if (> size min-size)
- (setq holder (format "%d\t%s\t%s\n"
- size (buffer-name buffer)
- (symbol-name (car var-cons)))))))
- (buffer-local-variables)))
- (insert holder)))
- (buffer-list))
- (sort-numeric-fields 1 (point-min) (point-max))))
-
-(provide 'memory-usage)
-;;; memory-usage.el ends here
diff --git a/packages/minibuffer-line/minibuffer-line.el
b/packages/minibuffer-line/minibuffer-line.el
deleted file mode 100644
index 0e44318..0000000
--- a/packages/minibuffer-line/minibuffer-line.el
+++ /dev/null
@@ -1,78 +0,0 @@
-;;; minibuffer-line.el --- Display status info in the minibuffer window -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
-;; Version: 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package lets you display various status information in the minibuffer
-;; window instead of the mode-line. Of course, this is only displayed when the
-;; minibuffer window is not already used for other things (e.g. a minibuffer or
-;; an each area message).
-;;
-;; The contents and aspect is controlled by the `minibuffer-line-format'
-;; variable and the `minibuffer-line' face. Their current default kind of
-;; sucks: suggestions for improvements welcome.
-
-;;; Code:
-
-(defgroup minibuffer-line ()
- "Use the idle minibuffer window to display status information."
- :group 'mode-line)
-
-(defcustom minibuffer-line-format
- '("" (:eval system-name) " | " (:eval (format-time-string "%F %R")))
- "Specification of the contents of the minibuffer-line.
-Uses the same format as `mode-line-format'."
- :type 'sexp)
-
-(defface minibuffer-line
- '((t :inherit mode-line-inactive))
- "Face to use for the minibuffer-line.")
-
-(defcustom minibuffer-line-refresh-interval 60
- "The frequency at which the minibuffer-line is updated, in seconds."
- :type 'integer)
-
-(defconst minibuffer-line--buffer " *Minibuf-0*")
-
-(defvar minibuffer-line--timer nil)
-
-;;;###autoload
-(define-minor-mode minibuffer-line-mode
- "Display status info in the minibuffer window."
- :global t
- (with-current-buffer minibuffer-line--buffer
- (erase-buffer))
- (when minibuffer-line--timer
- (cancel-timer minibuffer-line--timer)
- (setq minibuffer-line--timer nil))
- (when minibuffer-line-mode
- (setq minibuffer-line--timer
- (run-with-timer t minibuffer-line-refresh-interval
- #'minibuffer-line--update))
- (minibuffer-line--update)))
-
-(defun minibuffer-line--update ()
- (with-current-buffer minibuffer-line--buffer
- (erase-buffer)
- (insert (format-mode-line minibuffer-line-format 'minibuffer-line))))
-
-(provide 'minibuffer-line)
-;;; minibuffer-line.el ends here
diff --git a/packages/minimap/minimap.el b/packages/minimap/minimap.el
deleted file mode 100644
index 98c8a15..0000000
--- a/packages/minimap/minimap.el
+++ /dev/null
@@ -1,937 +0,0 @@
-;;; minimap.el --- Sidebar showing a "mini-map" of a buffer
-
-;; Copyright (C) 2009-2020 Free Software Foundation, Inc.
-
-;; Author: David Engster <deng@randomsample.de>
-;; Keywords:
-;; Version: 1.4
-
-;; This file is 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, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file is an implementation of a minimap sidebar, i.e., a
-;; smaller display of the current buffer on the left side. It
-;; highlights the currently shown region and updates its position
-;; automatically. You can navigate in the minibar by dragging the
-;; active region with the mouse, which will scroll the corresponding
-;; edit buffer. Additionally, you can overlay information from the
-;; tags gathered by CEDET's semantic analyzer.
-
-;; Simply use M-x minimap-mode to toggle activation of the minimap.
-;; Use 'M-x customize-group RET minimap RET' to adapt minimap to your
-;; needs.
-
-;;; KNOWN BUGS:
-
-;; * Currently cannot deal with images.
-;; * Display/movement can be a bit erratic at times.
-
-;;; TODO:
-
-;; * Fix known bugs.
-;; * Make sidebar permanently visible. This requires something like a
-;; 'window group' feature in Emacs, which is currently being worked on.
-;; * Moving the active region with the keyboard / mouse-wheel ?
-
-
-;;; News:
-;;
-;;;; Changes since v1.2:
-;;
-;; - New option: minimap-hide-cursor (active by default)
-;; - New option: minimap-disable-mode-line (active by default)
-;; - Make current line highlighting face configurable, change to dark gray.
-;; - New default behavior for minimap-automatically-delete-window:
-;; keep minimap window as long as buffer is visible. Change variable
-;; to 't' to get old behavior.
-;; - Bug fixes
-;;
-;;;; Changes since v1.1:
-;;
-;; - Change some defaults: better colors, reduced update delay.
-;; - `minimap-tag-only': New experimental feature to only display an
-;; 'abstract view' of the buffer with overlays generated from
-;; Semantic information. Works only for buffers parsed by Semantic.
-;; - `minimap-highlight-line': Highlight current line in Minimap.
-;; - Fix autoloads.
-;; - Display lines denoting beginning/end of functions in Semantic
-;; overlays.
-;;
-;;;; Changes since v1.0:
-;;
-;; - Largely rewritten as a minor mode; use M-x minimap-mode to
-;; enable/disable.
-;; - Minimap will now remain active for all buffers which derive from
-;; `prog-mode' (can be changed through `minimap-major-modes'). The
-;; minimap window will be automatically created or deleted (see new
-;; variables `minimap-recreate-window' and
-;; `minimap-automatically-delete-window').
-;; - Possibility to set a minimum width of the minimap window
-;; (`minimap-minimum-width').
-;; - Minimap window will be marked so that you should not be able to
-;; enter it.
-;; - Semantic overlays will be automatically updated during editing.
-;; - Lots of bug fixes.
-
-;; Silence byte compiler
-(declare-function semantic-active-p "semantic/fw")
-(declare-function semantic-fetch-tags "semantic")
-(declare-function semantic-tag-class "semantic/tag")
-(declare-function semantic-tag-overlay "semantic/tag")
-(declare-function semantic-tag-name "semantic/tag")
-
-(defgroup minimap nil
- "A minimap sidebar for Emacs."
- :group 'convenience)
-
-(defface minimap-font-face
- '((default :family "DejaVu Sans Mono" :height 30))
- "Face used for text in minimap buffer, notably the font family and height.
-This height should be really small. You probably want to use a
-TrueType font for this. After changing this, you should
-recreate the minimap to avoid problems with recentering."
- :group 'minimap)
-
-(defface minimap-current-line-face
- '((((background dark)) (:background "dark gray"))
- (t (:background "dark gray")))
- "Face for the current line in the minimap.
-By default, both foreground and background are yellow."
- :group 'minimap)
-
-(defface minimap-active-region-background
- '((((background dark)) (:background "#700000" :extend t))
- (t (:background "#C847D8FEFFFF" :extend t)))
- "Face for the active region in the minimap.
-By default, this is only a different background color."
- :group 'minimap)
-
-(defface minimap-semantic-function-face
- '((((background dark))
- (:box (:line-width 1 :color "white")
- :inherit (font-lock-function-name-face minimap-font-face)
- :height 2.75 :background "#202414"))
- (t (:box (:line-width 1 :color "black")
- :inherit (font-lock-function-name-face minimap-font-face)
- :height 2.75 :background "gray90")))
- "Face used for functions in the semantic overlay.")
-
-(defface minimap-semantic-variable-face
- '((((background dark))
- (:box (:line-width 1 :color "white")
- :inherit (font-lock-variable-name-face minimap-font-face)
- :height 2.75 :background "gray10"))
- (t (:box (:line-width 1 :color "black")
- :inherit (font-lock-function-name-face minimap-font-face)
- :height 2.75 :background "gray90")))
- "Face used for variables in the semantic overlay.")
-
-(defface minimap-semantic-type-face
- '((((background dark))
- (:box (:line-width 1 :color "white")
- :inherit (font-lock-type-face minimap-font-face)
- :height 2.75 :background "gray10"))
- (t (:box (:line-width 1 :color "black")
- :inherit (font-lock-function-name-face minimap-font-face)
- :height 2.75 :background "gray90")))
- "Face used for types in the semantic overlay.")
-
-(defcustom minimap-width-fraction 0.15
- "Fraction of width which should be used for minimap sidebar."
- :type 'number
- :group 'minimap)
-
-(defcustom minimap-minimum-width 30
- "Minimum width of minimap in characters (default size).
-Use nil to disable."
- :type 'number
- :group 'minimap)
-
-(defcustom minimap-window-location 'left
- "Location of the minimap window.
-Can be either the symbol `left' or `right'."
- :type '(choice (const :tag "Left" left)
- (const :tag "Right" right))
- :group 'minimap)
-
-(defcustom minimap-buffer-name " *MINIMAP*"
- "Buffer name of minimap sidebar."
- :type 'string
- :group 'minimap)
-
-(defcustom minimap-update-delay 0.1
- "Delay in seconds after which sidebar gets updated.
-Setting this to 0 will let the minimap react immediately, but
-this will slow down scrolling."
- :type 'number
- :set (lambda (sym value)
- (set sym value)
- (when (and (boundp 'minimap-timer-object)
- minimap-timer-object)
- (cancel-timer minimap-timer-object)
- (setq minimap-timer-object
- (run-with-idle-timer
- minimap-update-delay t 'minimap-update))))
- :group 'minimap)
-
-(defcustom minimap-always-recenter nil
- "Whether minimap sidebar should be recentered after every point movement."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-recenter-type 'relative
- "Specifies the type of recentering the minimap should use.
-The minimap can use different types of recentering, i.e., how the
-minimap should behave when you scroll in the main window or when
-you drag the active region with the mouse. The following
-explanations will probably not help much, so simply try them and
-choose the one which suits you best.
-
-`relative' -- The position of the active region in the minimap
-corresponds with the relative position of this region in the
-buffer. This the default.
-
-`middle' -- The active region will stay fixed in the middle of
-the minimap.
-
-`free' -- The position will be more or less free. When dragging
-the active region, the minimap will scroll when you reach the
-bottom or top."
- :type '(choice (const :tag "Relative" relative)
- (const :tag "Middle" middle)
- (const :tag "Free" free))
- :group 'minimap)
-
-(defcustom minimap-hide-scroll-bar t
- "Whether the minimap should hide the vertical scrollbar."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-hide-fringes nil
- "Whether the minimap should hide the fringes."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-dedicated-window t
- "Whether the minimap should create a dedicated window."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-display-semantic-overlays t
- "Display overlays from CEDET's semantic analyzer.
-If you use CEDET and the buffer's major-mode is supported, the
-minimap can display overlays generated by the semantic analyzer.
-By default, it will apply the faces `minimap-semantic-<X>-face',
-with <X> being \"function\", \"variable\" and \"type\". Also, it
-will display the name of the tag in the middle of the overlay in
-the corresponding font-lock face.
-
-See also `minimap-enlarge-certain-faces', which can be used as
-fallback."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-enlarge-certain-faces 'as-fallback
- "Whether certain faces should be enlarged in the minimap.
-All faces listed in `minimap-normal-height-faces' will be
-displayed using the default font height, allowing you to still
-read text using those faces. By default, this should enlarge all
-function names in the minimap, given you have font locking
-enabled. This variable can have the following values:
-
-'as-fallback (the default) -- The feature will only be activated
- if information from CEDET's semantic analyzer isn't available
- (see: `minimap-display-semantic-overlays').
-'always -- Always active.
-nil -- Inactive."
- :type '(choice (const :tag "Fallback if CEDET unavailable." as-fallback)
- (const :tag "Always active." always)
- (const :tag "Inactive." nil))
- :group 'minimap)
-
-(defcustom minimap-normal-height-faces '(font-lock-function-name-face)
- "List of faces which should be displayed with normal height.
-When `minimap-enlarge-certain-faces' is non-nil, all faces in
-this list will be displayed using the default font height. By
-default, this list contains `font-lock-function-name-face', so
-you can still read function names in the minimap."
- :type '(repeat face)
- :group 'minimap)
-
-(defcustom minimap-sync-overlay-properties '(face invisible)
- "Specifies which overlay properties should be synced.
-Unlike text properties, overlays are not applied automatically to
-the minimap and must be explicitly synced. This variable
-specifies which overlay properties should be synced by
-`minimap-sync-overlays'. Most importantly, this variable should
-include 'invisible', so that hidden text does not appear in the
-minimap buffer."
- :type '(repeat symbol)
- :group 'minimap)
-
-(defcustom minimap-major-modes '(prog-mode)
- "Major modes for which a minimap should be created.
-This can also be a parent mode like 'prog-mode.
-If nil, a minimap must be explicitly created for each buffer."
- :type '(repeat symbol)
- :group 'minimap)
-
-(defcustom minimap-recreate-window t
- "Whether the minimap window should be automatically re-created.
-If this is non-nil, the side window for the minimap will be
-automatically re-created as soon as you kill it."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-automatically-delete-window 'visible
- "Whether the minimap window should be automatically deleted.
-You can choose between three different behaviors here: If this is
-`nil', the minimap window will never be automatically deleted. If
-this is set to symbol 'visible, the minimap stays active as long
-as the minimap's buffer is visible somewhere in the frame,
-whether it is active or not. Any other value will delete the
-minimap window as soon as you enter a buffer which is not derived
-from `minimap-major-modes' (excluding the minibuffer)."
- :type '(choice (const :tag "Never delete automatically" nil)
- (const :tag "Keep as long as buffer visible" visible)
- (const :tag "Delete when entering unsupported buffer" t))
- :group 'minimap)
-
-(defcustom minimap-tag-only nil
- "Whether the minimap should only display parsed tags from CEDET."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-highlight-line t
- "Whether the minimap should highlight the current line."
- :type 'boolean
- :group 'minimap)
-
-(defcustom minimap-disable-mode-line t
- "Whether to disable the mode-line in the minimap window."
- :type 'boolen
- :group 'minimap)
-
-(defcustom minimap-hide-cursor t
- "Whether to hide the cursor in the minimap window."
- :type 'boolen
- :group 'minimap)
-
-;;; Internal variables
-
-;; The buffer currently displayed in the minimap
-(defvar minimap-active-buffer nil)
-;; Window start/end from the base buffer
-(defvar minimap-start nil)
-(defvar minimap-end nil)
-;; General overlay for the minimap
-(defvar minimap-base-overlay nil)
-;; Overlay for the active region
-(defvar minimap-active-overlay nil)
-;; Timer
-(defvar minimap-timer-object nil)
-;; Lines the minimap can display
-(defvar minimap-numlines nil)
-(defvar minimap-pointmin-overlay nil)
-;; Line overlay
-(defvar minimap-line-overlay nil)
-
-
-;;; Helpers
-
-(defun minimap-active-current-buffer-p ()
- "Whether the current buffer is displayed in the minimap."
- (and (eq (current-buffer) minimap-active-buffer)
- (get-buffer minimap-buffer-name)
- (with-current-buffer minimap-buffer-name
- (eq minimap-active-buffer (buffer-base-buffer)))))
-
-(defsubst minimap-get-window ()
- "Get current minimap window."
- (when (get-buffer minimap-buffer-name)
- (get-buffer-window minimap-buffer-name)))
-
-(defsubst minimap-kill-buffer ()
- "Kill the minimap buffer."
- (when (get-buffer minimap-buffer-name)
- (kill-buffer minimap-buffer-name)))
-
-(defun minimap-create-window ()
- (let ((width (round (* (window-width)
- minimap-width-fraction)))
- buffer-window)
- (when (< width minimap-minimum-width)
- (setq width minimap-minimum-width))
- (if (eq minimap-window-location 'left)
- ;; The existing window becomes the minimap
- (progn
- (setq buffer-window (split-window-horizontally width))
- ;; Restore prev/next buffers in the new window
- (set-window-next-buffers buffer-window
- (window-next-buffers))
- (set-window-prev-buffers buffer-window
- (window-prev-buffers)))
- ;; The new window is the minimap
- (setq buffer-window (selected-window))
- (select-window (split-window-horizontally
- (* -1 width))))
- ;; Set up the minimap window:
- ;; You should not be able to enter the minimap window.
- (set-window-parameter nil 'no-other-window t)
- ;; Switch to buffer.
- (switch-to-buffer
- (get-buffer-create minimap-buffer-name) t t)
- ;; Do not fold lines in the minimap.
- (setq truncate-lines t)
- ;; Make it dedicated.
- (when minimap-dedicated-window
- (set-window-dedicated-p nil t))
- ;; Return minimap window, but make sure we select the window where
- ;; the buffer is in.
- (prog1
- (selected-window)
- (select-window buffer-window))))
-
-(defun minimap-setup-hooks (&optional remove)
- "Hook minimap into other modes.
-If REMOVE is non-nil, remove minimap from other modes."
- (if remove
- (progn
- (remove-hook 'outline-view-change-hook 'minimap-sync-overlays)
- (remove-hook 'hs-hide-hook 'minimap-sync-overlays)
- (remove-hook 'hs-show-hook 'minimap-sync-overlays)
- (remove-hook 'flycheck-after-syntax-check-hook 'minimap-sync-overlays))
- ;; outline-(minor-)mode
- (add-hook 'outline-view-change-hook 'minimap-sync-overlays)
- ;; hideshow
- (add-hook 'hs-hide-hook 'minimap-sync-overlays)
- (add-hook 'hs-show-hook 'minimap-sync-overlays)
- (add-hook 'flycheck-after-syntax-check-hook 'minimap-sync-overlays)))
-
-;;; Minimap creation / killing
-
-;;;###autoload
-(define-minor-mode minimap-mode
- "Toggle minimap mode."
- :global t
- :group 'minimap
- :lighter " MMap"
- (if minimap-mode
- (progn
- (when (and minimap-major-modes
- (apply 'derived-mode-p minimap-major-modes))
- (unless (minimap-get-window)
- (minimap-create-window))
- ;; Create minimap.
- (minimap-new-minimap))
- ;; Create timer.
- (setq minimap-timer-object
- (run-with-idle-timer minimap-update-delay t 'minimap-update))
- ;; Hook into other modes.
- (minimap-setup-hooks))
- ;; Turn it off
- (minimap-kill)
- (minimap-setup-hooks t)))
-
-(defun minimap-create ()
- "Create a minimap sidebar."
- (interactive)
- (minimap-mode 1))
-
-(defun minimap-new-minimap ()
- "Create new minimap BUFNAME for current buffer and window.
-Re-use already existing minimap window if possible."
- (interactive)
- (let ((currentbuffer (current-buffer))
- (win (minimap-get-window))
- (indbuf (make-indirect-buffer (current-buffer)
- (concat minimap-buffer-name "_temp")))
- (edges (window-pixel-edges)))
- ;; Remember the active buffer currently displayed in the minimap.
- (setq minimap-active-buffer (current-buffer))
- ;; Hook into CEDET if necessary.
- (when (and minimap-display-semantic-overlays
- (boundp 'semantic-after-toplevel-cache-change-hook))
- (add-hook 'semantic-after-partial-cache-change-hook
- 'minimap-apply-semantic-overlays nil t)
- (add-hook 'semantic-after-toplevel-cache-change-hook
- 'minimap-apply-semantic-overlays nil t))
- (with-selected-window win
- ;; Now set up the minimap:
- (when (window-dedicated-p)
- (set-window-dedicated-p nil nil))
- (switch-to-buffer indbuf t t)
- (minimap-kill-buffer)
- (rename-buffer minimap-buffer-name)
- ;; Do not fold lines in the minimap.
- (setq truncate-lines t)
- (when minimap-dedicated-window
- (set-window-dedicated-p nil t))
- (setq minimap-base-overlay (make-overlay (point-min) (point-max) nil t
t))
- (overlay-put minimap-base-overlay 'face 'minimap-font-face)
- (overlay-put minimap-base-overlay 'priority 1)
- ;; Add the hand mouse pointer to visible text. It doesn’t seem
- ;; possible to set the mouse cursor when there’s no text. See
- ;; `void-text-area-pointer'.
- (overlay-put minimap-base-overlay 'pointer 'hand)
- (when minimap-tag-only
- (overlay-put minimap-base-overlay 'face
- `(:inherit minimap-font-face
- :foreground ,(face-background 'default))))
- (setq minimap-pointmin-overlay (make-overlay (point-min) (1+
(point-min))))
- (setq minimap-start (window-start)
- minimap-end (window-end)
- minimap-active-overlay (make-overlay minimap-start minimap-end)
- line-spacing 0)
- (overlay-put minimap-active-overlay 'face
- 'minimap-active-region-background)
- (when minimap-tag-only
- (overlay-put minimap-active-overlay 'face
- `(:inherit 'minimap-active-region-background
- :foreground ,(face-background
'minimap-active-region-background))))
- (overlay-put minimap-active-overlay 'priority 5)
- (minimap-sb-mode 1)
- (when minimap-disable-mode-line
- (setq mode-line-format nil))
- (when minimap-hide-cursor
- (setq cursor-type nil))
- (when minimap-hide-scroll-bar
- (setq vertical-scroll-bar nil)
- (set-window-buffer nil (current-buffer)))
- (when minimap-hide-fringes
- (set-window-fringes nil 0 0))
- (when (and (boundp 'linum-mode)
- linum-mode)
- (linum-mode 0))
- (setq buffer-read-only t)
- ;; Calculate the actual number of lines displayable with the minimap
face.
- (setq minimap-numlines
- (floor
- (/
- (- (nth 3 edges) (nth 1 edges))
- (car (progn (redisplay t) (window-line-height)))))))
- (minimap-sync-overlays)))
-
-(defun minimap-kill ()
- "Kill minimap."
- (interactive)
- (when (minimap-get-window)
- (delete-window (minimap-get-window)))
- (when minimap-timer-object
- (cancel-timer minimap-timer-object)))
-
-;;; Minimap update
-
-(defun minimap-update (&optional force)
- "Update minimap sidebar if necessary.
-This is meant to be called from the idle-timer or the post command hook.
-When FORCE, enforce update of the active region."
- (interactive)
- ;; If we are in the minibuffer, do nothing.
- (unless (active-minibuffer-window)
- (if (minimap-active-current-buffer-p)
- ;; We are still in the same buffer, so just update the minimap.
- (minimap-update-current-buffer force)
- ;; The buffer was switched, check if the minimap should switch, too.
- (if (and minimap-major-modes
- (apply 'derived-mode-p minimap-major-modes))
- (progn
- ;; Create window if necessary...
- (unless (minimap-get-window)
- (minimap-create-window))
- ;; ...and re-create minimap with new buffer...
- (minimap-new-minimap)
- ;; Redisplay
- (sit-for 0)
- ;; ...and call update again.
- (minimap-update t))
- ;; We have entered a buffer for which no minimap should be
- ;; displayed. Check if we should de
- (when (and (minimap-get-window)
- (minimap-need-to-delete-window))
- ;; We wait a tiny bit before deleting the window, since we
- ;; might only be temporarily in another buffer.
- (run-with-timer 0.3 nil
- (lambda ()
- (when (and (null (minimap-active-current-buffer-p))
- (minimap-get-window))
- (delete-window (minimap-get-window))))))))))
-
-(defun minimap-need-to-delete-window ()
- "Check if we should delete the minimap window.
-This depends on `minimap-automatically-delete-window'."
- (if (eq minimap-automatically-delete-window 'visible)
- (null (get-buffer-window minimap-active-buffer))
- (null minimap-automatically-delete-window)))
-
-(defun minimap-update-current-buffer (force)
- "Update minimap for the current buffer."
- (let ((win (minimap-get-window))
- (start (window-start))
- (end (window-end))
- (pt (point)))
- (when (and (null win)
- minimap-recreate-window)
- ;; The minimap window is no longer visible, so create it again...
- (setq win (minimap-create-window))
- ;; ...and switch to existing minimap buffer.
- (with-selected-window win
- (when (window-dedicated-p)
- (set-window-dedicated-p nil nil))
- (switch-to-buffer minimap-buffer-name t t)
- (when minimap-hide-fringes
- (set-window-fringes nil 0 0))
- (when minimap-dedicated-window
- (set-window-dedicated-p nil t))))
- (with-selected-window win
- ;; Make sure the base overlay spans the whole buffer.
- (unless (and (= (overlay-start minimap-base-overlay) (point-min))
- (= (overlay-end minimap-base-overlay) (point-max)))
- (move-overlay minimap-base-overlay (point-min) (point-max)))
- (unless (and (not force)
- (= minimap-start start)
- (= minimap-end end))
- ;; Update the overlay.
- (move-overlay minimap-active-overlay start end)
- (setq minimap-start start
- minimap-end end)
- (minimap-recenter (line-number-at-pos (/ (+ end start) 2))
- (/ (- (line-number-at-pos end)
- (line-number-at-pos start))
- 2)))
- (goto-char pt)
- (beginning-of-line)
- (when minimap-highlight-line
- (minimap-highlight-line))
- (when minimap-always-recenter
- (recenter (round (/ (window-height) 2)))))))
-
-(defun minimap-highlight-line ()
- "Highlight current line in the minimap."
- (unless minimap-line-overlay
- (setq minimap-line-overlay (make-overlay (point) (1+ (point)) nil t))
- (overlay-put minimap-line-overlay 'priority 6))
- (overlay-put
- minimap-line-overlay 'face
- `(:background ,(face-background 'minimap-current-line-face)
- :foreground ,(face-foreground 'minimap-current-line-face)))
- (move-overlay minimap-line-overlay (point) (line-beginning-position 2)))
-
-;;; Overlay movement
-
-(defun minimap-move-overlay-mouse (start-event)
- "Move overlay by tracking mouse movement."
- (interactive "e")
- (when (get-buffer-window (buffer-base-buffer (current-buffer)))
- (let* ((echo-keystrokes 0)
- (end-posn (event-end start-event))
- (start-point (posn-point end-posn))
- (make-cursor-line-fully-visible nil)
- (cursor-type nil)
- (minimap-automatically-delete-window nil)
- (pcselmode (when (boundp 'pc-selection-mode)
- pc-selection-mode))
- pt ev)
- (when (and pcselmode (fboundp 'pc-selection-mode))
- (pc-selection-mode -1))
- (move-overlay minimap-active-overlay start-point minimap-end)
- (track-mouse
- (minimap-set-overlay start-point)
- (while (and
- (consp (setq ev (read-event)))
- (eq (car ev) 'mouse-movement))
- (setq pt (posn-point (event-start ev)))
- (when (numberp pt)
- (with-selected-window (get-buffer-window minimap-buffer-name)
- (goto-char pt)
- (beginning-of-line)
- (minimap-set-overlay (point))))))
- (minimap-update)
- (when (and pcselmode (fboundp 'pc-selection-mode))
- (pc-selection-mode 1)))))
-
-(defun minimap-set-overlay (pt)
- "Set overlay position, with PT being the middle."
- (goto-char pt)
- (let* ((ovstartline (line-number-at-pos minimap-start))
- (ovendline (line-number-at-pos minimap-end))
- (ovheight (round (/ (- ovendline ovstartline) 2)))
- (line (line-number-at-pos))
- (winstart (window-start))
- (winend (window-end))
- newstart newend)
- (setq pt (point-at-bol))
- (setq newstart (minimap-line-to-pos (- line ovheight)))
- ;; Perform recentering
- (minimap-recenter line ovheight)
- ;; Set new position in main buffer and redisplay
- (with-selected-window (get-buffer-window (buffer-base-buffer))
- (goto-char pt)
- (set-window-start nil newstart)
- (redisplay t)
- (setq newend (window-end)))
- (when (eq minimap-recenter-type 'free)
- (while (> newend winend)
- (scroll-up 5)
- (redisplay t)
- (setq winend (window-end))))
- (move-overlay minimap-active-overlay newstart newend)))
-
-(defun minimap-line-to-pos (line)
- "Return point position of line number LINE."
- (save-excursion
- (goto-char 1)
- (if (eq selective-display t)
- (re-search-forward "[\n\C-m]" nil 'end (1- line))
- (forward-line (1- line)))
- (point)))
-
-(defun minimap-recenter (middle height)
- "Recenter the minimap according to `minimap-recenter-type'.
-MIDDLE is the line number in the middle of the active region.
-HEIGHT is the number of lines from MIDDLE to begin/end of the
-active region."
- (cond
- ;; Relative recentering
- ((eq minimap-recenter-type 'relative)
- (let* ((maxlines (line-number-at-pos (point-max)))
- percentage relpos newline start numlines)
- (setq numlines (count-lines (window-start) (window-end)))
- (setq percentage (/ (float middle) (float maxlines)))
- (setq newline (ceiling (* percentage numlines)))
- (setq start (minimap-line-to-pos
- (- middle height
- (floor (* percentage
- (- numlines height height))))))
- (or (> start (point-min))
- (setq start (point-min)))
- ;; If (point-max) already visible, don't go further
- (if (and (> start (window-start))
- (with-selected-window (get-buffer-window (buffer-base-buffer))
- (= (point-max) (window-end))))
- (save-excursion
- (goto-char (point-max))
- (recenter -1))
- (unless (and (> start (window-start))
- (= (point-max) (window-end)))
- (set-window-start nil start)))))
- ;; Middle recentering
- ((eq minimap-recenter-type 'middle)
- (let ((start (- middle height
- (floor (* 0.5
- (- minimap-numlines height height))))))
- (if (< start 1)
- (progn
- ;; Hack: Emacs cannot scroll down any further, so we fake
- ;; it using an overlay. Otherwise, the active region
- ;; would move to the top.
- (overlay-put minimap-pointmin-overlay
- 'display (concat
- (make-string (abs start) 10)
- (buffer-substring (point-min) (1+
(point-min)))))
- (overlay-put minimap-pointmin-overlay
- 'face `(:background ,(face-background 'default)))
- (overlay-put minimap-pointmin-overlay
- 'priority 10)
- (setq start 1))
- (overlay-put minimap-pointmin-overlay 'display "")
- (overlay-put minimap-pointmin-overlay 'face nil))
- (set-window-start nil (minimap-line-to-pos start))))
- ;; Free recentering
- ((eq minimap-recenter-type 'free)
- (let ((newstart (minimap-line-to-pos (- middle height)))
- (winstart (window-start)))
- (while (< newstart winstart)
- (scroll-down 5)
- (redisplay t)
- (setq winstart (window-start)))))))
-
-;;; Minimap minor mode
-
- (defvar minimap-sb-mode-map (make-sparse-keymap)
- "Keymap used by `minimap-sb-mode'.")
-
-(define-key minimap-sb-mode-map [down-mouse-1] 'minimap-move-overlay-mouse)
-(define-key minimap-sb-mode-map [down-mouse-2] 'minimap-move-overlay-mouse)
-(define-key minimap-sb-mode-map [down-mouse-3] 'minimap-move-overlay-mouse)
-
-(define-minor-mode minimap-sb-mode
- "Minor mode for minimap sidebar."
- nil "minimap" minimap-sb-mode-map)
-
-;;; Sync minimap with modes which create/delete overlays.
-
-(defun minimap-sync-overlays ()
- "Synchronize overlays between base and minimap buffer.
-Apply semantic overlays or face enlargement if necessary."
- (interactive)
- ;; Get overlays and Semantic status from base buffer.
- (when (and minimap-mode
- (minimap-active-current-buffer-p))
- (with-current-buffer minimap-active-buffer
- (let ((baseov (overlays-in (point-min) (point-max)))
- (semantic (and (boundp 'semantic-version)
- (semantic-active-p)))
- ov props p)
- ;; Apply overlays to minimap.
- (with-current-buffer minimap-buffer-name
- ;; Delete overlays (but keep our own).
- (let ((ovs (overlays-in (point-min) (point-max))))
- (dolist (ov ovs)
- (unless (member ov (list minimap-pointmin-overlay
- minimap-base-overlay
- minimap-active-overlay))
- (delete-overlay ov))))
- (while baseov
- (when (and (eq (overlay-buffer (car baseov)) minimap-active-buffer)
- (setq props (minimap-get-sync-properties (car baseov))))
- (setq ov (make-overlay (overlay-start (car baseov))
- (overlay-end (car baseov))))
- (while (setq p (car props))
- (overlay-put ov (car p) (cadr p))
- (setq props (cdr props))))
- (setq baseov (cdr baseov)))
- (move-overlay minimap-pointmin-overlay (point-min) (1+ (point-min)))
- ;; Re-apply font overlay
- (move-overlay minimap-base-overlay (point-min) (point-max)))
- ;; Face enlargement
- (when (and font-lock-mode
- (or (eq minimap-enlarge-certain-faces 'always)
- (and (eq minimap-enlarge-certain-faces 'as-fallback)
- (or (not minimap-display-semantic-overlays)
- (not semantic)))))
- (when (eq font-lock-support-mode 'jit-lock-mode)
- (condition-case nil
- (jit-lock-fontify-now)
- (error nil)))
- (minimap-enlarge-faces))
- ;; Semantic overlays
- (when (and semantic
- minimap-display-semantic-overlays)
- (minimap-apply-semantic-overlays t))))))
-
-(defun minimap-get-sync-properties (ov)
- "Get properties from overlay OV which should be synced.
-You can specify those properties with
-`minimap-sync-overlay-properties'."
- (let ((syncprops minimap-sync-overlay-properties))
- (when minimap-tag-only
- (setq syncprops (delq 'face syncprops)))
- (delq nil
- (mapcar
- (lambda (p)
- (let ((val (overlay-get ov p)))
- (if val
- (list p val)
- nil)))
- syncprops))))
-
-(defun minimap-enlarge-faces ()
- "Apply default font to all faces in `minimap-normal-height-faces'."
- (let ((pos (next-single-property-change (point-min) 'face))
- next ov face)
- (while pos
- (setq face (get-text-property pos 'face))
- (when (and face
- (member face minimap-normal-height-faces))
- (with-current-buffer minimap-buffer-name
- (setq ov
- (make-overlay pos
- (setq pos (next-single-property-change pos
'face))))
- (overlay-put ov 'face `(:family ,(face-font 'default)))
- (overlay-put ov 'priority 5)))
- (setq pos (next-single-property-change pos 'face)))))
-
-(defun minimap-apply-semantic-overlays (tags)
- "Apply semantic overlays to the minimap.
-TAGS is the list of tags. If it is t, fetch tags from buffer."
- (when (and tags
- minimap-mode)
- (with-current-buffer minimap-active-buffer
- (let (tag class ov ovnew)
- (when (eq tags t)
- (setq tags (semantic-fetch-tags)))
- (while tags
- (setq tag (car tags))
- (setq class (semantic-tag-class tag))
- (setq ov (semantic-tag-overlay tag))
- (when (and (overlayp ov)
- (or (eq class 'function)
- (eq class 'type)
- (eq class 'variable)))
- (with-current-buffer minimap-buffer-name
- (let* ((start (overlay-start ov))
- (end (overlay-end ov))
- (name (semantic-tag-name tag))
- (lstart (line-number-at-pos start))
- (lend (line-number-at-pos end)))
- ;; First, remove old Semantic overlays.
- (remove-overlays start end 'minimap-semantic t)
- (if minimap-tag-only
- ;; Now put the new ones.
- (overlay-put
- (setq ovnew (make-overlay start end))
- 'face `(:background ,(face-background
- (intern (format
"minimap-semantic-%s-face"
- (symbol-name
class))))
- :foreground
- ,(face-background
- (intern (format
"minimap-semantic-%s-face"
- (symbol-name
class))))
- ))
- ;; Now put the new ones.
- (overlay-put
- (setq ovnew (make-overlay start end))
- 'face `(:background ,(face-background
- (intern (format
"minimap-semantic-%s-face"
- (symbol-name
class)))))))
- (overlay-put ovnew 'priority 4)
- (when (and (eq class 'function)
- (> (- lend lstart) 5))
- (overlay-put ovnew 'priority 1)
- (overlay-put ovnew 'minimap-semantic t)
- (overlay-put (setq ovnew (make-overlay start (progn
(goto-char start) (point-at-eol))))
- 'display (make-string 200 ?\u203E))
- (overlay-put ovnew 'minimap-semantic t)
- (overlay-put ovnew 'face `(:foreground ,(face-foreground
'default) :overline nil))
- (overlay-put ovnew 'priority 8)
- (overlay-put (setq ovnew (make-overlay (progn (goto-char end)
(point-at-bol)) end))
- 'display (make-string 200 ?_))
- (overlay-put ovnew 'face `(:foreground ,(face-foreground
'default)))
- (overlay-put ovnew 'minimap-semantic t)
- (overlay-put ovnew 'priority 8))
- (setq start
- (minimap-line-to-pos (/ (+ lstart lend) 2)))
- (goto-char start)
- (while (looking-at "^$")
- (forward-line -1))
- (setq start (point))
- (setq end (progn (goto-char start) (point-at-eol)))
- (setq ovnew (make-overlay start end))
- (overlay-put ovnew 'face (format "minimap-semantic-%s-face"
- (symbol-name class)))
- (overlay-put ovnew 'display (concat " " name " "))
- (overlay-put ovnew 'priority 7)
- (overlay-put ovnew 'minimap-semantic t)
-
-
- )))
- (setq tags (cdr tags)))))))
-
-(provide 'minimap)
-
-;;; minimap.el ends here
diff --git a/packages/nadvice/nadvice.el b/packages/nadvice/nadvice.el
deleted file mode 100644
index 58523f6..0000000
--- a/packages/nadvice/nadvice.el
+++ /dev/null
@@ -1,94 +0,0 @@
-;;; nadvice.el --- Forward compatibility for Emacs-24.4's nadvice
-
-;; Copyright (C) 2018 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Version: 0.3
-;; Keywords:
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package tries to re-implement some of nadvice.el's functionality
-;; on top of the old defadvice system, to help users of defadvice
-;; move to the new advice system without dropping support for Emacs<24.4.
-;;
-;; Limitations;
-;; - only supports `advice-add', `advice-remove', and `advice-member-p'.
-;; - only handles the :before, :after, :override, and :around kinds of advice;
-;; - requires a named rather than anonymous function;
-;; - and does not support any additional properties like `name' or `depth'.
-;;
-;; It was tested on Emacs-22 and I can't see any obvious reason why it
-;; wouldn't work on older Emacsen.
-
-;;; Code:
-
-(declare-function ad-remove-advice "advice")
-
-(eval-and-compile (require 'advice))
-
-(unless (fboundp 'add-function)
- ;; If `add-function' is defined, we're presumably running on
- ;; an Emacs that comes with the real nadvice.el, so let's be careful
- ;; to do nothing in that case!
-
- ;; Load `advice' manually, in case `advice-remove' is called first,
- ;; since ad-remove-advice is not autoloaded.
- (require 'advice)
-
-(defun advice-member-p (advice symbol)
- (ad-find-advice symbol 'around advice))
-
-;;;###autoload
-(defun advice-add (symbol where function &optional props)
- (when props
- (error "This version of nadvice.el does not support PROPS"))
- (unless (symbolp function)
- (error "This version of nadvice.el requires FUNCTION to be a symbol"))
- (let ((body (cond
- ((eq where :before)
- `(progn (apply #',function (ad-get-args 0)) ad-do-it))
- ((eq where :after)
- `(progn ad-do-it (apply #',function (ad-get-args 0))))
- ((eq where :override)
- `(setq ad-return-value (apply #',function (ad-get-args 0))))
- ((eq where :around)
- `(setq ad-return-value
- (apply #',function
- (lambda (&rest nadvice--rest-arg)
- (ad-set-args 0 nadvice--rest-arg)
- ad-do-it)
- (ad-get-args 0))))
- (t (error "This version of nadvice.el does not handle %S"
- where)))))
- (ad-add-advice symbol
- `(,function nil t (advice lambda () ,body))
- 'around
- nil)
- (ad-activate symbol)))
-
-;;;###autoload
-(defun advice-remove (symbol function)
- ;; Just return nil if there is no advice, rather than signaling an
- ;; error.
- (when (advice-member-p function symbol)
- (ad-remove-advice symbol 'around function)
- (ad-activate symbol)))
-
-)
-
-(provide 'nadvice)
-;;; nadvice.el ends here
diff --git a/packages/oauth2/oauth2.el b/packages/oauth2/oauth2.el
deleted file mode 100644
index 43c4e9e..0000000
--- a/packages/oauth2/oauth2.el
+++ /dev/null
@@ -1,260 +0,0 @@
-;;; oauth2.el --- OAuth 2.0 Authorization Protocol -*- lexical-binding:t -*-
-
-;; Copyright (C) 2011-2020 Free Software Foundation, Inc
-
-;; Author: Julien Danjou <julien@danjou.info>
-;; Version: 0.15
-;; Keywords: comm
-;; Package-Requires: ((cl-lib "0.5") (nadvice "0.3"))
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Implementation of the OAuth 2.0 draft.
-;;
-;; The main entry point is `oauth2-auth-and-store' which will return a token
-;; structure. This token structure can be then used with
-;; `oauth2-url-retrieve-synchronously' or `oauth2-url-retrieve' to retrieve
-;; any data that need OAuth authentication to be accessed.
-;;
-;; If the token needs to be refreshed, the code handles it automatically and
-;; store the new value of the access token.
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-(require 'plstore)
-(require 'json)
-(require 'url-http)
-
-(defvar url-http-data)
-(defvar url-http-method)
-(defvar url-http-extra-headers)
-(defvar url-callback-arguments)
-(defvar url-callback-function)
-
-(defun oauth2-request-authorization (auth-url client-id &optional scope state
redirect-uri)
- "Request OAuth authorization at AUTH-URL by launching `browse-url'.
-CLIENT-ID is the client id provided by the provider.
-It returns the code provided by the service."
- (browse-url (concat auth-url
- (if (string-match-p "\?" auth-url) "&" "?")
- "client_id=" (url-hexify-string client-id)
- "&response_type=code"
- "&redirect_uri=" (url-hexify-string (or redirect-uri
"urn:ietf:wg:oauth:2.0:oob"))
- (if scope (concat "&scope=" (url-hexify-string scope))
"")
- (if state (concat "&state=" (url-hexify-string state))
"")))
- (read-string "Enter the code your browser displayed: "))
-
-(defun oauth2-request-access-parse ()
- "Parse the result of an OAuth request."
- (goto-char (point-min))
- (when (search-forward-regexp "^$" nil t)
- (json-read)))
-
-(defun oauth2-make-access-request (url data)
- "Make an access request to URL using DATA in POST."
- (let ((url-request-method "POST")
- (url-request-data data)
- (url-request-extra-headers
- '(("Content-Type" . "application/x-www-form-urlencoded"))))
- (with-current-buffer (url-retrieve-synchronously url)
- (let ((data (oauth2-request-access-parse)))
- (kill-buffer (current-buffer))
- data))))
-
-(cl-defstruct oauth2-token
- plstore
- plstore-id
- client-id
- client-secret
- access-token
- refresh-token
- token-url
- access-response)
-
-(defun oauth2-request-access (token-url client-id client-secret code &optional
redirect-uri)
- "Request OAuth access at TOKEN-URL.
-The CODE should be obtained with `oauth2-request-authorization'.
-Return an `oauth2-token' structure."
- (when code
- (let ((result
- (oauth2-make-access-request
- token-url
- (concat
- "client_id=" client-id
- (when client-secret
- (concat "&client_secret=" client-secret))
- "&code=" code
- "&redirect_uri=" (url-hexify-string (or redirect-uri
"urn:ietf:wg:oauth:2.0:oob"))
- "&grant_type=authorization_code"))))
- (make-oauth2-token :client-id client-id
- :client-secret client-secret
- :access-token (cdr (assoc 'access_token result))
- :refresh-token (cdr (assoc 'refresh_token result))
- :token-url token-url
- :access-response result))))
-
-;;;###autoload
-(defun oauth2-refresh-access (token)
- "Refresh OAuth access TOKEN.
-TOKEN should be obtained with `oauth2-request-access'."
- (setf (oauth2-token-access-token token)
- (cdr (assoc 'access_token
- (oauth2-make-access-request
- (oauth2-token-token-url token)
- (concat "client_id=" (oauth2-token-client-id token)
- (when (oauth2-token-client-secret token)
- (concat "&client_secret="
(oauth2-token-client-secret token)))
- "&refresh_token=" (oauth2-token-refresh-token
token)
- "&grant_type=refresh_token")))))
- ;; If the token has a plstore, update it
- (let ((plstore (oauth2-token-plstore token)))
- (when plstore
- (plstore-put plstore (oauth2-token-plstore-id token)
- nil `(:access-token
- ,(oauth2-token-access-token token)
- :refresh-token
- ,(oauth2-token-refresh-token token)
- :access-response
- ,(oauth2-token-access-response token)
- ))
- (plstore-save plstore)))
- token)
-
-;;;###autoload
-(defun oauth2-auth (auth-url token-url client-id client-secret &optional scope
state redirect-uri)
- "Authenticate application via OAuth2."
- (oauth2-request-access
- token-url
- client-id
- client-secret
- (oauth2-request-authorization
- auth-url client-id scope state redirect-uri)
- redirect-uri))
-
-(defcustom oauth2-token-file (concat user-emacs-directory "oauth2.plstore")
- "File path where store OAuth tokens."
- ;; FIXME: This var doesn't belong to any group. Either add it to some
- ;; pre-existing group or create an `oauth2' group for it.
- :type 'file)
-
-(defun oauth2-compute-id (auth-url token-url scope)
- "Compute an unique id based on URLs.
-This allows to store the token in an unique way."
- (secure-hash 'md5 (concat auth-url token-url scope)))
-
-;;;###autoload
-(defun oauth2-auth-and-store (auth-url token-url scope client-id client-secret
&optional redirect-uri state)
- "Request access to a resource and store it using `plstore'."
- ;; We store a MD5 sum of all URL
- (let* ((plstore (plstore-open oauth2-token-file))
- (id (oauth2-compute-id auth-url token-url scope))
- (plist (cdr (plstore-get plstore id))))
- ;; Check if we found something matching this access
- (if plist
- ;; We did, return the token object
- (make-oauth2-token :plstore plstore
- :plstore-id id
- :client-id client-id
- :client-secret client-secret
- :access-token (plist-get plist :access-token)
- :refresh-token (plist-get plist :refresh-token)
- :token-url token-url
- :access-response (plist-get plist :access-response))
- (let ((token (oauth2-auth auth-url token-url
- client-id client-secret scope state
redirect-uri)))
- ;; Set the plstore
- (setf (oauth2-token-plstore token) plstore)
- (setf (oauth2-token-plstore-id token) id)
- (plstore-put plstore id nil `(:access-token
- ,(oauth2-token-access-token token)
- :refresh-token
- ,(oauth2-token-refresh-token token)
- :access-response
- ,(oauth2-token-access-response token)))
- (plstore-save plstore)
- token))))
-
-(defun oauth2-url-append-access-token (token url)
- "Append access token to URL."
- (concat url
- (if (string-match-p "\?" url) "&" "?")
- "access_token=" (oauth2-token-access-token token)))
-
-(defvar oauth--url-advice nil)
-(defvar oauth--token-data)
-
-(defun oauth2-authz-bearer-header (token)
- "Return `Authoriztions: Bearer' header with TOKEN."
- (cons "Authorization" (format "Bearer %s" token)))
-
-(defun oauth2-extra-headers (extra-headers)
- "Return EXTRA-HEADERS with `Authorization: Bearer' added."
- (cons (oauth2-authz-bearer-header (oauth2-token-access-token (car
oauth--token-data)))
- extra-headers))
-
-
-;; FIXME: We should change URL so that this can be done without an advice.
-(defun oauth2--url-http-handle-authentication-hack (orig-fun &rest args)
- (if (not oauth--url-advice)
- (apply orig-fun args)
- (let ((url-request-method url-http-method)
- (url-request-data url-http-data)
- (url-request-extra-headers
- (oauth2-extra-headers url-http-extra-headers)))
- (oauth2-refresh-access (car oauth--token-data))
- (url-retrieve-internal (cdr oauth--token-data)
- url-callback-function
- url-callback-arguments)
- ;; This is to make `url' think it's done.
- (when (boundp 'success) (setq success t)) ;For URL library in Emacs<24.4.
- t))) ;For URL library in Emacs≥24.4.
-(advice-add 'url-http-handle-authentication :around
- #'oauth2--url-http-handle-authentication-hack)
-
-;;;###autoload
-(defun oauth2-url-retrieve-synchronously (token url &optional request-method
request-data request-extra-headers)
- "Retrieve an URL synchronously using TOKEN to access it.
-TOKEN can be obtained with `oauth2-auth'."
- (let* ((oauth--token-data (cons token url)))
- (let ((oauth--url-advice t) ;Activate our advice.
- (url-request-method request-method)
- (url-request-data request-data)
- (url-request-extra-headers
- (oauth2-extra-headers request-extra-headers)))
- (url-retrieve-synchronously url))))
-
-;;;###autoload
-(defun oauth2-url-retrieve (token url callback &optional
- cbargs
- request-method request-data
request-extra-headers)
- "Retrieve an URL asynchronously using TOKEN to access it.
-TOKEN can be obtained with `oauth2-auth'. CALLBACK gets called with CBARGS
-when finished. See `url-retrieve'."
- ;; TODO add support for SILENT and INHIBIT-COOKIES. How to handle this in
`url-http-handle-authentication'.
- (let* ((oauth--token-data (cons token url)))
- (let ((oauth--url-advice t) ;Activate our advice.
- (url-request-method request-method)
- (url-request-data request-data)
- (url-request-extra-headers
- (oauth2-extra-headers request-extra-headers)))
- (url-retrieve url callback cbargs))))
-
-(provide 'oauth2)
-
-;;; oauth2.el ends here
diff --git a/packages/org-translate/org-translate.el
b/packages/org-translate/org-translate.el
deleted file mode 100644
index 21ef5ac..0000000
--- a/packages/org-translate/org-translate.el
+++ /dev/null
@@ -1,809 +0,0 @@
-;;; org-translate.el --- Org-based translation environment -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2020 Free Software Foundation, Inc.
-
-;; Version: 0.1.2
-;; Package-Requires: ((emacs "25.1") (org "9.1"))
-
-;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
-;; Maintainer: Eric Abrahamsen <eric@ericabrahamsen.net>
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library contains the `org-translate-mode' minor mode to be
-;; used on top of Org, providing translation-related functionality.
-;; It is not a full-fledged CAT tool. It essentially does two things:
-;; manages segmentation correspondences between the source text and
-;; the translation, and manages a glossary which can be used for
-;; automatic term translation, displaying previous usages, etc.
-
-;; Buffer setup:
-
-;; The mode currently assumes a single file holding a single
-;; translation project, with three separate top-level headings for
-;; source text, translation, and glossary (other headings will be
-;; ignored). The three customization options
-;; `ogt-default-source-locator', `ogt-default-translation-locator' and
-;; `ogt-default-glossary-locator' can be used to tell the mode which
-;; heading is which; by default it expects a buffer that looks like
-;; this:
-
-;; * Le Rouge et le Noir :source:
-;; La petite ville de Verrières peut passer pour...
-
-;; * The Red and the Black :translation:
-;; The small town of Verrieres may be regarded...
-
-;; * Glossary
-;; ** ville de Verrières
-
-;; In other words, tags are used to find the source and translation
-;; texts, while the glossary heading is just called "Glossary". This
-;; is also configurable on a per-project basis, using the
-;; `ogt-translation-projects' option.
-
-;; Segmentation
-
-;; The first time you start this mode in a new translation project
-;; buffer (after first setting up the three headings appropriately),
-;; the mode will detect that the project has not yet been segmented,
-;; and will offer to do so. Segmentation involves inserting the value
-;; of `ogt-segmentation-character' at intervals in the source text.
-;; As you progress through the translation, you'll insert that same
-;; character at corresponding places in the translation text, allowing
-;; the minor mode to keep track of which segment corresponds to which,
-;; and to keep the display of source and translation synchronized.
-
-;; The option `ogt-segmentation-strategy' determines how the source
-;; text is segmented. Currently the options are to segment by
-;; sentence, by paragraph, or by regular expression. Note that, after
-;; initial segmentation, the minor mode will leave the segmentation
-;; characters alone, and you're free to insert, delete or move them as
-;; needed.
-
-;; As you reach the end of each translation segment, use "C-M-n"
-;; (`ogt-new-segment') to insert a segmentation character and start a
-;; new segment. The character should be inserted at the _beginning_
-;; of the new segment, not at the end of the last -- eg at the start
-;; of a paragraph or sentence.
-
-;; Use "C-M-f" and "C-M-b" to move forward and backward in the
-;; translation text by segment. This will allow the minor mode to
-;; keep the corresponding source segment in view. Alternately, move
-;; point however you like in the translation text, then use "C-M-t" to
-;; update the source view.
-
-;; The glossary
-
-;; This mode also maintains a glossary of translation terms for the
-;; current project. Currently it does this by keeping each term as a
-;; subheading under the top-level glossary heading. Each subheading
-;; has an ID property, and this property is used to create links in
-;; the source and translation text, pointing to the glossary item in
-;; question. The mode keeps tracks of the various ways you've
-;; translated a term previously, and offers these for completion on
-;; inserting a new translation.
-
-;; To create a new glossary term, use "C-M-y". If you've marked text
-;; in the source buffer, this will become the new term, otherwise
-;; you'll be prompted to enter the string. This command will attempt
-;; to turn all instances of this term in the source text into a link.
-
-;; In the translation text, use "C-M-;"
-;; (`ogt-insert-glossary-translation') to add a translation. The mode
-;; will attempt to guess which term you're adding, and suggest
-;; previous translations for that term. If you don't want it to
-;; guess, use a prefix argument to be prompted.
-
-;; Bookmarks
-
-;; The functions `ogt-start-translating' and `ogt-stop-translating'
-;; can be used to start and stop a translation session. The first use
-;; of the latter command will save the project in your bookmarks file,
-;; after which `ogt-start-translating' will offer the project to work
-;; on.
-
-;; TODO:
-
-;; - Generalize the code to work in text-mode as well as Org,
-;; using 2C-mode instead of Org subtrees.
-;; - Support multi-file translation projects.
-;; - Import/export TMX translation databases.
-;; - Provide for other glossary backends: eieio-persistent, xml,
-;; sqlite, etc.
-;; - Do this by allowing the glossary locator to point at a named Org
-;; table, or at a babel source block, allowing users to maintain
-;; the glossary outside of Org altogether.
-;; - Provide integration with `org-clock': set a custom property on a
-;; TODO heading indicating that it represents a translation project.
-;; Clocking in both starts the clock, and sets up the translation
-;; buffers. Something like that.
-
-;;; Code:
-
-(require 'bookmark)
-(require 'ox)
-(require 'org-id)
-
-(defgroup org-translate nil
- "Customizations for the org-translate library."
- :group 'text)
-
-(defcustom ogt-default-source-locator '(tag . "source")
- "Default method for locating the source-language subtree.
-The value should be a cons of (TYPE . MATCHER), where TYPE is a
-locator type, as a symbol, and MATCHER is a string or other
-specification. `org-translate-mode' will identify the subtree
-representing the source-language text by locating the first
-heading where MATCHER matches the TYPE of the heading's
-data. Valid TYPEs are:
-
-`tag': Match heading tags.
-`id': Match the heading ID.
-`property': Match an arbitrary other property. MATCHER should be
- a further cons of two strings: the property name and
- value.
-`heading': Match heading text.
-
-Once the heading is located, it will be tracked by its ID
-property."
- :type '(choice
- (cons :tag "Tag" (const tag) string)
- (cons :tag "ID" (const id) string)
- (cons :tag "Property" (const property)
- (cons (string :tag "Property name")
- (string :tag "Property value")))
- (cons :tag "Heading text" (const heading) string)))
-
-(defcustom ogt-default-translation-locator '(tag . "translation")
- "Default method for locating the translation subtree.
-The value should be a cons of (TYPE . MATCHER), where TYPE is a
-locator type, as a symbol, and MATCHER is a string or other
-specification. `org-translate-mode' will identify the subtree
-representing the source-language text by locating the first
-heading where MATCHER matches the TYPE of the heading's
-data. Valid TYPEs are:
-
-`tag': Match heading tags.
-`ID': Match the heading ID.
-`property': Match an arbitrary other property. MATCHER should be
- a further cons of two strings: the property name and
- value.
-`heading': Match heading text.
-
-Once the heading is located, it will be tracked by its ID
-property."
- :type '(choice
- (cons :tag "Tag" (const tag) string)
- (cons :tag "ID" (const id) string)
- (cons :tag "Property" (const property)
- (cons (string :tag "Property name")
- (string :tag "Property value")))
- (cons :tag "Heading text" (const heading) string)))
-
-(defcustom ogt-default-glossary-locator '(heading . "glossary")
- "Default method for locating the glossary subtree.
-The value should be a cons of (TYPE . MATCHER), where TYPE is a
-locator type, as a symbol, and MATCHER is a string or other
-specification. `org-translate-mode' will identify the subtree
-representing the source-language text by locating the first
-heading where MATCHER matches the TYPE of the heading's
-data. Valid TYPEs are:
-
-`tag': Match heading tags.
-`ID': Match the heading ID.
-`property': Match an arbitrary other property. MATCHER should be
- a further cons of two strings: the property name and
- value.
-`heading': Match heading text (case-insensitively).
-
-Once the heading is located, it will be tracked by its ID
-property."
- :type '(choice
- (cons :tag "Tag" (const tag) string)
- (cons :tag "ID" (const id) string)
- (cons :tag "Property" (const property)
- (cons (string :tag "Property name")
- (string :tag "Property value")))
- (cons :tag "Heading text" (const heading) string)))
-
-;; `org-block-regexp', `org-table-any-line-regexp',
-;; `org-heading-regexp' `page-delimiter'... Hmm, maybe we should be
-;; walking through using the org parser instead?
-(defcustom ogt-default-segmentation-strategy 'sentence
- "Default strategy for segmenting source/target text.
-Value can be one of symbols `sentence' or `paragraph', in which
-case the buffer-local definitions of sentence and paragraph will
-be used. It can also be a regular expression.
-
-Org headings, lists, tables, etc, as well as the value of
-`page-delimiter', will always delimit segments."
- :type '(choice (const :tag "Sentence" sentence)
- (const :tag "Paragraph" paragraph)
- regexp))
-
-(defcustom ogt-default-segmentation-character 29
- ;; INFORMATION SEPARATOR THREE, aka "group separator"
- "Default character used to delimit segments."
- :type 'character)
-
-;(defface ogt-source-segment-face '())
-
-(defcustom ogt-translation-projects nil
- "Alist of active translation projects.
-Keys are identifying string for use in completion. Values are
-plists specifying options for that project. Valid options are
-:file, :seg-strategy, :seg-character, :source, :translation, and
-:glossary. The last three values can be specified as a string
-ID, or as a \"locator\" as in, for instance,
-`ogt-default-source-locator'."
- :type 'list)
-
-(defvar-local ogt-source-heading nil
- "ID of the source-text heading in this file.")
-
-(defvar-local ogt-translation-heading nil
- "ID of the translation heading in this file.")
-
-(defvar-local ogt-glossary-heading nil
- "ID of the glossary heading in this file.")
-
-(defvar-local ogt-segmentation-strategy nil
- "Segmentation strategy in this file.")
-
-(defvar-local ogt-segmentation-character nil
- "Segmentation character in this file.")
-
-(defvar-local ogt-this-project-name nil
- "String name of the current translation project, if any.
-If `ogt-translation-projects' is not used, this will be nil.")
-
-(defvar-local ogt-glossary-table nil
- "Hash table holding original<->translation relations.
-Keys are glossary heading IDs. Values are an alist holding
-source terms and translation terms.")
-
-(defvar-local ogt-source-window nil
- "Pointer to window on source text.")
-
-(defvar-local ogt-translation-window nil
- "Pointer to window on translation text.")
-
-(defvar-local ogt-probable-source-location nil
- "Marker at point's corresponding location in source text.
-Called \"probable\" as it is placed heuristically, updated very
-fragilely, and deleted and re-set with abandon.")
-
-(defvar-local ogt-source-segment-overlay nil
- "Overlay on the current source segment.")
-
-(defvar ogt-link-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "o") #'ogt-term-occur)
- (define-key map (kbd "d") #'ogt-term-display-translations)
- map)
- "Keymap active on \"trans:\" type Org links.")
-
-(org-link-set-parameters
- "trans"
- :follow #'org-id-open
- :keymap ogt-link-keymap
- :export #'ogt-export-link)
-
-(defun ogt-export-link (_path desc _backend)
- "Export a translation link.
-By default, just remove it."
- desc)
-
-(defvar org-translate-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-M-f") #'ogt-forward-segment)
- (define-key map (kbd "C-M-b") #'ogt-backward-segment)
- (define-key map (kbd "C-M-n") #'ogt-new-segment)
- (define-key map (kbd "C-M-t") #'ogt-update-source-location)
- (define-key map (kbd "C-M-y") #'ogt-new-glossary-term)
- (define-key map (kbd "C-M-;") #'ogt-insert-glossary-translation)
- map))
-
-(define-minor-mode org-translate-mode
- "Minor mode for using an Org file as a translation project.
-
-\\{org-translate-mode-map}"
- nil " Translate" nil
- (if (null org-translate-mode)
- (progn
- (setq ogt-source-heading nil
- ogt-translation-heading nil
- ogt-glossary-heading nil
- ogt-segmentation-strategy nil
- ogt-segmentation-character nil
- ogt-glossary-table nil
- ogt-probable-source-location nil)
- (when (overlayp ogt-source-segment-overlay)
- (delete-overlay ogt-source-segment-overlay)))
- (unless (derived-mode-p 'org-mode)
- (user-error "Only applicable in Org files."))
- (let* ((this-project (or ogt-this-project-name
- (when ogt-translation-projects
- (let* ((f-name (buffer-file-name)))
- (seq-find
- (lambda (elt)
- (file-equal-p
- f-name (plist-get (cdr elt) :file)))
- ogt-translation-projects)))))
- (this-plist (when this-project
- (alist-get this-project ogt-translation-projects))))
- (condition-case err
- (setq ogt-source-heading (or (plist-get this-plist :source)
- (ogt-locate-heading
- ogt-default-source-locator))
- ogt-translation-heading (or (plist-get this-plist :translation)
- (ogt-locate-heading
- ogt-default-translation-locator))
- ogt-glossary-heading (or (plist-get this-plist :glossary)
- (ogt-locate-heading
- ogt-default-glossary-locator))
- ogt-segmentation-strategy (or (plist-get this-plist
:seg-strategy)
- ogt-default-segmentation-strategy)
- ogt-segmentation-character (or (plist-get this-plist
:seg-character)
-
ogt-default-segmentation-character)
- ogt-glossary-table (make-hash-table :size 500 :test #'equal)
- ogt-probable-source-location (make-marker)
- ogt-source-segment-overlay (make-overlay (point) (point)))
- (error (org-translate-mode -1)
- (signal (car err) (cdr err))))
- (push #'ogt-export-remove-segmenters org-export-filter-body-functions)
- (overlay-put ogt-source-segment-overlay
- 'face 'highlight)
- ;; Doesn't actually delete it, just makes it "inactive" until we
- ;; know where to put it.
- (delete-overlay ogt-source-segment-overlay)
- (delete-other-windows)
- (org-show-all)
- (save-excursion
- (ogt-goto-heading 'source)
- (when (and (save-restriction
- (org-narrow-to-subtree)
- (null (re-search-forward
- (string ogt-segmentation-character) nil t)))
- (yes-or-no-p
- "Project not yet segmented, segment now?"))
- (ogt-segment-project))
- (dolist (location '(source translation))
- (ogt-goto-heading location)
- (save-restriction
- (org-narrow-to-subtree)
- (while (re-search-forward org-link-any-re
- nil t)
- (when (string-prefix-p "trans:" (match-string 2))
- (cl-pushnew (match-string-no-properties 3)
- (alist-get location
- (gethash
- (string-remove-prefix
- "trans:"
- (match-string-no-properties 2))
- ogt-glossary-table))
- :test #'equal))))))
- ;; TODO: Provide more flexible window configuration.
- (setq ogt-translation-window (split-window-sensibly))
- (setq ogt-source-window (selected-window))
- (select-window ogt-translation-window)
- (ogt-goto-heading 'translation)
- ;; If we arrived via a bookmark, don't move point.
- (unless bookmark-current-bookmark
- (org-end-of-subtree))
- (ogt-prettify-segmenters)
- (ogt-update-source-location)
- (ogt-report-progress))))
-
-(defun ogt-export-remove-segmenters (body-string _backend _plist)
- "Remove `ogt-segmentation-character' on export."
- ;; Is `org-export-filter-body-functions' the right filter to use?
- (replace-regexp-in-string
- (string ogt-segmentation-character) "" body-string))
-
-(defun ogt-term-occur ()
- "Run `occur' for the glossary term at point.
-Available on \"trans:\" type links that represent glossary
-terms."
- (interactive)
- (let ((id (org-element-property :path (org-element-context))))
- ;; I thought I should use `org-occur', but that only seems to work
- ;; correctly in the sparse tree context.
- (occur (concat "trans:" id))))
-
-(defun ogt-term-display-translations ()
- "Display original and translations for link under point."
- (interactive)
- (let ((bits (gethash
- (org-element-property :path (org-element-context))
- ogt-glossary-table)))
- (message
- (format
- (concat
- (mapconcat #'identity (alist-get 'source bits) ", ")
- " : "
- (mapconcat #'identity (alist-get 'translation bits) ", "))))))
-
-(defun ogt-prettify-segmenters (&optional begin end)
- "Add a display face to all segmentation characters.
-If BEGIN and END are given, prettify segmenters between those
-locations."
- (save-excursion
- (let ((begin (or begin (point-min)))
- (end (or end (point-max))))
- (goto-char begin)
- (while (re-search-forward
- (string ogt-segmentation-character) end t)
- ;; This marks the buffer as modified (on purpose). Is that
- ;; something we want to suppress?
- (put-text-property (1- (point)) (point)
- ;; Any other useful thing we could do? A
- ;; keymap?
- 'display (string 9245))))))
-
-(defun ogt-recenter-source ()
- "Recenter source location in the source window."
- (with-selected-window ogt-source-window
- (goto-char ogt-probable-source-location)
- (recenter)))
-
-(defun ogt-update-source-location ()
- "Place location marker in source text.
-Point must be in the translation tree for this to do anything.
-Sets the marker `ogt-probable-source-location' to our best-guess
-spot corresponding to where point is in the translation."
- (interactive)
- (let* ((start (point))
- (trans-start
- (progn (ogt-goto-heading 'translation) (point)))
- (trans-end (progn (org-end-of-subtree) (point)))
- (number-of-segments 0))
- (goto-char start)
- (unless (<= trans-start start trans-end)
- (user-error "Must be called from inside the translation text"))
- (while (re-search-backward (string ogt-segmentation-character)
- trans-start t)
- (cl-incf number-of-segments))
- (with-selected-window ogt-source-window
- (ogt-goto-heading 'source)
- (save-restriction
- (org-narrow-to-subtree)
- (org-end-of-meta-data t)
- (unless (re-search-forward (string ogt-segmentation-character)
- nil t number-of-segments)
- t ;; Something is wrong! Re-segment the whole buffer?
- )
- (set-marker ogt-probable-source-location (point))
- (ogt-highlight-source-segment)
- (recenter)))
- (goto-char start)))
-
-(defun ogt-report-progress ()
- "Report progress in the translation, as a percentage."
- (interactive)
- (let (report-start report-end)
- (save-excursion
- (save-selected-window
- (ogt-goto-heading 'source)
- (org-end-of-meta-data t)
- (setq report-start (point))
- (org-end-of-subtree)
- (setq report-end (point))))
- (message "You're %d%% done!"
- (* (/ (float (- ogt-probable-source-location report-start))
- (float (- report-end report-start)))
- 100))))
-
-(defun ogt-highlight-source-segment ()
- "Highlight the source segment the user is translating.
-Finds the location of the `ogt-probable-source-location' marker,
-and applies a highlight to the appropriate segment of text."
- (when (marker-position ogt-probable-source-location)
- (save-excursion
- (goto-char ogt-probable-source-location)
- ;; If we're right in front of a seg character, use the
- ;; following segment.
- (when (looking-at-p (string ogt-segmentation-character))
- (forward-char))
- (move-overlay
- ogt-source-segment-overlay
- (progn
- (re-search-backward
- (string ogt-segmentation-character)
- nil t)
- (forward-char)
- (point))
- (progn
- (or (and (re-search-forward
- (regexp-opt (string ogt-segmentation-character)
- "\n\n"
- org-heading-regexp)
- nil t)
- (progn
- (backward-char)
- (skip-syntax-backward "-")
- (point)))
- (point-max)))))))
-
-(defun ogt-locate-heading (locator)
- "Return the ID of the heading found by LOCATOR, or nil.
-Creates an ID if necessary."
- (save-excursion
- (goto-char (point-min))
- (let ((id (pcase locator
- (`(heading . ,text)
- (catch 'found
- (while (re-search-forward
- org-complex-heading-regexp nil t)
- (when (string-match-p text (match-string 4))
- (throw 'found (org-id-get-create))))))
- (`(tag . ,tag-text)
- (catch 'found
- (while (re-search-forward org-tag-line-re nil t)
- (when (string-match-p tag-text (match-string 2))
- (throw 'found (org-id-get-create))))))
- (`(id . ,id-text)
- (org-id-goto id-text)
- id-text)
- (`(property (,prop . ,value))
- (goto-char (org-find-property prop value))
- (org-id-get-create)))))
- (or id
- (error "Locator failed: %s" locator)))))
-
-(defun ogt-goto-heading (head)
- (let ((id (pcase head
- ('source ogt-source-heading)
- ('translation ogt-translation-heading)
- ('glossary ogt-glossary-heading)
- (_ nil))))
- (when id
- (org-id-goto id))))
-
-(defun ogt-segment-project ()
- "Do segmentation for the current file.
-Automatic segmentation is only done for the source text;
-segmentation in the translation is all manual.
-
-Segmentation is done by inserting `ogt-segmentation-character' at
-the beginning of each segment."
- (dolist (loc '(source translation))
- ;; Also attempt to segment the translation subtree -- the user
- ;; might have already started.
- (save-excursion
- (ogt-goto-heading loc)
- (save-restriction
- (org-narrow-to-subtree)
- (org-end-of-meta-data t)
- (let ((mover
- ;; These "movers" should all leave point at the beginning
- ;; of the _next_ thing.
- (pcase ogt-segmentation-strategy
- ('sentence
- (lambda (_end)
- (forward-sentence)
- (skip-chars-forward "[:blank:]")))
- ('paragraph (lambda (_end)
- (org-forward-paragraph)))
- ((pred stringp)
- (lambda (end)
- (re-search-forward
- ogt-segmentation-strategy end t)))
- (_ (user-error
- "Invalid value of `ogt-segmentation-strategy'"))))
- (end (make-marker))
- current)
- (while (< (point) (point-max))
- (setq current (org-element-at-point))
- (unless (eql (org-element-type current) 'headline)
- (insert ogt-segmentation-character))
- (move-marker end (org-element-property :contents-end current))
- ;; TODO: Do segmentation in plain lists and tables.
- (while (and (< (point) end)
- ;; END can be after `point-max' in narrowed
- ;; buffer.
- (< (point) (point-max)))
- (cond
- ((eql (org-element-type current) 'headline)
- (skip-chars-forward "[:blank:]\\*")
- (insert ogt-segmentation-character)
- (org-end-of-meta-data t)
- (move-marker end (point)))
- ((null (eql (org-element-type current)
- 'paragraph))
- (goto-char end))
- (t (ignore-errors (funcall mover end))))
- (if (eolp) ;; No good if sentence happens to end at `eol'!
- (goto-char end)
- (insert ogt-segmentation-character)))
- (unless (ignore-errors (org-forward-element))
- (goto-char (point-max)))))))))
-
-;; Could also set this as `forward-sexp-function', then don't need the
-;; backward version.
-(defun ogt-forward-segment (arg)
- "Move ARG segments forward.
-Or backward, if ARG is negative."
- (interactive "p")
- (re-search-forward (string ogt-segmentation-character) nil t arg)
- (if (marker-position ogt-probable-source-location)
- (with-selected-window ogt-source-window
- (goto-char ogt-probable-source-location)
- (re-search-forward (string ogt-segmentation-character)
- nil t arg)
- (set-marker ogt-probable-source-location (point))
- (ogt-highlight-source-segment)
- (recenter))
- (ogt-update-source-location)))
-
-(defun ogt-backward-segment (arg)
- (interactive "p")
- (ogt-forward-segment (- arg)))
-
-(defun ogt-new-segment ()
- "Start a new translation segment.
-Used in the translation text when a segment is complete, to start
-the next one."
- (interactive)
- (insert ogt-segmentation-character)
- (ogt-prettify-segmenters (1- (point)) (point))
- (unless (eolp)
- (forward-char))
- (recenter 10)
- (if (marker-position ogt-probable-source-location)
- (with-selected-window ogt-source-window
- (goto-char ogt-probable-source-location)
- (re-search-forward (string ogt-segmentation-character)
- nil t)
- (set-marker ogt-probable-source-location (point))
- (ogt-highlight-source-segment)
- (recenter 10))
- (ogt-update-source-location)))
-
-(defun ogt-new-glossary-term (string)
- "Add STRING as an item in the glossary.
-If the region is active, it will be used as STRING. Otherwise,
-prompt the user for STRING."
- (interactive
- (list (if (use-region-p)
- (buffer-substring-no-properties
- (region-beginning)
- (region-end))
- (read-string "Glossary term: "))))
- (save-excursion
- (ogt-goto-heading 'glossary)
- (if (org-goto-first-child)
- (org-insert-heading-respect-content)
- (end-of-line)
- (org-insert-subheading 1))
- (insert string)
- (let ((id (org-id-get-create))
- ;; STRING might be broken across lines. What do we do about
- ;; Chinese, with no word separators?
- (doctored (replace-regexp-in-string
- "[[:blank:]]+" "[[:space:]\n]+"
- string)))
- (ogt-goto-heading 'source)
- (save-restriction
- (org-narrow-to-subtree)
- (while (re-search-forward doctored nil t)
- (replace-match (format "[[trans:%s][%s]]" id string))))
- (push string (alist-get 'source (gethash id ogt-glossary-table)))))
- (message "Added %s as a glossary term" string))
-
-(defun ogt-insert-glossary-translation (prompt)
- "Insert a likely translation of the next glossary term.
-Guesses the glossary term to insert based on how many terms have
-already been translated in this segment. Alternately, give a
-prefix arg to be prompted for the term to enter."
- (interactive "P")
- (let* ((orig (when prompt
- (completing-read
- "Add translation of: "
- (mapcan (lambda (v)
- (copy-sequence (alist-get 'source v)))
- (hash-table-values ogt-glossary-table))
- nil t)))
- (glossary-id (when orig
- (catch 'found
- (maphash
- (lambda (k v)
- (when (member orig (alist-get 'source v))
- (throw 'found k)))
- ogt-glossary-table))))
- glossary-translation this-translation)
- (ogt-update-source-location)
- ;; If we didn't prompt, attempt to guess which glossary term
- ;; should be translated next by counting how many we've already
- ;; done this segment.
- (unless (and orig glossary-id)
- (let ((terms-this-segment 1))
- (save-excursion
- (while (re-search-backward
- "\\[\\[trans:"
- (save-excursion
- (re-search-backward
- (string ogt-segmentation-character) nil t)
- (point))
- t)
- (cl-incf terms-this-segment)))
- (with-selected-window ogt-source-window
- (goto-char ogt-probable-source-location)
- (while (null (zerop terms-this-segment))
- (re-search-forward org-link-any-re nil t)
- (when (string-prefix-p "trans:" (match-string 2))
- (cl-decf terms-this-segment)))
- (setq orig (match-string-no-properties 3)
- glossary-id (string-remove-prefix
- "trans:" (match-string 2))))))
- (setq glossary-translation
- (alist-get 'translation
- (gethash glossary-id ogt-glossary-table))
- this-translation
- (completing-read (format "Translation of %s: " orig)
- glossary-translation))
- (cl-pushnew
- this-translation
- (alist-get 'translation
- (gethash glossary-id ogt-glossary-table))
- :test #'equal)
- (insert (format "[[trans:%s][%s]]" glossary-id this-translation))))
-
-(defun ogt-stop-translating (project-name)
- "Stop translating for the current file, record position.
-Saves a bookmark under PROJECT-NAME."
- (interactive
- (list (or bookmark-current-bookmark
- (let ((f-name (file-name-nondirectory
- (file-name-sans-extension
- (buffer-file-name)))))
- (read-string
- (format-prompt "Save project as" f-name)
- nil nil f-name)))))
- (let ((rec (bookmark-make-record)))
- (bookmark-prop-set rec 'translation t)
- (bookmark-store project-name (cdr rec) nil)
- (bookmark-save)
- (message "Position recorded and saved")))
-
-(defun ogt-start-translating (bmk)
- "Start translating a bookmarked project.
-Prompts for a bookmark, and sets up the windows."
- (interactive
- (list (progn (require 'bookmark)
- (bookmark-maybe-load-default-file)
- (assoc-string
- (completing-read
- "Translation project: "
- ;; "Borrowed" from `bookmark-completing-read'.
- (lambda (string pred action)
- (if (eq action 'metadata)
- '(metadata (category . bookmark))
- (complete-with-action
- action
- (seq-filter
- (lambda (bmk)
- (bookmark-prop-get bmk 'translation))
- bookmark-alist)
- string pred))))
- bookmark-alist))))
- (bookmark-jump bmk)
- (when (derived-mode-p 'org-mode)
- (org-translate-mode)))
-
-(provide 'org-translate)
-;;; org-translate.el ends here
diff --git a/packages/other-frame-window/other-frame-window.el
b/packages/other-frame-window/other-frame-window.el
deleted file mode 100644
index 794d2bc..0000000
--- a/packages/other-frame-window/other-frame-window.el
+++ /dev/null
@@ -1,436 +0,0 @@
-;;; other-frame-window.el --- Minor mode to enable global prefix keys for
other frame/window buffer placement -*- lexical-binding: t -*-
-;;
-;; Copyright (C) 2015, 2017, 2018 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
-;; Keywords: frame window
-;; Version: 1.0.6
-;; Package-Requires: ((emacs "24.4"))
-;;
-;; This file is 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 <http://www.gnu.org/licenses/>.
-;;
-;;; Commentary:
-;;
-;; other-frame-window provides prefix key sequences to control where a
-;; new buffer is created by a subsequent command. With no prefix, the
-;; buffer is created where the command decides (nominally the currently
-;; selected window). Prefix C-x 7 causes the buffer to appear in
-;; another window in the same frame; a window is created if necessary.
-;; Prefix C-x 9 causes the buffer to appear in another frame; a frame
-;; is created if necessary.
-;;
-;; Some commands display new buffers in other than the currently
-;; selected window, which defeats the purpose of ‘other-frame-window’ in
-;; the absense of a prefix. To override that, customize
-;; ‘display-buffer-alist’ for those commands. For example, to override
-;; ‘gud-gdb’:
-;;
-;; (add-to-list
-;; 'display-buffer-alist
-;; (cons "\\*gud"
-;; (cons 'display-buffer-same-window nil)))
-;; )
-;;
-;; Other key bindings provided by other-frame-window:
-;;
-;; C-x W moves the current buffer to another window in the same frame.
-;;
-;; C-x F moves the current buffer to another frame.
-;;
-;;
-;; In addition, C-x 7 and C-x 9 can be followed by these keys:
-;;
-;; 0 - deletes the current window.
-;;
-;; 1 - deletes the other windows/frames.
-;;
-;; 2 - shows another view of the current buffer in a new
-;; window/frame.
-;;
-;; a - creates a commit log entry for the current defun in
-;; another window/frame.
-;;
-;; b - switches to another buffer in another window/frame.
-;;
-;; d - start dired in another window/frame.
-;;
-;; f - find-file in another window/frame.
-;;
-;; m - compose mail in another window/frame.
-;;
-;; o - select another window/frame.
-;;
-;; r - find-file-read-only in another window/frame.
-;;
-;; To extend this list, add key bindings to ‘ofw-transient-map’.
-;;
-
-;;;; Usage:
-;;
-;; Enable the minor mode with:
-;;
-;; M-x other-frame-window-mode
-;;
-;; or, in your ~/.emacs:
-;;
-;; (other-frame-window-mode t)
-;;
-
-;;;; Design:
-;;
-;; This uses C-x 7, 9 prefix because those keys are undefined in core
-;; Emacs. It could eventually switch to 4, 5, since those are
-;; currently used for -other-window, -other-frame bindings.
-;;
-;; (info "(emacs) Pop Up Window") (info "(emacs) Creating Frames")
-;;
-;; This adds advice to switch-to-buffer; eventually Emacs could
-;; reimplement switch-to-buffer to do the same.
-
-;;;; Todo:
-
-;; - Pay attention to bindings added to ctl-x-4-map and ctl-x-5-map
-;; - Should `C-x 7 C-h' display the transient map?
-;; - `C-x 7 C-h k f' should show `find-file' rather than `self-insert-command'.
-;; This should probably be fixed in set-transient-map.
-
-;;; Code:
-
-(defvar ofw--just-set nil
- "Non-nil if we just set the prefix in the previous command.")
-
-(defvar ofw-transient-map
- (let ((map (make-sparse-keymap)))
- ;; This is basically the union of the default C-x 4 and C-x 5
- ;; keymaps in Emacs-25.
- (define-key map [?\C-f] #'find-file)
- (define-key map [?\C-o] #'display-buffer)
- (define-key map [?.]
- (if (fboundp 'xref-find-definitions) ;Emacs≥25.
- 'xref-find-definitions 'find-tag))
- (define-key map [?0] #'ofw-dwim-delete-this)
- (define-key map [?1] #'ofw-dwim-one)
- (define-key map [?2] #'ofw-dwim-open-other)
- (define-key map [?a] #'add-change-log-entry)
- (define-key map [?b] #'switch-to-buffer)
- (define-key map [?c] #'clone-indirect-buffer)
- (define-key map [?d] #'dired)
- (define-key map [?f] #'find-file)
- (define-key map [?m] #'compose-mail)
- (define-key map [?o] #'ofw-dwim-select-other)
- (define-key map [?r] #'find-file-read-only)
- map)
- "Keymap used for one command right after setting the prefix.")
-
-(defun ofw--set-prefix (func)
- "Add ofw prefix function FUNC."
- (ofw-delete-from-overriding)
- (let ((functions (car display-buffer-overriding-action))
- (attrs (cdr display-buffer-overriding-action)))
- (push func functions)
- (setq display-buffer-overriding-action (cons functions attrs))
- ;; C-u C-x 7 foo should pass C-u to foo, not to C-x 7, so
- ;; pass the normal prefix to the next command.
- (if (fboundp 'prefix-command-preserve-state)
- (prefix-command-preserve-state)
- ;; Make sure the next pre-command-hook doesn't immediately set
- ;; display-buffer-overriding-action back to nil.
- (setq ofw--just-set t)
- (setq prefix-arg current-prefix-arg))
- (set-transient-map ofw-transient-map)))
-
-(defun ofw--echo-keystrokes ()
- ;; Sometimes people abuse ‘display-buffer-overriding-action’, and
- ;; that crashes emacs, so be careful.
- (when (and (consp display-buffer-overriding-action)
- (listp (car display-buffer-overriding-action)))
- (let ((funs (car display-buffer-overriding-action)))
- (cond
- ((memq #'ofw-display-buffer-other-frame funs) "[other-frame]")
- ((memq #'ofw-display-buffer-other-window funs) "[other-window]")))))
-
-(when (boundp 'prefix-command-echo-keystrokes-functions)
- (add-hook 'prefix-command-echo-keystrokes-functions
- #'ofw--echo-keystrokes))
-
-(defun ofw--preserve-state () (setq ofw--just-set t))
-(when (boundp 'prefix-command-preserve-state-hook)
- (add-hook 'prefix-command-preserve-state-hook
- #'ofw--preserve-state))
-
-(defun ofw-delete-from-overriding ()
- "Remove ourselves from `display-buffer-overriding-action' action list, if
present."
- (let ((functions (car display-buffer-overriding-action))
- (attrs (cdr display-buffer-overriding-action)))
- (setq functions (remq #'ofw-display-buffer-other-frame
- (remq #'ofw-display-buffer-other-window functions)))
- (setq display-buffer-overriding-action
- (when (or functions attrs) (cons functions attrs)))))
-
-(defun ofw-other-window ()
- "Set `display-buffer-overriding-action' to indicate other window."
- (interactive)
- (ofw--set-prefix #'ofw-display-buffer-other-window))
-
-(defun ofw-other-frame ()
- "Set `display-buffer-overriding-action' to indicate other frame."
- (interactive)
- (ofw--set-prefix #'ofw-display-buffer-other-frame))
-
-(defun ofw-display-buffer-other-window (buffer alist)
- "Show BUFFER in another window in the current frame,
-creating new window if needed and allowed.
-If successful, return window; else return nil.
-Intended for `display-buffer-overriding-action'."
- ;; Reset for next display-buffer call. Normally, this is taken care
- ;; of by ofw--reset-prefix, but we do it here in case the user does
- ;; two ofw prefixed commands consecutively.
- (ofw-delete-from-overriding)
-
- ;; We can't use display-buffer-use-some-window here, because
- ;; that unconditionally allows another frame.
- (or (display-buffer-use-some-frame
- buffer
- (append (list (cons 'frame-predicate
- (lambda (frame) (eq frame (selected-frame))))
- '(inhibit-same-window . t))
- alist))
- (display-buffer-pop-up-window buffer alist)))
-
-(defun ofw-display-buffer-other-frame (buffer alist)
- "Show BUFFER in another frame, creating a new frame if needed.
-If successful, return window; else return nil.
-Intended for `display-buffer-overriding-action'."
- ;; Reset for next display-buffer call.
- (ofw-delete-from-overriding)
-
- ;; IMPROVEME: prompt for a frame if more than 2
- (or (display-buffer-use-some-frame buffer alist)
- (display-buffer-pop-up-frame buffer alist)))
-
-(defun ofw-switch-to-buffer-advice (orig-fun buffer
- &optional norecord force-same-window)
- "Change `switch-to-buffer' to call `pop-to-buffer'.
-This allows `switch-to-buffer' to respect `ofw-other-window',
-`ofw-other-frame'."
- (if display-buffer-overriding-action
- (pop-to-buffer buffer (list #'display-buffer-same-window) norecord)
- (funcall orig-fun buffer norecord force-same-window)))
-
-(defun ofw--suspend-and-restore (orig-func &rest args)
- "Call ORIG-FUNC without any ofw actions on
`display-buffer-overriding-action'."
- (let ((display-buffer-overriding-action display-buffer-overriding-action))
- (ofw-delete-from-overriding)
- (apply orig-func args)))
-
-(defun ofw-move-to-other-window ()
- "Move current buffer to another window in same frame.
-Point stays in moved buffer."
- (interactive)
- (let ((buffer (current-buffer)))
- (switch-to-prev-buffer nil 'bury)
- (pop-to-buffer
- buffer
- (cons '(display-buffer-use-some-frame display-buffer-pop-up-window)
- (list (cons 'frame-predicate (lambda (frame) (eq frame
(selected-frame))))
- '(inhibit-same-window . t)))
- )))
-
-(defun ofw-move-to-other-frame ()
- "Move current buffer to a window in another frame.
-Point stays in moved buffer."
- (interactive)
- (let ((buffer (current-buffer)))
- (switch-to-prev-buffer nil 'bury)
- (pop-to-buffer
- buffer
- (cons '(display-buffer-use-some-frame display-buffer-pop-up-frame)
- '((reusable-frames . visible)))
- )))
-
-(defvar other-frame-window-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-x7" #'ofw-other-window)
- (define-key map "\C-x9" #'ofw-other-frame)
- (define-key map "\C-xW" #'ofw-move-to-other-window)
- (define-key map "\C-xF" #'ofw-move-to-other-frame)
- map)
- "Local keymap used for other-frame-window minor mode.")
-
-(defun ofw--reset-prefix ()
- (if ofw--just-set
- (setq ofw--just-set nil)
- (ofw-delete-from-overriding)))
-
-;;;###autoload
-(define-minor-mode other-frame-window-mode
- "Minor mode for other frame/window buffer placement.
-Enable mode if ARG is positive.
-
-\\[ofw-other-window] <command> causes a buffer displayed by <command>
-to appear in another window in the same frame; a window
-is created if necessary.
-
-\\[ofw-other-frame] <command> causes a buffer displayed by <command>
-to appear in another frame; a frame is created if necessary.
-
-\\[ofw-move-to-other-window] moves the current buffer to another
-window in the same frame.
-
-\\[ofw-move-to-other-frame] moves the current buffer to another
-frame.
-
-In addition, \\[ofw-other-window] and \\[ofw-other-frame] can be followed by
these keys:
-
-0 - deletes the current window/frame
-
-1 - deletes the other windows/frames.
-
-2 - shows another view of the current buffer in a new
- window/frame.
-
-a - creates a commit log entry for the current defun in
- another window/frame.
-
-b - switches to another buffer in another window/frame.
-
-d - start dired in another window/frame.
-
-f - find-file in another window/frame.
-
-m - compose mail in another window/frame.
-
-o - select another window/frame.
-
-r - find-file-read-only in another window/frame.
-"
- :global t
-
- (remove-hook 'pre-command-hook #'ofw--reset-prefix)
-
- (if other-frame-window-mode
- ;; enable
- (progn
- (add-hook 'pre-command-hook #'ofw--reset-prefix)
-
- ;; We assume Emacs code calls pop-to-buffer when there is a good
- ;; reason to put the buffer in another window, so we don't mess
- ;; with the default actions, except to allow
- ;; display-buffer-reuse-window to use a window in another frame;
- ;; add (reusable-frames . visible) to display-buffer-base-action
- ;; attributes alist.
- (let ((functions (car display-buffer-base-action))
- (attrs (cdr display-buffer-base-action)))
- (push '(reusable-frames . visible) attrs)
- (setq display-buffer-base-action (cons functions attrs)))
-
- ;; Change switch-to-buffer to use display-buffer
- (advice-add 'switch-to-buffer :around #'ofw-switch-to-buffer-advice)
-
- ;; Completing-read <tab> pops up a buffer listing completions;
- ;; that should not respect or consume
- ;; ofw-frame-window-prefix-arg.
- (advice-add 'read-from-minibuffer :around #'ofw--suspend-and-restore)
- )
-
- ;; else disable
- (let ((functions (car display-buffer-base-action))
- (attrs (cdr display-buffer-base-action)))
- (setq attrs (delq '(reusable-frames . visible) attrs))
- (setq display-buffer-base-action (cons functions attrs)))
-
- (advice-remove 'switch-to-buffer #'ofw-switch-to-buffer-advice)
- (advice-remove 'read-from-minibuffer #'ofw--suspend-and-restore)
- ))
-
-(unless (fboundp 'display-buffer-use-some-frame)
- ;; in Emacs 25; define here for earlier
-
-(defun display-buffer-use-some-frame (buffer alist)
- "Display BUFFER in an existing frame that meets a predicate
-\(by default any frame other than the current frame). If
-successful, return the window used; otherwise return nil.
-
-If ALIST has a non-nil `inhibit-switch-frame' entry, avoid
-raising the frame.
-
-If ALIST has a non-nil `frame-predicate' entry, its value is a
-function taking one argument (a frame), returning non-nil if the
-frame is a candidate; this function replaces the default
-predicate.
-
-If ALIST has a non-nil `inhibit-same-window' entry, avoid using
-the currently selected window (only useful with a frame-predicate
-that allows the selected frame)."
- (let* ((predicate (or (cdr (assq 'frame-predicate alist))
- (lambda (frame)
- (and
- (not (eq frame (selected-frame)))
- (not (window-dedicated-p
- (or
- (get-lru-window frame)
- (frame-first-window frame)))))
- )))
- (frame (car (filtered-frame-list predicate)))
- (window (and frame (get-lru-window frame nil (cdr (assq
'inhibit-same-window alist))))))
- (when window
- (prog1
- (window--display-buffer
- buffer window 'frame alist display-buffer-mark-dedicated)
- (unless (cdr (assq 'inhibit-switch-frame alist))
- (window--maybe-raise-frame frame))))
- ))
- )
-
-;; Some of the commands on the transient keymap don't actually *display*
-;; in another window/frame but instead do something either at the level
-;; of windows or frames. I call those "ofw-dwim-*".
-
-(defun ofw-dwim--frame-p ()
- "Return non-nil if the prefix is for \"other-frame\" rather than window."
- ;; IMPROVEME: Comparing functions is ugly/hackish!
- (memq #'ofw-display-buffer-other-frame
- (car display-buffer-overriding-action)))
-
-(defun ofw-dwim-delete-this ()
- "Delete this frame or window."
- (interactive)
- (call-interactively
- (if (ofw-dwim--frame-p) #'delete-frame #'kill-buffer-and-window)))
-
-(defun ofw-dwim-one ()
- "Delete all other frames or windows."
- (interactive)
- (call-interactively
- (if (ofw-dwim--frame-p) #'delete-other-frames #'delete-other-windows)))
-
-(defun ofw-dwim-open-other ()
- "Show current buffer in other frame or window."
- (interactive)
- (if (ofw-dwim--frame-p)
- ;; IMPROVEME: This is the old C-x 5 2 behavior, but maybe it should just
use
- ;; display-buffer instead!
- (call-interactively #'make-frame-command)
- (display-buffer (current-buffer))))
-
-(defun ofw-dwim-select-other ()
- "Select other frame or window."
- (interactive)
- (call-interactively (if (ofw-dwim--frame-p) #'other-frame #'other-window)))
-
-(provide 'other-frame-window)
-;;; other-frame-window.el ends here
diff --git a/packages/package-fixes/package-fixes.el
b/packages/package-fixes/package-fixes.el
deleted file mode 100644
index c0324e8..0000000
--- a/packages/package-fixes/package-fixes.el
+++ /dev/null
@@ -1,148 +0,0 @@
-;;; package-fixes.el --- package.el bug fixes ported to older Emacsen -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Artur Malabarba <emacs@endlessparentheses.com>
-;; Keywords: tools
-;; Version: 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package fixes some critical bugs in package.el 1.0.1 which
-;; cause bad .elc files to be created during package upgrades when a
-;; macro changes. It is designed to be required as a dependency by
-;; packages whose installation is affected by these bugs.
-
-;; This package can be safely installed on Emacs >= 25, in which
-;; case it does nothing.
-
-;;; Code:
-
-
-;;; Emacs < 25
-(unless (fboundp 'package--list-loaded-files)
- (require 'package)
- (require 'find-func)
-
- (declare-function package-fixes--autoloads-file-name "package-fixes")
- (declare-function find-library-name "find-func")
- (declare-function package-fixes--list-loaded-files "package-fixes")
- (declare-function package-fixes--activate-autoloads-and-load-path
"package-fixes")
-
- ;; None of these functions are defined in Emacs < 25.1. Defining
- ;; them here doesn't actually do anything yet, they will be used by
- ;; the advices below.
- (defun package-fixes--autoloads-file-name (pkg-desc)
- "Return the absolute name of the autoloads file, sans extension.
-PKG-DESC is a `package-desc' object."
- (expand-file-name
- (format "%s-autoloads" (package-desc-name pkg-desc))
- (package-desc-dir pkg-desc)))
-
- (defun package-fixes--activate-autoloads-and-load-path (pkg-desc)
- "Load the autoloads file and add package dir to `load-path'.
-PKG-DESC is a `package-desc' object."
- (let* ((old-lp load-path)
- (pkg-dir (package-desc-dir pkg-desc))
- (pkg-dir-dir (file-name-as-directory pkg-dir)))
- (with-demoted-errors "Error loading autoloads: %s"
- (load (package-fixes--autoloads-file-name pkg-desc) nil t))
- (when (and (eq old-lp load-path)
- (not (or (member pkg-dir load-path)
- (member pkg-dir-dir load-path))))
- ;; Old packages don't add themselves to the `load-path', so we have to
- ;; do it ourselves.
- (push pkg-dir load-path))))
-
- (defun package-fixes--list-loaded-files (dir)
- "Recursively list all files in DIR which correspond to loaded features.
-Returns the `file-name-sans-extension' of each file, relative to
-DIR, sorted by most recently loaded last."
- (let* ((history (delq nil
- (mapcar (lambda (x)
- (let ((f (car x)))
- (and f (file-name-sans-extension f))))
- load-history)))
- (dir (file-truename dir))
- ;; List all files that have already been loaded.
- (list-of-conflicts
- (delq
- nil
- (mapcar
- (lambda (x) (let* ((file (file-relative-name x dir))
- ;; Previously loaded file, if any.
- (previous
- (ignore-errors
- (file-name-sans-extension
- (file-truename (find-library-name file)))))
- (pos (when previous (member previous history))))
- ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
- (when pos
- (cons (file-name-sans-extension file) (length pos)))))
- (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))))
- ;; Turn the list of (FILENAME . POS) back into a list of features.
Files in
- ;; subdirectories are returned relative to DIR (so not actually
features).
- (let ((default-directory (file-name-as-directory dir)))
- (mapcar (lambda (x) (file-truename (car x)))
- (sort list-of-conflicts
- ;; Sort the files by ascending HISTORY-POSITION.
- (lambda (x y) (< (cdr x) (cdr y))))))))
-
- (defun package-fixes--load-files-for-activation (pkg-desc reload)
- "Load files for activating a package given by PKG-DESC.
-Load the autoloads file, and ensure `load-path' is setup. If
-RELOAD is non-nil, also load all files in the package that
-correspond to previously loaded files."
- (let* ((loaded-files-list (when reload
- (package-fixes--list-loaded-files
(package-desc-dir pkg-desc)))))
- ;; Add to load path, add autoloads, and activate the package.
- (package-fixes--activate-autoloads-and-load-path pkg-desc)
- ;; Call `load' on all files in `package-desc-dir' already present in
- ;; `load-history'. This is done so that macros in these files are
updated
- ;; to their new definitions. If another package is being installed which
- ;; depends on this new definition, not doing this update would cause
- ;; compilation errors and break the installation.
- (with-demoted-errors "Error in package--load-files-for-activation: %s"
- (mapc (lambda (feature) (load feature nil t))
- ;; Skip autoloads file since we already evaluated it above.
- (remove (file-truename (package-fixes--autoloads-file-name
pkg-desc))
- loaded-files-list)))))
-
-
-;;; 24.1, 24.2, 24.3
- (defadvice package--make-autoloads-and-compile (around
fix-package--make-autoloads-and-compile
- (name pkg-dir)
activate)
- "Fixed `package--make-autoloads-and-compile'.
-Behave the same as `package--make-autoloads-and-compile', except
-it uses `package-fixes--load-files-for-activation' instead of just
-loading the autoloads file."
- (package-generate-autoloads name pkg-dir)
- (package-fixes--load-files-for-activation pkg-desc :reload)
- (let ((load-path (cons pkg-dir load-path)))
- ;; We must load the autoloads file before byte compiling, in
- ;; case there are magic cookies to set up non-trivial paths.
- (byte-recompile-directory pkg-dir 0 t)))
-
-;;; 24.4, 24.5
- (defadvice package--compile (after fix-package--compile (pkg-desc) activate)
- "Like `package--compile', but reload package first.
-Uses `package-fixes--load-files-for-activation' to reload files."
- (package-activate-1 pkg-desc)
- (package-fixes--load-files-for-activation pkg-desc :reload)
- (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
-
-(provide 'package-fixes)
-;;; package-fixes.el ends here
diff --git
a/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text
b/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text
deleted file mode 100644
index fa6dc6c..0000000
--- a/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-1/bar-file1.text
diff --git
a/packages/path-iterator/path-iterator-resources/alice-1/foo-file1.text
b/packages/path-iterator/path-iterator-resources/alice-1/foo-file1.text
deleted file mode 100644
index d83a9f4..0000000
--- a/packages/path-iterator/path-iterator-resources/alice-1/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-alice-1/foo-file1.text
diff --git
a/packages/path-iterator/path-iterator-resources/bob-1/bob-2/foo-file2.text
b/packages/path-iterator/path-iterator-resources/bob-1/bob-2/foo-file2.text
deleted file mode 100644
index 6bd9bdb..0000000
--- a/packages/path-iterator/path-iterator-resources/bob-1/bob-2/foo-file2.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-1/foo-file2.text
diff --git
a/packages/path-iterator/path-iterator-resources/bob-1/bob-3/foo-file3.text
b/packages/path-iterator/path-iterator-resources/bob-1/bob-3/foo-file3.text
deleted file mode 100644
index 2a3b1e9..0000000
--- a/packages/path-iterator/path-iterator-resources/bob-1/bob-3/foo-file3.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-2/foo-file5.text
diff --git a/packages/path-iterator/path-iterator-resources/file-0.text
b/packages/path-iterator/path-iterator-resources/file-0.text
deleted file mode 100644
index 0c7a9ac..0000000
--- a/packages/path-iterator/path-iterator-resources/file-0.text
+++ /dev/null
@@ -1 +0,0 @@
-just a file
diff --git a/packages/path-iterator/path-iterator-test.el
b/packages/path-iterator/path-iterator-test.el
deleted file mode 100644
index cf50461..0000000
--- a/packages/path-iterator/path-iterator-test.el
+++ /dev/null
@@ -1,203 +0,0 @@
-;;; path-iterator-test.el --- test for path-iterator.el.
-*-lexical-binding:t-*-
-
-;; Copyright (C) 2015, 2019 Free Software Foundation, Inc.
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Code:
-(require 'path-iterator)
-
-(defconst path-iter-root-dir
- (concat
- (file-name-directory (or load-file-name (buffer-file-name)))
- "path-iterator-resources/"))
-
-(defmacro path-iter-deftest (name-suffix path-non-recursive path-recursive
expected-dirs &optional ignore-function)
- "Define an ert test for path-iterator.
-EXPECTED-DIRS is a list of directory file names; it is compared
-with `equal' to a list of the results of running the path
-iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION."
- (declare (indent defun)
- (debug (symbolp "name-suffix")))
- `(ert-deftest ,(intern (concat "path-iter-test-" (symbol-name name-suffix)))
()
- (path-iter-test-run ,path-non-recursive ,path-recursive ,expected-dirs
,ignore-function)
- ))
-
-(defun path-iter-test-run-1 (iter expected-dirs)
- (let (dir computed-dirs)
- (while (setq dir (path-iter-next iter))
- (push dir computed-dirs))
- (should (null (path-iter-next iter)))
- (setq computed-dirs (nreverse computed-dirs))
- (should (equal computed-dirs expected-dirs))
- ))
-
-(defun path-iter-test-run (path-non-recursive path-recursive expected-dirs
ignore-function)
- (let ((iter (make-path-iterator
- :user-path-non-recursive path-non-recursive
- :user-path-recursive path-recursive
- :ignore-function ignore-function)))
- (path-iter-test-run-1 iter expected-dirs)
- (path-iter-restart iter)
- (path-iter-test-run-1 iter expected-dirs)
- ))
-
-(path-iter-deftest recursive
- nil ;; non-recursive
- (list path-iter-root-dir)
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- ))
-
-(path-iter-deftest non-recursive
- (list
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- (concat path-iter-root-dir "bob-1/bob-4/") ;; does not exist
- )
- nil ;; recursive
- (list
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- ))
-
-(path-iter-deftest both
- (list
- (concat path-iter-root-dir "alice-1/"))
- (list
- (concat path-iter-root-dir "bob-1/"))
- (list
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- (concat path-iter-root-dir "alice-1/")
- ))
-
-(path-iter-deftest dup
- (list
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/")) ;; non-recursive
- (list
- (concat path-iter-root-dir "bob-1/")) ;; recursive
- (list
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- (concat path-iter-root-dir "alice-1/")
- ))
-
-(defvar path-iter-ignore-bob nil
- "Set during test to change visited directories.")
-
-(defun path-iter-ignore-bob (dir)
- (string-equal path-iter-ignore-bob (file-name-nondirectory dir)))
-
-(ert-deftest path-iter-ignores-restart ()
- (let ((iter
- (make-path-iterator
- :user-path-non-recursive nil
- :user-path-recursive (list path-iter-root-dir)
- :ignore-function #'path-iter-ignore-bob)))
-
- (setq path-iter-ignore-bob "bob-2")
- (path-iter-test-run-1
- iter
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- ))
-
- (setq path-iter-ignore-bob "bob-3")
-
- (path-iter-restart iter);; not reset; does not recompute path
- (path-iter-test-run-1
- iter
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-3/")
- ))
-
- (path-iter-reset iter);; recomputes path
- (path-iter-test-run-1
- iter
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")
- (concat path-iter-root-dir "bob-1/")
- (concat path-iter-root-dir "bob-1/bob-2/")
- ))
- ))
-
-(ert-deftest path-iter-ignore-2 ()
- (let ((iter
- (make-path-iterator
- :user-path-non-recursive nil
- :user-path-recursive (list path-iter-root-dir)
- :ignore-function #'path-iter-ignore-bob)))
-
- (setq path-iter-ignore-bob "bob-1") ;; has child directories
- (path-iter-test-run-1
- iter
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")
- ))
- ))
-
-(ert-deftest path-iter-truename-nil ()
- (let ((default-directory path-iter-root-dir))
- (should
- (equal
- (path-iter--to-truename
- (list
- nil
- (concat path-iter-root-dir "alice-1/")))
- (list
- path-iter-root-dir
- (concat path-iter-root-dir "alice-1/")))
-
- )))
-
-(ert-deftest path-iter-all-files ()
- (let ((iter
- (make-path-iterator
- :user-path-non-recursive nil
- :user-path-recursive (list path-iter-root-dir))))
-
- (should
- (equal
- (path-iter-all-files iter)
- (list
- (concat path-iter-root-dir "bob-1/bob-3/foo-file3.text")
- (concat path-iter-root-dir "bob-1/bob-2/foo-file2.text")
- (concat path-iter-root-dir "alice-1/foo-file1.text")
- (concat path-iter-root-dir "alice-1/bar-file1.text")
- (concat path-iter-root-dir "file-0.text")
- )))
- ))
-
-(provide 'path-iterator-test)
-;;; path-iterator.el ends here
diff --git a/packages/path-iterator/path-iterator.el
b/packages/path-iterator/path-iterator.el
deleted file mode 100644
index efd651a..0000000
--- a/packages/path-iterator/path-iterator.el
+++ /dev/null
@@ -1,293 +0,0 @@
-;;; path-iterator.el --- An iterator for traversing a directory path.
-*-lexical-binding:t-*-
-
-;; Copyright (C) 2015 - 2017, 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Version: 1.0
-;; package-requires: ((emacs "25.0"))
-;;
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; A path-iterator object is created by `make-path-iterator', which
-;; takes keyword arguments:
-;;
-;; user-path-non-recursive: list of directories to return, in order given
-;;
-;; user-path-recursive: list of root directory trees to return; trees
-;; are explored in depth-first order, after all directories in
-;; `user-path-non-recursive' are returned.
-;;
-;; ignore-function: a function that takes one argument (an absolute
-;; directory name), and returns nil if directory should be returned,
-;; non-nil if not.
-;;
-;; Other functions:
-;;
-;; path-iter-next: return the next directory, or nil if done.
-;;
-;; path-iter-restart: restart iterator; next call to `path-iter-next'
-;; will return the first directory.
-;;
-;; path-iter-reset: clear internal caches; recompute the path. In
-;; normal operation, the directories returned from both the
-;; non-recursive and recursive path are cached in an array in the
-;; first iteration, and subsequent iterations just return items in
-;; that array. This avoids calling `directory-files' and the
-;; ignore-function on iterations after the first. `path-iter-reset'
-;; should be called if directories are added/deleted in the recursive
-;; path, or if the ignore-function is changed,
-;;
-;; path-iter-contains-root: non-nil if the iterator directory lists
-;; contain the given directory. For both the non-recursive and
-;; recursive lists, the given directory must be in the list; nested
-;; directories return nil.
-;;
-;; path-iter-expand-filename: expand a given filename against all the
-;; directories returned by the iterator, return the first one that
-;; exists, or nil if the filename exists in none of the directories.
-
-;;; Code:
-
-(cl-defstruct
- (path-iterator
- (:conc-name path-iter-)
- (:copier nil)
- (:constructor nil)
- (:constructor make-path-iterator
- (&key
- user-path-non-recursive
- user-path-recursive
- ignore-function
- &aux
- (path-non-recursive-init (path-iter--to-truename
user-path-non-recursive))
- (path-non-recursive path-non-recursive-init)
- (path-recursive-init (path-iter--to-truename
user-path-recursive))
- (path-recursive path-recursive-init)
- (visited nil)
- (current nil)
- (state nil))
- ))
-
- path-non-recursive-init ;; absolute directory file truenames, no recursion
- path-recursive-init ;; absolute directory file truenames, recurse into
subdirectories
-
- path-non-recursive ;; temp storage while iterating
- path-recursive ;; "
-
- ignore-function
- ;; Function called with absolute directory name; return non-nil
- ;; if it should be ignored.
-
- visited
- ;; During first iteration - list of directories already visited.
- ;; During subsequent iterations - vector of directories to visit
- ;;
- ;; We have to populate the visited list during the first iteration
- ;; in order to avoid visiting a directory twice, so we might as well
- ;; use it for subsequent iterations.
-
- current ;; index into `visited' during subsequent iterations
-
- state ;; one of nil, 'started, 'complete. Allows detecting interrupted
computation.
- )
-
-(defun path-iter--to-truename (path)
- "Convert each existing element of PATH to an absolute directory file
truename,
-return the resulting list. Elements of PATH are either absolute or
-relative to `default-directory'.
-
-If an element of PATH is nil, `default-directory' is used."
- ;; The nil handling is as defined by the `load-path' doc string.
- (unless (listp path)
- ;; Users often specify a single root directory, and forget it's
- ;; supposed to be a list.
- (setq path (list path)))
- (let (result)
- (cl-mapc
- (lambda (name)
- (let ((absname (if name
- (expand-file-name name)
- default-directory)))
- (when (file-directory-p absname)
- (push (file-name-as-directory (file-truename absname)) result))
- ))
- path)
- (nreverse result)))
-
-(cl-defmethod path-iter-next ((iter path-iterator))
- "Return the next directory to visit, or nil if there are no more.
-
-The iterator will first visit all elements of the recursive path,
-visiting all subdirectories of the recursive path for which
-`ignore-function' returns nil, in depth-first order (parent
-directories are visited before their subdirectories; sibling
-directories are visited after subdirectories); then visit all
-directories in the non-recursive path, but will not visit any
-directory more than once. The order of subdirectories within a
-directory is given by `directory-files'.
-
-`ignore-function' is passed one argument; the directory file
-name. Symlinks in the directory part are resolved, but the
-nondirectory part is the link name if it is a symlink.
-
-The directories returned by `path-iter-next' are absolute
-directory file truenames; they contain forward slashes, end in a
-slash, have casing that matches the existing directory file name,
-and resolve simlinks (see `file-truename')."
- (cond
- ((and (listp (path-iter-visited iter))
- (not (null (path-iter-path-recursive iter))))
- ;; First iteration, doing recursive path
-
- (let ((result (pop (path-iter-path-recursive iter)))
- subdirs)
-
- (while (member result (path-iter-visited iter))
- (setq result (pop (path-iter-path-recursive iter))))
-
- (when result
- (push result (path-iter-visited iter))
-
- ;; Push directories in `result' onto the path, to be visited
- ;; next. `directory-files' sorts the list.
- (cl-mapc
- (lambda (absname)
- (unless (or (string-equal "." (file-name-nondirectory absname))
- (string-equal ".." (file-name-nondirectory absname))
- (not (file-directory-p absname))
- ;; If `absname' is a symlink, we assume
- ;; `ignore-function' wants the link name.
- (and (path-iter-ignore-function iter)
- (funcall (path-iter-ignore-function iter) absname)))
- (push (file-name-as-directory (file-truename absname)) subdirs))
- )
- (directory-files result t))
-
- (setf (path-iter-path-recursive iter)
- (append
- (nreverse subdirs)
- (path-iter-path-recursive iter)))
- )
- (unless result
- (setf (path-iter-state iter) 'complete))
-
- result))
-
- ((and (listp (path-iter-visited iter))
- (not (null (path-iter-path-non-recursive iter))))
- ;; First iteration, doing non-recursive path
- (let ((result (pop (path-iter-path-non-recursive iter))))
-
- (while (member result (path-iter-visited iter))
- (setq result (pop (path-iter-path-non-recursive iter))))
-
- (when result
- (push result (path-iter-visited iter)))
-
- (unless result
- (setf (path-iter-state iter) 'complete))
-
- result))
-
- ((listp (path-iter-visited iter))
- ;; Both paths empty; first iteration done.
-
- (setf (path-iter-state iter) 'complete)
-
- nil)
-
- (t
- ;; Subsequent iterations; path-iter-visited changed to a vector
- (setf (path-iter-current iter) (1+ (path-iter-current iter)))
-
- (if (< (path-iter-current iter) (length (path-iter-visited iter)))
- (aref (path-iter-visited iter) (path-iter-current iter))
- (setf (path-iter-state iter) 'complete)
- nil))
- ))
-
-(cl-defmethod path-iter-restart ((iter path-iterator))
- "Restart ITER.
-Next call to `path-iter-next' will return first directory visited.
-Uses cached path computed during first iteration; see `path-iter-reset'."
- (if (eq 'started (path-iter-state iter))
- ;; compute was interrupted (probably by `while-no-input' in icomplete)
- (path-iter-reset iter)
-
- (cond
- ((null (path-iter-visited iter))
- ;; Not run first time yet
- (setf (path-iter-state iter) 'started))
-
- ((listp (path-iter-visited iter))
- ;; Run once; convert to vector
- (setf (path-iter-visited iter) (vconcat nil (nreverse (path-iter-visited
iter))))
- (setf (path-iter-current iter) -1))
-
- (t
- ;; Run more than once
- (setf (path-iter-current iter) -1))
- )))
-
-(cl-defmethod path-iter-reset ((iter path-iterator))
- "Reset ITER; recomputes path.
-Next call to `path-iter-next' will return first directory visited."
- (setf (path-iter-path-non-recursive iter) (path-iter-path-non-recursive-init
iter))
- (setf (path-iter-path-recursive iter) (path-iter-path-recursive-init iter))
- (setf (path-iter-visited iter) nil)
- (setf (path-iter-current iter) nil)
- (setf (path-iter-state iter) 'started)
- )
-
-(cl-defmethod path-iter-expand-filename ((iter path-iterator) filename)
- "Expand FILENAME with ITER.
-Return a list of absolute filenames or nil if none found."
- (path-iter-restart iter)
-
- (let (result dir)
- (while (setq dir (path-iter-next iter))
- (cl-mapc
- (lambda (filename)
- (push (concat (file-name-as-directory dir) filename) result))
- (file-name-all-completions filename dir)))
- result))
-
-(cl-defmethod path-iter-files ((iter path-iterator) pred)
- "Return all filenames in ITER satisfying predicate PRED.
-If non-nil, PRED is a function taking a single absolute file
-name; the file is included if PRED returns non-nil"
- (let (dir result)
- (path-iter-restart iter)
-
- (while (setq dir (path-iter-next iter))
- (mapc
- (lambda (absfile)
- (when (and (not (string-equal "." (substring absfile -1)))
- (not (string-equal ".." (substring absfile -2)))
- (not (file-directory-p absfile))
- (or (null pred)
- (funcall pred absfile)))
- (push absfile result)))
- (directory-files dir t))
- )
- result))
-
-(provide 'path-iterator)
-;;; path-iterator.el ends here.
diff --git a/packages/poker/poker.el b/packages/poker/poker.el
deleted file mode 100644
index 285015a..0000000
--- a/packages/poker/poker.el
+++ /dev/null
@@ -1,1101 +0,0 @@
-;;; poker.el --- Texas hold 'em poker
-
-;; Copyright (C) 2014, 2016 Free Software Foundation, Inc.
-
-;; Author: Mario Lang <mlang@delysid.org>
-;; Maintainer: Mario Lang <mlang@delysid.org>
-;; Version: 0.2
-;; Keywords: games
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; poker.el provides Texas hold 'em poker gameplay for Emacs.
-
-;;; Todo:
-
-;; * Provide a better user interface. A buffer should be used to keep
-;; the state and visual representation of a table/game.
-;; * Smarter AIs.
-
-;;; Requires:
-
-(require 'cl-lib)
-(require 'cookie1)
-(require 'ert)
-
-;;; Compatibility:
-
-(eval-and-compile
- (unless (fboundp 'cookie-shuffle-vector)
- (defalias 'cookie-shuffle-vector 'shuffle-vector)))
-
-;;; Constants:
-
-(defconst poker-ranks '(2 3 4 5 6 7 8 9 10 jack queen king ace))
-(defconst poker-suits '(clubs diamonds hearts spades))
-(defconst poker-deck (cl-loop for card from 0 to 51 collect card))
-(defconst poker-unicode-cards
- (let ((unicode-suit '((clubs . #xD0) (diamonds . #XC0)
- (hearts . #XB0) (spades . #XA0))))
- (apply #'vector
- (cl-loop for suit in poker-suits
- nconc
- (cl-loop for rank in poker-ranks
- collect
- (logior #x1f000
- (cdr (assq suit unicode-suit))
- (cond
- ((eq rank 'ace) #x1)
- ((eq rank 'jack) #xB)
- ((eq rank 'queen) #xD)
- ((eq rank 'king) #XE)
- (t rank))))))))
-(defconst poker-pre-flop-starting-hands
- '((AA 0.8551 0.7375 0.6422 0.5622 0.4946 0.4388 0.3907 0.349 0.3134 0.2828)
- (KK 0.8273 0.692 0.586 0.5022 0.4331 0.3785 0.332 0.2951 0.2638 0.2386)
- (QQ 0.8017 0.6536 0.5387 0.4525 0.3829 0.3298 0.2878 0.2535 0.2265 0.2045)
- (JJ 0.7781 0.6166 0.496 0.4072 0.3406 0.2904 0.2511 0.2214 0.1984 0.181)
- (TT 0.7538 0.5807 0.4568 0.3689 0.3044 0.2577 0.2238 0.1979 0.1771 0.1626)
- (99 0.7251 0.541 0.4159 0.33 0.2709 0.2293 0.1989 0.1767 0.1605 0.1483)
- (88 0.6965 0.5052 0.3808 0.2995 0.2443 0.2084 0.1818 0.1634 0.1499 0.1391)
- (AKs 0.6787 0.5185 0.425 0.3655 0.3216 0.2876 0.2602 0.2362 0.2179 0.2004)
- (AQs 0.6718 0.5059 0.4104 0.3492 0.3056 0.272 0.2451 0.2228 0.2042 0.1884)
- (77 0.6674 0.47 0.3492 0.2728 0.2231 0.1912 0.1685 0.1524 0.141 0.1331)
- (AJs 0.6637 0.495 0.398 0.3365 0.2927 0.2591 0.2337 0.2131 0.1956 0.1813)
- (AK 0.6614 0.4933 0.3965 0.334 0.29 0.2556 0.2257 0.2027 0.183 0.1647)
- (ATs 0.6575 0.4845 0.388 0.3266 0.2827 0.2508 0.2259 0.2057 0.1888 0.1747)
- (AQ 0.6532 0.4804 0.3804 0.3175 0.2726 0.2376 0.2101 0.1858 0.1683 0.1521)
- (AJ 0.6467 0.4673 0.3673 0.3029 0.258 0.2241 0.197 0.1752 0.1569 0.1414)
- (KQs 0.6438 0.4828 0.3937 0.3377 0.2947 0.2639 0.2374 0.2156 0.1977 0.1825)
- (A9s 0.6404 0.4606 0.3617 0.2999 0.2574 0.2263 0.2032 0.184 0.1689 0.1556)
- (66 0.6394 0.4383 0.3205 0.2499 0.2054 0.178 0.1582 0.145 0.1353 0.1278)
- (AT 0.6389 0.4582 0.3555 0.2918 0.2467 0.2134 0.1878 0.1664 0.1492 0.1347)
- (KJs 0.6365 0.4712 0.3824 0.3244 0.2829 0.2513 0.2265 0.2071 0.1893 0.1755)
- (A8s 0.633 0.4531 0.354 0.2915 0.2498 0.219 0.1972 0.1785 0.1638 0.1511)
- (KTs 0.6302 0.4631 0.3713 0.3137 0.2736 0.2418 0.2185 0.1991 0.184 0.1703)
- (A7s 0.6261 0.4434 0.3436 0.2827 0.2425 0.2123 0.1908 0.1732 0.1592 0.1477)
- (KQ 0.6254 0.4559 0.3644 0.3051 0.2626 0.2289 0.2038 0.1814 0.1632 0.1476)
- (A9 0.6208 0.4325 0.3282 0.2635 0.2192 0.1866 0.1631 0.1429 0.127 0.1146)
- (A5s 0.6182 0.4351 0.3396 0.2804 0.2413 0.2142 0.1928 0.1757 0.1621 0.1513)
- (KJ 0.6167 0.4443 0.3509 0.291 0.2484 0.2166 0.1916 0.1702 0.1528 0.1387)
- (A6s 0.6162 0.4318 0.3326 0.2743 0.2351 0.2073 0.1867 0.1697 0.1564 0.1451)
- (QJs 0.6138 0.455 0.3702 0.3156 0.2762 0.2453 0.2211 0.2019 0.1855 0.1721)
- (A8 0.6132 0.4234 0.3185 0.2537 0.2109 0.1794 0.1557 0.1368 0.1216 0.1096)
- (K9s 0.613 0.439 0.3458 0.2865 0.2474 0.2179 0.1955 0.1764 0.1616 0.1501)
- (55 0.6097 0.4074 0.2951 0.2291 0.1908 0.1655 0.1491 0.1365 0.1291 0.1219)
- (KT 0.6095 0.4344 0.3391 0.2795 0.2377 0.2062 0.182 0.1623 0.1463 0.133)
- (A4s 0.6091 0.4264 0.3308 0.2737 0.2366 0.2094 0.1882 0.172 0.1584 0.1474)
- (QTs 0.6076 0.4459 0.3607 0.3052 0.2658 0.237 0.2141 0.1956 0.1803 0.1675)
- (A7 0.6049 0.4124 0.3085 0.2448 0.2018 0.1723 0.1499 0.1312 0.1164 0.1052)
- (A3s 0.6008 0.4184 0.323 0.2675 0.2316 0.204 0.1847 0.1685 0.1555 0.1443)
- (K8s 0.5985 0.4194 0.3251 0.2685 0.2291 0.2015 0.1799 0.1634 0.1499 0.1393)
- (A5 0.5976 0.4047 0.3026 0.2409 0.2012 0.1734 0.1514 0.1336 0.1196 0.1084)
- (A6 0.5945 0.4012 0.2965 0.2347 0.194 0.1654 0.1443 0.1275 0.113 0.1022)
- (QJ 0.5937 0.4274 0.34 0.2836 0.2426 0.2115 0.1873 0.167 0.1503 0.1374)
- (A2s 0.5928 0.4081 0.3147 0.2597 0.2244 0.1985 0.1793 0.1629 0.1503 0.1397)
- (K7s 0.5927 0.4121 0.3174 0.2617 0.224 0.1961 0.1761 0.1594 0.1461 0.1359)
- (K9 0.5922 0.4092 0.3108 0.251 0.21 0.1798 0.1562 0.138 0.123 0.1105)
- (Q9s 0.5909 0.4223 0.3346 0.2789 0.2404 0.2122 0.1898 0.1725 0.1592 0.1476)
- (JTs 0.5894 0.4354 0.3532 0.3017 0.2633 0.2351 0.2124 0.1954 0.1807 0.1688)
- (A4 0.5876 0.3943 0.2932 0.2339 0.1949 0.1673 0.146 0.1295 0.1164 0.105)
- (QT 0.5863 0.4173 0.3283 0.2712 0.2323 0.2017 0.1778 0.1589 0.1448 0.1325)
- (K6s 0.5858 0.4038 0.3101 0.2543 0.2173 0.1918 0.1719 0.1556 0.1434 0.1332)
- (A3 0.5784 0.3846 0.2848 0.2266 0.1894 0.1616 0.1416 0.1249 0.1122 0.1014)
- (K5s 0.5776 0.3947 0.3024 0.2488 0.2136 0.1876 0.1683 0.1531 0.1408 0.1309)
- (44 0.577 0.3741 0.2686 0.2114 0.1776 0.1564 0.1432 0.133 0.1256 0.1194)
- (Q8s 0.5765 0.4026 0.3132 0.2586 0.2226 0.1955 0.1748 0.1593 0.1469 0.1353)
- (K8 0.576 0.3878 0.2887 0.2304 0.19 0.1616 0.1402 0.1234 0.1101 0.0984)
- (J9s 0.5725 0.4117 0.3281 0.2753 0.238 0.2106 0.1896 0.1725 0.1605 0.1493)
- (A2 0.5694 0.3739 0.2755 0.2185 0.1811 0.1552 0.1352 0.1197 0.1065 0.0967)
- (K7 0.5692 0.3787 0.2813 0.2232 0.1835 0.1565 0.1344 0.1187 0.1053 0.095)
- (K4s 0.5691 0.3866 0.2953 0.2425 0.2075 0.1829 0.1635 0.1501 0.1374 0.1286)
- (Q9 0.5686 0.3918 0.3001 0.2436 0.2039 0.1758 0.153 0.1357 0.1211 0.11)
- (JT 0.5667 0.4056 0.3221 0.2696 0.2296 0.2016 0.1779 0.1612 0.147 0.1349)
- (Q7s 0.5614 0.3831 0.2948 0.2419 0.2061 0.1813 0.1627 0.1474 0.1358 0.1262)
- (K6 0.5607 0.3704 0.2729 0.2152 0.1777 0.1498 0.1304 0.1151 0.1023 0.0915)
- (K3s 0.5597 0.3785 0.2889 0.236 0.2025 0.1787 0.1601 0.1459 0.1343 0.1254)
- (J8s 0.557 0.3918 0.3075 0.2559 0.2203 0.1946 0.1748 0.1584 0.1466 0.1367)
- (T9s 0.5558 0.4035 0.3256 0.2742 0.2394 0.2124 0.1918 0.1757 0.1636 0.1529)
- (Q6s 0.5555 0.3762 0.2888 0.2363 0.2023 0.1778 0.1585 0.1449 0.1332 0.1227)
- (K5 0.5538 0.3615 0.2648 0.2087 0.1721 0.1458 0.1263 0.1112 0.0996 0.0892)
- (Q8 0.5531 0.3708 0.2787 0.2229 0.1848 0.1556 0.136 0.1202 0.1069 0.0968)
- (K2s 0.5514 0.3692 0.281 0.2304 0.1985 0.1746 0.157 0.1436 0.1322 0.1231)
- (J9 0.5491 0.38 0.295 0.2415 0.203 0.1747 0.1539 0.1375 0.1233 0.1127)
- (Q5s 0.5484 0.3695 0.2808 0.2313 0.1969 0.1739 0.156 0.1417 0.1303 0.1215)
- (33 0.5454 0.3437 0.2457 0.1946 0.1665 0.1502 0.1385 0.1299 0.1234 0.1176)
- (K4 0.5436 0.3524 0.2563 0.2011 0.1659 0.1406 0.1215 0.107 0.0961 0.0865)
- (J7s 0.542 0.373 0.2874 0.2375 0.2036 0.1794 0.1599 0.1462 0.1349 0.1258)
- (T8s 0.5417 0.3852 0.3055 0.2551 0.2205 0.1962 0.1766 0.1626 0.1506 0.1406)
- (Q4s 0.5392 0.3613 0.2743 0.2248 0.1916 0.1689 0.1527 0.1388 0.1271 0.1189)
- (Q7 0.5371 0.35 0.2581 0.2035 0.1674 0.1411 0.122 0.1079 0.0956 0.0865)
- (K3 0.5354 0.3431 0.248 0.1946 0.1602 0.1353 0.1182 0.104 0.0925 0.0834)
- (J8 0.5321 0.3596 0.2722 0.2202 0.1833 0.1565 0.1372 0.1215 0.1094 0.0993)
- (T9 0.532 0.3736 0.2929 0.2411 0.2038 0.1777 0.1571 0.1415 0.1288 0.1185)
- (Q3s 0.5316 0.3524 0.2671 0.2189 0.1868 0.1654 0.1474 0.135 0.1246 0.1161)
- (Q6 0.5305 0.3429 0.2512 0.1976 0.1619 0.1367 0.1177 0.104 0.0923 0.0833)
- (98s 0.5275 0.3775 0.3009 0.2516 0.2168 0.1916 0.1729 0.1586 0.1464 0.1372)
- (T7s 0.5264 0.3655 0.2859 0.2377 0.2045 0.1817 0.163 0.1496 0.1385 0.1296)
- (J6s 0.5262 0.3532 0.2704 0.2217 0.1894 0.1659 0.1489 0.1359 0.1255 0.1169)
- (K2 0.5254 0.3331 0.24 0.1886 0.1549 0.1317 0.1142 0.1006 0.0891 0.0809)
- (Q5 0.5227 0.3354 0.2444 0.1907 0.1566 0.1326 0.1141 0.1006 0.0903 0.0815)
- (Q2s 0.5224 0.3438 0.2598 0.2137 0.1824 0.1609 0.1441 0.1318 0.122 0.1129)
- (J5s 0.5214 0.348 0.2658 0.2172 0.1855 0.1636 0.1469 0.134 0.1233 0.1147)
- (J7 0.5164 0.3379 0.2518 0.1995 0.1651 0.1403 0.1216 0.1075 0.0967 0.0878)
- (T8 0.5157 0.3522 0.2715 0.2207 0.1851 0.1596 0.1404 0.1262 0.1148 0.1057)
- (Q4 0.5132 0.3249 0.2352 0.1835 0.1506 0.1276 0.1103 0.0973 0.0867 0.0787)
- (J4s 0.5126 0.3397 0.2586 0.2115 0.1814 0.1586 0.1432 0.1306 0.1203 0.1122)
- (22 0.5125 0.3132 0.2256 0.1817 0.1587 0.1448 0.1355 0.1279 0.1224 0.1163)
- (97s 0.5122 0.3594 0.2829 0.2357 0.2028 0.1796 0.1615 0.1481 0.1384 0.1293)
- (T6s 0.5106 0.3468 0.2675 0.2204 0.189 0.1669 0.1505 0.1378 0.1277 0.1188)
- (Q3 0.5044 0.3162 0.2278 0.1774 0.1455 0.1227 0.1062 0.0936 0.0837 0.0757)
- (J3s 0.5043 0.3315 0.2506 0.2054 0.1755 0.1541 0.1394 0.1275 0.118 0.1094)
- (87s 0.5028 0.3567 0.2828 0.2358 0.2033 0.1805 0.1633 0.1514 0.1403 0.132)
- (98 0.5009 0.3446 0.2668 0.2159 0.181 0.1558 0.1372 0.1228 0.1122 0.1037)
- (T7 0.5001 0.332 0.2499 0.2011 0.1671 0.1433 0.1252 0.1119 0.1017 0.0931)
- (J6 0.5 0.3182 0.2334 0.1823 0.1496 0.1259 0.1095 0.0966 0.0863 0.0782)
- (96s 0.4971 0.3404 0.2646 0.2192 0.1884 0.1668 0.1503 0.1377 0.127 0.1188)
- (J2s 0.4954 0.3231 0.2437 0.1999 0.1717 0.1513 0.1359 0.1236 0.1147 0.1066)
- (T5s 0.4952 0.3292 0.2501 0.2063 0.1761 0.1549 0.1396 0.1282 0.1188 0.1109)
- (J5 0.4941 0.3118 0.2268 0.1775 0.1454 0.1231 0.1065 0.094 0.084 0.0764)
- (Q2 0.494 0.3072 0.2206 0.1709 0.1408 0.1189 0.1026 0.0906 0.0804 0.0725)
- (T4s 0.4888 0.3213 0.2456 0.2012 0.1722 0.1513 0.1368 0.1246 0.1151 0.108)
- (86s 0.4859 0.3388 0.2662 0.2214 0.1909 0.1698 0.1538 0.1419 0.1319 0.1236)
- (97 0.4856 0.3255 0.2475 0.1996 0.1664 0.1427 0.126 0.1121 0.1023 0.0944)
- (J4 0.4846 0.3039 0.2184 0.1714 0.139 0.1175 0.1021 0.0904 0.0809 0.0731)
- (T6 0.4834 0.3115 0.2304 0.182 0.151 0.1272 0.1116 0.0997 0.0899 0.0822)
- (95s 0.4814 0.3222 0.2477 0.2033 0.1747 0.1539 0.1385 0.1266 0.1165 0.1096)
- (T3s 0.4798 0.3138 0.2375 0.1955 0.167 0.1478 0.1332 0.1209 0.1128 0.1053)
- (76s 0.4789 0.3382 0.2676 0.223 0.193 0.1722 0.1572 0.1452 0.1356 0.1278)
- (J3 0.4757 0.2944 0.2106 0.1645 0.1336 0.1133 0.0983 0.0862 0.0775 0.0703)
- (87 0.474 0.3238 0.2478 0.1999 0.1677 0.1446 0.1279 0.1153 0.1056 0.0983)
- (T2s 0.4715 0.3056 0.2314 0.1892 0.1628 0.1435 0.1298 0.1183 0.1097 0.1029)
- (85s 0.4703 0.3206 0.2488 0.205 0.177 0.1573 0.1424 0.1304 0.1219 0.1147)
- (96 0.4686 0.3059 0.2284 0.1813 0.1499 0.1283 0.1122 0.1003 0.0912 0.0836)
- (T5 0.4664 0.2914 0.212 0.1656 0.1365 0.1158 0.1004 0.0893 0.0801 0.073)
- (J2 0.4663 0.2856 0.2039 0.1576 0.1293 0.109 0.0945 0.083 0.0748 0.0675)
- (75s 0.4643 0.3202 0.2515 0.2098 0.181 0.1614 0.1472 0.1366 0.1285 0.1198)
- (94s 0.4639 0.3041 0.231 0.1884 0.1609 0.1414 0.1268 0.1159 0.1066 0.1)
- (T4 0.4598 0.2851 0.2057 0.1602 0.1323 0.1114 0.097 0.0854 0.0769 0.07)
- (65s 0.459 0.3217 0.2533 0.2122 0.1848 0.1654 0.1509 0.14 0.1311 0.1242)
- (86 0.458 0.3037 0.2299 0.1833 0.1542 0.1319 0.117 0.1057 0.0973 0.0899)
- (93s 0.4572 0.2974 0.2253 0.1837 0.1563 0.1377 0.1238 0.1129 0.1036 0.0972)
- (84s 0.4532 0.3021 0.2313 0.1905 0.1627 0.144 0.1297 0.1195 0.11 0.1038)
- (95 0.4517 0.2862 0.2096 0.1641 0.1348 0.1135 0.0998 0.0884 0.0796 0.073)
- (76 0.4502 0.3041 0.2314 0.1868 0.1561 0.1357 0.121 0.1099 0.1011 0.0943)
- (T3 0.4499 0.2775 0.1983 0.1542 0.1266 0.107 0.0928 0.0817 0.0742 0.0677)
- (92s 0.4487 0.2899 0.2194 0.1789 0.1523 0.1339 0.1208 0.1103 0.102 0.095)
- (74s 0.4454 0.3023 0.2339 0.1936 0.1668 0.1489 0.1345 0.1243 0.1156 0.1089)
- (54s 0.444 0.3104 0.2435 0.2044 0.1786 0.1607 0.1483 0.1374 0.1288 0.1224)
- (64s 0.4408 0.3049 0.2382 0.1975 0.1717 0.1535 0.1408 0.13 0.1219 0.1154)
- (T2 0.4407 0.2683 0.191 0.1486 0.1214 0.1027 0.0893 0.0794 0.0713 0.0646)
- (85 0.4407 0.2852 0.2114 0.1665 0.1386 0.1189 0.1042 0.0944 0.0862 0.0793)
- (83s 0.4345 0.2832 0.2138 0.1747 0.1498 0.1318 0.1185 0.1087 0.1005 0.0938)
- (75 0.4337 0.2848 0.2133 0.1717 0.1426 0.1241 0.1104 0.1002 0.0927 0.0862)
- (94 0.4332 0.2656 0.1904 0.1475 0.1203 0.1008 0.0872 0.078 0.0698 0.0635)
- (65 0.4281 0.2868 0.2169 0.1749 0.1468 0.1281 0.1149 0.1055 0.0979 0.091)
- (82s 0.4279 0.2772 0.2094 0.1718 0.1463 0.1285 0.1159 0.1062 0.0978 0.0909)
- (73s 0.4276 0.2833 0.2168 0.1773 0.1528 0.1356 0.1224 0.1128 0.1048 0.0985)
- (93 0.4264 0.2592 0.1849 0.1423 0.1153 0.0971 0.0841 0.0739 0.0665 0.0601)
- (53s 0.4248 0.292 0.228 0.1898 0.1658 0.1497 0.1375 0.1278 0.119 0.113)
- (63s 0.4236 0.2853 0.2201 0.1818 0.158 0.141 0.1283 0.1191 0.1107 0.1042)
- (84 0.4216 0.2648 0.1921 0.1486 0.1236 0.1044 0.0917 0.0813 0.0733 0.0676)
- (92 0.4173 0.2511 0.1784 0.1368 0.1108 0.0928 0.0801 0.071 0.0635 0.0569)
- (43s 0.4156 0.2826 0.2189 0.1825 0.1585 0.1431 0.1306 0.1218 0.1136 0.1071)
- (74 0.4141 0.2652 0.1954 0.1535 0.1279 0.1097 0.0973 0.0879 0.0804 0.0742)
- (54 0.4126 0.2739 0.2055 0.1658 0.1406 0.1234 0.1113 0.102 0.0946 0.0891)
- (64 0.4102 0.2676 0.199 0.1594 0.134 0.1165 0.1043 0.0943 0.0871 0.0815)
- (72s 0.4092 0.2647 0.1999 0.1623 0.1399 0.1236 0.1122 0.1026 0.0951 0.0892)
- (52s 0.4076 0.2737 0.2106 0.1748 0.1523 0.1373 0.1252 0.1159 0.109 0.102)
- (62s 0.4052 0.2669 0.2036 0.1666 0.1437 0.1279 0.1163 0.1072 0.0997 0.0931)
- (83 0.4021 0.2436 0.1742 0.1335 0.1084 0.0912 0.0791 0.0707 0.0636 0.0581)
- (42s 0.3982 0.2653 0.2033 0.1684 0.1467 0.1317 0.121 0.1119 0.1052 0.0981)
- (82 0.3962 0.2374 0.1688 0.1292 0.1048 0.0881 0.0765 0.0677 0.0605 0.0548)
- (73 0.3955 0.2447 0.1761 0.1375 0.1123 0.0957 0.0838 0.0749 0.0685 0.0627)
- (53 0.3938 0.2548 0.1883 0.1505 0.1274 0.1118 0.1009 0.0915 0.0854 0.0799)
- (63 0.3911 0.2475 0.1809 0.1419 0.1182 0.1018 0.091 0.0823 0.0752 0.0706)
- (32s 0.3895 0.2562 0.1951 0.1609 0.1406 0.1258 0.1155 0.1066 0.0991 0.0931)
- (43 0.3826 0.2444 0.1789 0.1428 0.12 0.1046 0.0937 0.0855 0.079 0.0735)
- (72 0.3738 0.2244 0.1581 0.1218 0.0989 0.0835 0.0726 0.0647 0.0586 0.0538)
- (52 0.3736 0.2342 0.1694 0.1342 0.1121 0.0975 0.0866 0.0795 0.0734 0.0683)
- (62 0.3709 0.2273 0.1622 0.1257 0.1032 0.088 0.0777 0.0699 0.0639 0.0587)
- (42 0.3631 0.225 0.1632 0.1271 0.1073 0.0932 0.0828 0.0755 0.0693 0.0643)
- (32 0.3539 0.2162 0.1536 0.1202 0.0996 0.0859 0.0769 0.0698 0.0632
0.0584)))
-
-;;; Code:
-
-(defsubst poker-make-card (rank suit)
- "Make a poker card from RANK and SUIT.
-RANK is one of `poker-ranks' and SUIT is one of `poker-suits'."
- (cl-assert (memq rank poker-ranks))
- (cl-assert (memq suit poker-suits))
- (+ (* (cl-position suit poker-suits) 13) (cl-position rank poker-ranks)))
-
-(defsubst poker-card-rank (card)
- "The rank (a integer from 0 to 12) of a poker CARD."
- (cl-check-type card (integer 0 51))
- (% card 13))
-
-(defsubst poker-card-suit (card)
- "The suit (an integer from 0 to 3) of a poker CARD."
- (cl-check-type card (integer 0 51))
- (/ card 13))
-
-(defsubst poker-card-name (card)
- "The name of a poker CARD (a string of two characters)."
- (cl-check-type card (integer 0 51))
- (concat (aref ["2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A"]
- (poker-card-rank card))
- (aref ["c" "d" "h" "s"] (poker-card-suit card))))
-
-(defun poker-card-unicode (card)
- "The Unicode character for a poker CARD."
- (aref poker-unicode-cards card))
-
-(defun poker-hand-value (hand)
- "Calculate the value of a given 5 card poker HAND.
-The result is a 24 bit integer where the leftmost 4 bits (0-8) indicate the
type
-of hand, and the remaining nibbles are rank values of decisive cards.
-The highest possible value is therefore #x8CBA98 and the lowest is #x053210."
- (let* ((rank-counts (sort (let ((cards hand) result)
- (while cards
- (let ((rank (poker-card-rank (car cards))))
- (unless (rassq rank result)
- (push (cons (let ((count 1))
- (dolist (card (cdr cards)
count)
- (when (eq (poker-card-rank
card)
- rank)
- (setq count (1+ count)))))
- rank)
- result)))
- (setq cards (cdr cards)))
- result)
- (lambda (lhs rhs) (or (> (car lhs) (car rhs))
- (and (= (car lhs) (car rhs))
- (> (cdr lhs) (cdr
rhs)))))))
- (ranks-length (length rank-counts))
- (ranks (mapcar #'cdr rank-counts)))
- (setq rank-counts (mapcar #'car rank-counts))
- (logior (cond
- ((eq ranks-length 4) #x100000)
- ((eq ranks-length 5)
- (let ((straight (or (when (and (eq (nth 0 ranks) 12)
- (eq (nth 1 ranks) 3))
- (setq ranks '(3 2 1 0 0)))
- (eq (- (nth 0 ranks) (nth 4 ranks)) 4)))
- (flush (let ((suit (poker-card-suit (car hand)))
- (tail (cdr hand)))
- (while (and tail
- (eq suit (poker-card-suit (car tail))))
- (setq tail (cdr tail)))
- (not tail))))
- (cond ((and straight flush) #x800000)
- (straight #x400000)
- (flush #x500000)
- (t 0))))
- ((equal rank-counts '(2 2 1)) #x200000)
- ((equal rank-counts '(3 1 1)) #x300000)
- ((equal rank-counts '(3 2)) #x600000)
- ((equal rank-counts '(4 1)) #x700000))
- (ash (nth 0 ranks) 16)
- (ash (nth 1 ranks) 12)
- (if (> ranks-length 2) (ash (nth 2 ranks) 8) 0)
- (if (> ranks-length 3) (ash (nth 3 ranks) 4) 0)
- (if (> ranks-length 4) (nth 4 ranks) 0))))
-
-(defun poker-hand-> (hand1 hand2)
- "Return non-nil if HAND1 is better than HAND2."
- (> (poker-hand-value hand1) (poker-hand-value hand2)))
-
-(defun poker-sort-hands (hands)
- "Sort HANDS (a list of list of cards) according to the value of the
individual hands."
- (mapcar #'cdr
- (cl-sort (mapcar (lambda (hand) (cons (poker-hand-value hand) hand))
hands)
- #'> :key #'car)))
-
-(defun poker-combinations (n list)
- "A list of all unique ways of taking N different elements from LIST."
- (when list
- (let ((length (length list)))
- (nconc (if (eq n 1)
- (list (if (cdr list) (list (car list)) list))
- (if (eq n length)
- (list list)
- (mapcar (lambda (rest) (cons (car list) rest))
- (poker-combinations (1- n) (cdr list)))))
- (when (> length n) (poker-combinations n (cdr list)))))))
-
-(defun poker-possible-hands (cards)
- "Generate a list of possible 5 card poker hands from CARDS.
-CARDS is a list of 5 to 7 poker cards."
- (cl-check-type (length cards) (integer 5 7))
- (cond
- ;; While this could certainly be made generic,
- ;; the performance of this hand-crafted implementation is unmatched.
- ((eq 7 (length cards))
- (let ((car (car cards))
- (cdr (cdr cards)))
- (let ((cadr (car cdr))
- (cddr (cdr cdr)))
- (let ((caddr (car cddr))
- (cdddr (cdr cddr)))
- (let ((cadddr (car cdddr))
- (cddddr (cdr cdddr)))
- (let ((caddddr (car cddddr))
- (cdddddr (cdr cddddr)))
- (let ((cadddddr (car cdddddr))
- (cddddddr (cdr cdddddr)))
- (list (list car cadr caddr cadddr caddddr)
- (list car cadr caddr cadddr cadddddr)
- (cons car (cons cadr (cons caddr (cons cadddr cddddddr))))
- (list car cadr caddr caddddr cadddddr)
- (cons car (cons cadr (cons caddr (cons caddddr
cddddddr))))
- (cons car (cons cadr (cons caddr cdddddr)))
- (cons car (cons cadr (butlast cdddr)))
- (cons car (cons cadr (cons cadddr (cons caddddr
cddddddr))))
- (cons car (cons cadr (cons cadddr cdddddr)))
- (cons car (cons cadr cddddr))
- (cons car (butlast cddr))
- (cons car (cons caddr (cons cadddr (cons caddddr
cddddddr))))
- (cons car (cons caddr (cons cadddr cdddddr)))
- (cons car (cons caddr cddddr))
- (cons car cdddr)
- (butlast cdr)
- (cons cadr (cons caddr (cons cadddr (cons caddddr
cddddddr))))
- (cons cadr (cons caddr (cons cadddr cdddddr)))
- (cons cadr (cons caddr cddddr))
- (cons cadr cdddr)
- cddr))))))))
- (t (poker-combinations 5 cards))))
-
-(defun poker-best-hand (cards)
- "Find the best hand for a number of CARDS (usually a list of 6 or 7
elements)."
- (let ((max 0) (best-hand nil))
- (dolist (hand (poker-possible-hands cards) best-hand)
- (let ((value (poker-hand-value hand)))
- (when (> value max) (setq max value best-hand hand))))))
-
-(defun poker-rank-to-string (rank)
- "The english name of poker card RANK."
- (aref ["2" "3" "4" "5" "6" "7" "8" "9" "10" "jack" "queen" "king" "ace"]
rank))
-
-(defun poker-rank-to-plural-string (rank)
- "The plural english name of poker card RANK."
- (concat (poker-rank-to-string rank) "s"))
-
-(defun poker-describe-hand (hand)
- "Return a string description of the value of the given poker HAND.
-HAND is a list of 5 poker cards."
- (cl-assert (eq (length hand) 5))
- (pcase (let ((value (poker-hand-value hand)))
- (cl-loop for i from 5 downto 0 collect (logand (ash value (- (* i
4))) #xf)))
- (`(8 ,high ,_ ,_ ,_ ,_) (pcase high
- (12 "royal flush")
- (_ (format "%s high straight flush"
- (poker-rank-to-string high)))))
- (`(7 ,four ,high 0 0 0) (format "four %s, %s high"
- (poker-rank-to-plural-string four)
- (poker-rank-to-string high)))
- (`(6 ,three ,two 0 0 0) (format "full house of %s and %s"
- (poker-rank-to-plural-string three)
- (poker-rank-to-plural-string two)))
- (`(5 ,high ,k1 ,k2 ,k3 ,k4) (format "%s high flush, %s %s %s and %s
kickers"
- (poker-rank-to-string high)
- (poker-rank-to-string k1)
- (poker-rank-to-string k2)
- (poker-rank-to-string k3)
- (poker-rank-to-string k4)))
- (`(4 ,high ,_ ,_ ,_ ,_) (pcase high
- (3 "5 high straight (steel wheel)")
- (_ (format "%s high straight"
- (poker-rank-to-string high)))))
- (`(3 ,three ,high ,kicker 0 0) (format "three %s, %s high, %s kicker"
- (poker-rank-to-plural-string three)
- (poker-rank-to-string high)
- (poker-rank-to-string kicker)))
- (`(2 ,two1 ,two2 ,high 0 0) (format "two pairs of %s and %s, %s high"
- (poker-rank-to-plural-string two1)
- (poker-rank-to-plural-string two2)
- (poker-rank-to-string high)))
- (`(1 ,two ,high ,k1 ,k2 0) (format "a pair of %s, %s high, %s and %s
kickers"
- (poker-rank-to-plural-string two)
- (poker-rank-to-string high)
- (poker-rank-to-string k1)
- (poker-rank-to-string k2)))
- (`(0 ,high ,k1 ,k2 ,k3 ,k4) (format "high card %s, %s %s %s and %s kickers"
- (poker-rank-to-string high)
- (poker-rank-to-string k1)
- (poker-rank-to-string k2)
- (poker-rank-to-string k3)
- (poker-rank-to-string k4)))))
-
-(defun poker-random-deck ()
- "Return a shuffled deck of 52 poker cards."
- (append (cookie-shuffle-vector (apply 'vector poker-deck)) nil))
-
-(defun poker-strength (pocket &optional community opponents)
- "Estimate the strength of POCKET and COMMUNITY cards against number of
OPPONENTS.
-The optional number of OPPONENTS defaults to 1."
- (or (and (not community)
- (nth (or opponents 1)
- (assq (poker-starting-hand-name pocket)
- poker-pre-flop-starting-hands)))
- (let ((wins 0) (iterations 300))
- (dotimes (i iterations)
- (let ((deck (poker-random-deck))
- (players (make-vector (or opponents 1) nil)))
- (dolist (card pocket) (setq deck (delete card deck)))
- (dolist (card community) (setq deck (delete card deck)))
- (dotimes (cards 2)
- (dotimes (player (or opponents 1))
- (push (pop deck) (aref players player))))
- (let ((board (append community nil)))
- (dotimes (_ (- 5 (length community)))
- (push (pop deck) board))
- (setq wins (+ wins (caar (cl-sort
- (mapcar (lambda (info)
- (setcdr info (poker-best-hand
- (append (cdr
info) board)))
- info)
- (nconc (list (cons 1 pocket))
- (mapcar (lambda (cards)
- (cons 0 cards))
- players)))
- #'poker-hand-> :key #'cdr)))))))
- (/ (float wins) iterations))))
-
-(defun poker-starting-hand-name (pocket)
- (cl-assert (eq (length pocket) 2))
- (cl-assert (not (eq (nth 0 pocket) (nth 1 pocket))))
- (let ((rank-name (vector "2" "3" "4" "5" "6" "7" "8" "9" "T"
- "J" "Q" "K" "A"))
- (rank1 (poker-card-rank (nth 0 pocket)))
- (rank2 (poker-card-rank (nth 1 pocket)))
- (suited (eq (poker-card-suit (nth 0 pocket))
- (poker-card-suit (nth 1 pocket)))))
- (when (< rank1 rank2)
- (let ((tmp rank1))
- (setq rank1 rank2 rank2 tmp)))
- (if (and (< rank1 (cl-position 10 poker-ranks))
- (< rank2 (cl-position 10 poker-ranks))
- (not suited))
- (+ (* (+ rank1 2) 10) (+ rank2 2))
- (intern (concat (aref rank-name rank1)
- (aref rank-name rank2)
- (when suited "s"))))))
-
-(defun poker-pre-flop-starting-hands (opponents)
- (let (hands)
- (dolist (rank1 poker-ranks (cl-sort hands #'> :key #'cdr))
- (dolist (rank2 poker-ranks)
- (if (eq rank1 rank2)
- (push (let ((pocket (list (poker-make-card rank1 'clubs)
- (poker-make-card rank2 'hearts))))
- (cons (poker-strength pocket nil opponents)
- (poker-starting-hand-name pocket)))
- hands)
- (when (< (cl-position rank1 poker-ranks)
- (cl-position rank2 poker-ranks))
- (let ((tmp rank1))
- (setq rank1 rank2
- rank2 tmp)))
- (dolist (suited '(nil t))
- (let* ((pocket (list (poker-make-card rank1 'clubs)
- (poker-make-card rank2 (if suited
- 'clubs 'hearts))))
- (code (poker-starting-hand-name pocket)))
- (unless (rassq code hands)
- (accept-process-output)
- (message "%S" code)
- (push (cons (poker-strength pocket nil opponents)
- code)
- hands)))))))))
-
-(defun poker-pot-odds (bet pot)
- "Return the odds when BET is added to POT."
- (/ (float bet) (+ pot bet)))
-
-(defun poker-random-fold-call-raise (fold% call% raise%)
- "Randomly choose between FOLD%, CALL% and RAISE%."
- (cl-assert (= (+ fold% call% raise%) 100))
- (let ((value (random 100)))
- (cond
- ((< value fold%) 'fold)
- ((< value (+ fold% call%)) 'call)
- ((< value (+ fold% call% raise%)) 'raise)
- (t (error "Random FCR Error")))))
-
-(defun poker-make-player (name fcr-fn)
- "Create a new poker player with NAME and FCR-FN.
-FCR-FN specifies a function to use when a fold-call-raise decision is
required."
- (list (cons 'name name)
- (cons 'stack 0)
- (cons 'wagered 0)
- (cons 'pocket nil)
- (cons 'fcr-fn fcr-fn)))
-
-(defun poker-player-name (player)
- "Return the name of poker PLAYER."
- (cdr (assq 'name player)))
-
-(defun poker-player-stack (player)
- "Return the remaining stack of poker PLAYER."
- (cdr (assq 'stack player)))
-
-(defun poker-player-bet (player amount)
- "Make PLAYER bet AMOUNT of chips."
- (let ((actual (min (poker-player-stack player) amount)))
- (when (zerop actual) (message "WARNING: Actual is 0."))
- (unless (zerop actual)
- (cl-decf (cdr (assq 'stack player)) actual)
- (cl-incf (cdr (assq 'wagered player)) actual))
- actual))
-
-(defun poker-player-payout (player amount)
- "Give PLAYER AMOUNT of chips."
- (cl-incf (cdr (assq 'stack player)) amount)
- amount)
-
-(defun poker-player-wagered (player)
- "Return the amount of chips currently wagered by poker PLAYER."
- (cdr (assq 'wagered player)))
-
-(defun poker-player-pocket (player)
- "Return the current pocket (hole) cards of PLAYER."
- (cdr (assq 'pocket player)))
-
-(defun poker-player-fold (player)
- "Make PLAYER fold and forget about their cards."
- (setcdr (assq 'pocket player) nil))
-
-(defun poker-player-active-p (player)
- (and (poker-player-pocket player) (> (poker-player-wagered player) 0)))
-
-(defun poker-player-all-in-p (player)
- (and (poker-player-active-p player) (zerop (poker-player-stack player))))
-
-(defun poker-player-can-bet-p (player)
- (and (poker-player-pocket player) (> (poker-player-stack player) 0)))
-
-(defun poker-player-best-hand (player community)
- (cl-assert (>= (length (poker-player-pocket player)) 2))
- (cl-assert (>= (length community) 3))
- (poker-best-hand (append (poker-player-pocket player) community)))
-
-(defun poker-player-give-card (player card)
- (cl-check-type card (integer 0 51))
- (push card (cdr (assq 'pocket player))))
-
-(defun poker-player-fcr-fn (player)
- (cdr (assq 'fcr-fn player)))
-
-(defun poker-player-fcr (player pot amount-to-call max-raise board opponents)
- (funcall (poker-player-fcr-fn player)
- player pot amount-to-call max-raise board opponents))
-
-(defun poker-read-fold-call-raise (pot to-call max-raise &optional prompt)
- (let ((cursor-in-echo-area t)
- (map (let ((map (make-sparse-keymap)))
- (define-key map [?c] 'call)
- (define-key map [?f] 'fold)
- (when (> max-raise 0) (define-key map [?r] 'raise))
- (define-key map [?q] 'quit)
- map))
- (action nil))
- (while (not action)
- (message (format "%s%d in pot, %d to call: (f)old%s: "
- (or prompt "") pot to-call
- (if (> max-raise 0)
- (if (zerop to-call)
- ", (c)heck or (r)aise"
- ", (c)all or (r)aise")
- (if (zerop to-call)
- " or (c)heck"
- " or (c)all"))))
- (setq action (lookup-key map (vector (read-event)))))
- (cond
- ((eq action 'fold) nil)
- ((eq action 'call) to-call)
- ((eq action 'raise) (+ to-call (let ((raise (1+ max-raise)))
- (while (> raise max-raise)
- (setq raise
- (read-number (format "Raise by
(max %d): "
- max-raise))))
- (cl-check-type raise integer)
- raise))))))
-
-(defun poker-interactive-fcr (player pot due max-raise board opponents)
- (poker-read-fold-call-raise
- pot due max-raise (format "%s%s, %d stack, "
- (mapconcat #'poker-card-name (poker-player-pocket
player) ", ")
- (if board
- (concat "(" (mapconcat #'poker-card-name board
" ") ")")
- "")
- (poker-player-stack player))))
-
-(defun poker-automatic-fcr (player pot due max-raise board &optional opponents)
- (let* ((strength (poker-strength (poker-player-pocket player) board
opponents))
- (pot-odds (poker-pot-odds due pot))
- (rate-of-return (/ strength pot-odds))
- (action (cond
- ((< rate-of-return 0.8) (poker-random-fold-call-raise 95 1 4))
- ((< rate-of-return 1.0) (poker-random-fold-call-raise 80 15
5))
- ((< rate-of-return 1.3) (poker-random-fold-call-raise 0 60
40))
- (t (poker-random-fold-call-raise 0 25 75)))))
- (when (and (memq action '(call raise))
- (< (- (poker-player-stack player) due) 200) (< strength 0.5))
- (setq action 'fold))
- (when (and (eq action 'raise) (< strength 0.1))
- (setq action 'call))
- (when (and (zerop due) (eq action 'fold))
- (setq action 'call))
- (cond
- ((eq action 'fold) nil)
- ((eq action 'call) due)
- ((eq action 'raise) (+ due (min 100 max-raise))))))
-
-(defun poker-rotate-to-first (player players)
- "Make PLAYER the first element of PLAYERS."
- (let ((position (cl-position player players)))
- (when position
- (let ((shift (- (length players) position)))
- (append (last players shift) (butlast players shift))))))
-
-(defun poker-next-players (player players)
- (cdr (poker-rotate-to-first player players)))
-
-(defun poker-next-player (player players)
- (car (poker-next-players player players)))
-
-(defun poker-pot (players)
- "Return the amount of chips in the pot, the total wagered by all PLAYERS."
- (apply #'+ (mapcar #'poker-player-wagered players)))
-
-(defun poker-current-wager (players)
- "Determine the maximum amount of chips wagered by any of PLAYERS."
- (apply #'max (mapcar #'poker-player-wagered players)))
-
-(defun poker-collect-wager (amount players)
- "Collect AMOUNT of wager from PLAYERS."
- (let ((total 0))
- (dolist (player players total)
- (let ((wagered (assq 'wagered player)))
- (if (> amount (cdr wagered))
- (progn
- (setq total (+ total (cdr wagered)))
- (setcdr wagered 0))
- (setq total (+ total amount))
- (setcdr wagered (- (cdr wagered) amount)))))))
-
-(defun poker-distribute-winnings (winners players)
- "Distribute chips to WINNERS from PLAYERS accounting for split-pot rules."
- (cl-assert (not (null winners)))
- (cl-assert (> (length players) 1))
- (if (= (length winners) 1)
- (poker-player-payout (car winners)
- (poker-collect-wager (poker-player-wagered (car
winners))
- players))
- (let* ((lowest (apply #'min (mapcar #'poker-player-wagered winners)))
- (total (poker-collect-wager lowest players))
- (each (/ total (length winners)))
- (leftover (- total (* each (length winners)))))
- (poker-player-payout (car winners) (+ each leftover))
- (dolist (player (cdr winners)) (poker-player-payout player each))
- total)))
-
-(defun poker-player-max-raise (player players)
- "Determine the maximum amount allowed to raise for PLAYER considering
PLAYERS stacks."
- (let ((other-stacks (mapcar #'poker-player-stack
- (cl-remove
- player
- (cl-remove-if-not #'poker-player-can-bet-p
players)))))
- (min (poker-player-stack player) (if other-stacks (apply #'max
other-stacks) 0))))
-
-(defun poker-interactive-p (players)
- (cl-find #'poker-interactive-fcr players :key #'poker-player-fcr-fn))
-
-(defun poker-dealer-ask-player (player players board allow-raise)
- "Ask PLAYER for next action."
- (let ((pot (poker-pot players))
- (max-raise (if allow-raise (poker-player-max-raise player players) 0))
- (amount-to-call (- (poker-current-wager players)
- (poker-player-wagered player)))
- (opponents (1- (length (cl-remove-if-not #'poker-player-pocket
players)))))
- (cl-assert (> opponents 0))
- (let ((decision (poker-player-fcr player pot amount-to-call max-raise
- board opponents)))
- (cl-assert (or (null decision)
- (and (integerp decision)
- (<= (- decision amount-to-call) max-raise))))
- (cond
- ((null decision)
- (message (format "%s folds." (poker-player-name player)))
- (poker-player-fold player))
- ((zerop decision)
- (message "%s checks." (poker-player-name player)))
- ((integerp decision)
- (if (= decision amount-to-call)
- (message "%s calls %d." (poker-player-name player) decision)
- (cl-assert (>= decision amount-to-call))
- (message "%s raises by %d."
- (poker-player-name player) (- decision amount-to-call)))
- (poker-player-bet player decision))))))
-
-(defun poker-dealer (min-bet deck board players)
- "Deal a round of texas holdem poker with MIN-BET for PLAYERS."
- (cl-assert (> (length players) 1))
- (cond
- ;; pre-flop
- ((and (null board) (zerop (poker-pot players)))
- (let ((blinds players))
- (message "Collecting blinds.")
- (message "%s posts %d small blind." (poker-player-name (car blinds)) (/
min-bet 2))
- (poker-player-bet (car blinds) (/ min-bet 2))
- (message "%s posts %d big blind." (poker-player-name (cadr blinds))
min-bet)
- (poker-player-bet (cadr blinds) min-bet)
- (message "Dealing cards to players.")
- (dotimes (_ 2)
- (dolist (player players) (poker-player-give-card player (pop deck))))
-
- (message "Initial betting round.")
-
- (dolist (player (poker-next-players (cadr blinds) players))
-
- (unless (zerop (poker-player-stack player))
- (poker-dealer-ask-player player players board t)))
-
- (when (and (not (zerop (poker-player-stack (cadr blinds))))
- (or (> (length (cl-remove-if-not #'poker-player-can-bet-p
players)) 1)
- (< (poker-player-wagered (cadr blinds))
- (poker-current-wager players))))
- (poker-dealer-ask-player (cadr blinds) players board t))
-
- (poker-dealer min-bet deck board players)))
-
- ;; All but one have folded
- ((and (not (zerop (poker-pot players)))
- (= (length (cl-remove-if-not #'poker-player-active-p players)) 1))
- (let ((winners (cl-remove-if-not #'poker-player-active-p players)))
- (message "%s silently wins %d."
- (poker-player-name (car winners))
- (poker-distribute-winnings winners players))
- winners))
-
- ;; pre-flop, second round of bets, no raises allowed
- ((and (null board) (cl-remove-if
- (lambda (player)
- (or (zerop (poker-player-wagered player))
- (not (poker-player-pocket player))
- (poker-player-all-in-p player)
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- (poker-rotate-to-first (cadr players) players)))
-
- (message "Pre flop, second round of bets.")
-
- (dolist (player (cl-remove-if
- (lambda (player)
- (or (zerop (poker-player-wagered player))
- (not (poker-player-pocket player))
- (poker-player-all-in-p player)
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- (poker-rotate-to-first (cadr players) players)))
- (when (or (> (length (cl-remove-if-not #'poker-player-can-bet-p
players)) 1)
- (< (poker-player-wagered player) (poker-current-wager players)))
- (poker-dealer-ask-player player players board nil)))
-
- (poker-dealer min-bet deck board players))
-
- ;; flop
- ((null board)
- (dotimes (_ 3) (push (pop deck) board))
-
- (message "The flop: %s" (mapconcat #'poker-card-name board " "))
-
- (dolist (player (cl-remove-if-not #'poker-player-can-bet-p players))
- (when (or (> (length (cl-remove-if-not #'poker-player-can-bet-p
players)) 1)
- (< (poker-player-wagered player) (poker-current-wager players)))
- (poker-dealer-ask-player player players board t)))
-
- (poker-dealer min-bet deck board players))
-
- ;; flop, second round of bets, no raises allowed
- ((and (= (length board) 3) (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (message "The flop, second round of bets.")
- (dolist (player (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (poker-dealer-ask-player player players board nil))
-
- (poker-dealer min-bet deck board players))
-
- ;; turn
- ((= (length board) 3)
- (push (pop deck) board)
-
- (message "The turn: %s" (mapconcat #'poker-card-name board " "))
-
- (setq min-bet (* min-bet 2))
-
- (dolist (player (cl-remove-if-not #'poker-player-can-bet-p players))
- (when (or (> (length (cl-remove-if-not #'poker-player-can-bet-p
players)) 1)
- (< (poker-player-wagered player) (poker-current-wager players)))
- (poker-dealer-ask-player player players board t)))
-
- (poker-dealer min-bet deck board players))
-
- ;; turn, second round of bets, no raises allowed
- ((and (= (length board) 4) (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (message "The turn, second round of bets.")
- (dolist (player (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (poker-dealer-ask-player player players board nil))
-
- (poker-dealer min-bet deck board players))
-
- ;; river
- ((= (length board) 4)
- (push (pop deck) board)
- (message "The river: %s" (mapconcat #'poker-card-name board " "))
-
- (dolist (player (cl-remove-if-not #'poker-player-can-bet-p players))
- (when (or (> (length (cl-remove-if-not #'poker-player-can-bet-p
players)) 1)
- (< (poker-player-wagered player) (poker-current-wager players)))
- (poker-dealer-ask-player player players board t)))
-
- (poker-dealer min-bet deck board players))
-
- ;; river, second round of bets, no raises allowed
- ((and (= (length board) 5) (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (message "Last betting round.")
- (dolist (player (cl-remove-if
- (lambda (player)
- (or (not (poker-player-can-bet-p player))
- (= (poker-player-wagered player)
- (poker-current-wager players))))
- players))
- (poker-dealer-ask-player player players board nil))
-
- (poker-dealer min-bet deck board players))
-
- ;; showdown
- ((= (length board) 5)
- (cl-assert (not (zerop (poker-pot players))))
- (let ((in-play (cl-remove-if-not #'poker-player-active-p players))
- (groups ())
- (game-interactive-p (poker-interactive-p players)))
- (unless (> (length in-play) 1)
- (error "In-play to small: %S %S" in-play players))
- (while in-play
- (if (= (length in-play) 1)
- (progn
- (message "%s wins %d."
- (poker-player-name (car in-play))
- (poker-distribute-winnings in-play players))
- (when game-interactive-p (sit-for 2))
- (push in-play groups)
- (setq in-play nil))
- (let* ((best-hand-value (poker-hand-value
- (car
- (poker-sort-hands
- (mapcar (lambda (player)
- (poker-player-best-hand player
board))
- in-play)))))
- (winners (cl-remove-if (lambda (player)
- (< (poker-hand-value
- (poker-player-best-hand player
board))
- best-hand-value))
- in-play)))
- (dolist (player in-play)
- (message "%s shows %s, %s."
- (poker-player-name player)
- (mapconcat #'poker-card-name (poker-player-pocket
player) " ")
- (poker-describe-hand (poker-player-best-hand player
board)))
- (when game-interactive-p (sit-for 2)))
- (message "%s wins %d."
- (mapconcat #'poker-player-name winners ", ")
- (poker-distribute-winnings winners players))
- (when game-interactive-p (sit-for 2))
- (push winners groups))
- (setq in-play (cl-remove-if-not #'poker-player-active-p players))))
-
- (cons board (nreverse groups))))
-
- (t (list 'error min-bet deck board players))))
-
-;;;###autoload
-(defun poker (initial-stack min-bet players)
- "Play a game of texas hold 'em poker."
- (interactive (list (read-number "Initial stack: " 1000)
- (read-number "Minimum bet: " 50)
- (list (poker-make-player "Angela" #'poker-automatic-fcr)
- (poker-make-player "Bettina" #'poker-automatic-fcr)
- (poker-make-player "Christina" #'poker-automatic-fcr)
- (poker-make-player "Daniela" #'poker-automatic-fcr)
- (poker-make-player "Emil" #'poker-automatic-fcr)
- (poker-make-player "Frank" #'poker-automatic-fcr)
- (poker-make-player "Günther" #'poker-automatic-fcr)
- (poker-make-player "Harald" #'poker-automatic-fcr)
- (poker-make-player "Ingrid" #'poker-automatic-fcr)
- (poker-make-player (user-full-name)
#'poker-interactive-fcr))))
- (cl-assert (> (length players) 1))
- (dolist (player players)
- (message "%s receives %d chips." (poker-player-name player) initial-stack)
- (setcdr (assq 'stack player) initial-stack))
- (let ((game-interactive-p (poker-interactive-p players))
- (button-player (nth (random (length players)) players))
- (rounds ())
- (losers ()))
- (setq players (poker-rotate-to-first button-player players))
- (while (and button-player
- (or (not game-interactive-p)
- (poker-interactive-p players)))
- (message "Round %d, %d players." (1+ (length rounds)) (length players))
-
- (push (poker-dealer min-bet (poker-random-deck) () players)
- rounds)
-
- (mapc #'poker-player-fold players)
- (setq button-player
- (car-safe (cdr (cl-remove-if (lambda (player)
- (zerop (poker-player-stack player)))
- (poker-rotate-to-first button-player
players)))))
- (let ((lost (cl-remove-if-not (lambda (player) (zerop
(poker-player-stack player)))
- players)))
- (when lost
- (setq players (cl-remove-if
- (lambda (player)
- (when (member player lost)
- (message "%s drops out." (poker-player-name
player))
- t))
- players))
- (setq losers (nconc losers lost))))
- (message "Remaining players: %s"
- (mapconcat (lambda (player) (format "%s (%d)"
- (poker-player-name player)
- (poker-player-stack player)))
- (cl-sort (append players nil)
- #'> :key #'poker-player-stack)
- " "))
- (when button-player
- (cl-assert (member button-player players))
- (let ((count (length players)))
- (setq players (poker-rotate-to-first button-player players))
- (cl-assert (= count (length players)))))
-
- (accept-process-output)
-
- (when (and game-interactive-p (not (poker-interactive-p players)))
- (message "You drop out in %s place."
- (let ((rank (1+ (length players))))
- (pcase rank
- (2 "2nd")
- (3 "3rd")
- (n (format "%dth" n)))))))
-
- (when (and game-interactive-p (poker-interactive-p players))
- (message "You are the winner."))
-
- (cons players rounds)))
-
-
-;;;###autoload
-(define-key menu-bar-games-menu
- [poker] '(menu-item "Texas hold 'em poker" poker
- :help "Play Texas hold 'em poker"))
-
-;;; Tests:
-
-(ert-deftest poker-combinations ()
- (should (equal 21 (length (poker-combinations 5 (last poker-deck 7)))))
- (should (equal 1326 (length (poker-combinations 2 poker-deck)))))
-
-(ert-deftest poker-possible-hands ()
- (should (equal (poker-possible-hands '(1 2 3 4 5 6 7))
- (poker-combinations 5 '(1 2 3 4 5 6 7))))
- (should (equal (poker-possible-hands '(1 2 3 4 5 6))
- (poker-combinations 5 '(1 2 3 4 5 6)))))
-
-(ert-deftest poker-hand-value ()
- (cl-labels ((permute (list)
- (when list
- (if (not (cdr list)) (list list)
- (cl-mapcan (lambda (elt)
- (mapcar (lambda (l) (cons elt l))
- (permute (remq elt list))))
- list)))))
- ;; Straight flush
- (dolist (suit poker-suits)
- (dolist (hand (permute (mapcar (lambda (args)
- (apply #'poker-make-card args))
- (list (list 'ace suit) (list 'king suit)
- (list 'queen suit) (list 'jack suit)
- (list 10 suit)))))
- (should (eq (poker-hand-value hand) #x8cba98))))
- ;; Straight
- (dolist (s1 poker-suits)
- (dolist (s2 poker-suits)
- (dolist (s3 poker-suits)
- (dolist (s4 poker-suits)
- (dolist (s5 poker-suits)
- (unless (and (eq s1 s2) (eq s2 s3) (eq s3 s4) (eq s4 s5))
- (dolist (hand (permute (mapcar (lambda (args)
- (apply #'poker-make-card args))
- (list (list 'ace s1) (list 'king
s2)
- (list 'queen s3) (list
'jack s4)
- (list 10 s5)))))
- (should (eq (poker-hand-value hand) #x4cba98)))))))))))
-
-(ert-deftest poker ()
- (let ((players (list (poker-make-player "Angela" #'poker-automatic-fcr)
- (poker-make-player "Bettina" #'poker-automatic-fcr)
- (poker-make-player "Christoph" #'poker-automatic-fcr)
- (poker-make-player "Daniela" #'poker-automatic-fcr)
- (poker-make-player "Emilia" #'poker-automatic-fcr)
- (poker-make-player "Franz" #'poker-automatic-fcr)
- (poker-make-player "Günter" #'poker-automatic-fcr)
- (poker-make-player "Harald" #'poker-automatic-fcr)
- (poker-make-player "Isabella" #'poker-automatic-fcr)
- (poker-make-player "Jakob" #'poker-automatic-fcr))))
- (while (> (length players) 1)
- (should (equal (poker-player-stack (caar (poker 1000 100 players)))
- (* 1000 (length players))))
- (setq players (cdr players)))))
-
-(provide 'poker)
-;;; poker.el ends here
diff --git a/packages/quarter-plane/quarter-plane.el
b/packages/quarter-plane/quarter-plane.el
deleted file mode 100644
index 3cb70d9..0000000
--- a/packages/quarter-plane/quarter-plane.el
+++ /dev/null
@@ -1,113 +0,0 @@
-;;; quarter-plane.el --- Minor mode for quarter-plane style editing
-
-;; Copyright (C) 2011 Free Software Foundation, Inc.
-
-;; Author: Peter J. Weisberg
-;; Version: 0.1
-;; Keywords: convenience wp
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package provides Quarter Plane mode, a minor mode which
-;; provides Picture mode style editing (treating the screen as a
-;; semi-infinite quarter-plane). Unlike Picture mode, it is a minor
-;; mode (see the Emacs manual for the documentation of Picture mode).
-;; Type M-x quarter-plane-mode to enable Quarter Plane mode in the
-;; current buffer, and M-x global-quarter-plane-mode to enable it
-;; globally.
-
-;; In Quarter Plane mode, the commands `right-char', `forward-char',
-;; `previous-line', `next-line', and `mouse-set-point' are rebound to
-;; Quarter Plane commands.
-
-;; Known issues:
-
-;; Quarter-Plane mode doesn't work in read-only buffers, where it
-;; can't insert spaces.
-
-;; The user doesn't really care about the "modifications" of adding
-;; whitespace that's going to be trimmed when he exits quarter-plane
-;; mode or saves, but it's still part of the undo history.
-
-;; Both of these are due to the disconnect between what the user
-;; really wants--movement of the cursor within the window, regardless
-;; of where the text is--and what the mode can actually do--add dummy
-;; text to give the cursor a place to move to.
-
-;;; Code:
-
-(require 'picture)
-
-(defvar quarter-plane-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [remap right-char] 'picture-forward-column)
- (define-key map [remap forward-char] 'picture-forward-column)
- (define-key map [remap previous-line] 'picture-move-up)
- (define-key map [remap next-line] 'picture-move-down)
- (define-key map [remap mouse-set-point] 'picture-mouse-set-point)
- map))
-
-(defvar quarter-plane-saved-values nil)
-(make-variable-buffer-local 'quarter-plane-saved-values)
-
-;;;###autoload
-(define-minor-mode quarter-plane-mode
- "Toggle Quarter-Plane mode on or off.
-Interactively, with no prefix argument, toggle the mode.
-With universal prefix ARG turn mode on.
-With zero or negative ARG turn mode off.
-
-Use point movement commands that act as if the text extended
-infinitely down and to the right, inserting spaces as necessary.
-Excess whitespace is trimmed when saving or exiting Quarter-Plane mode.
-
-Because it works by inserting spaces, Quarter-Plane mode won't work in
-read-only buffers.
-
-\\{quarter-plane-mode-map}"
- :lighter " Plane"
- :group 'picture
- :keymap quarter-plane-mode-map
- (remove-hook 'before-save-hook 'quarter-plane-delete-whitespace t)
- (dolist (symval (prog1 quarter-plane-saved-values
- (setq quarter-plane-saved-values nil)))
- (set (car symval) (cdr symval)))
- (when quarter-plane-mode
- (add-hook 'before-save-hook 'quarter-plane-delete-whitespace nil t)
- ;; Since quarter-plane-mode is not permanent-local, it should turn itself
- ;; off cleanly.
- (add-hook 'change-major-mode-hook (lambda () (quarter-plane-mode -1)) nil
t)
- (dolist (symval '((truncate-lines . t)
- (show-trailing-whitespace . nil)))
- (push (cons (car symval) (symbol-value (car symval)))
- quarter-plane-saved-values)
- (set (car symval) (cdr symval)))))
-
-;;;###autoload
-(define-global-minor-mode global-quarter-plane-mode quarter-plane-mode
- quarter-plane-mode
- :group 'picture)
-
-(defun quarter-plane-delete-whitespace ()
- "Call `delete-trailing-whitespace' if the buffer is not read-only."
- (if (not buffer-read-only)
- (delete-trailing-whitespace)))
-
-(add-hook 'quarter-plane-mode-off-hook 'quarter-plane-delete-whitespace)
-
-(provide 'quarter-plane)
-
-;;; quarter-plane.el ends here
diff --git a/packages/rainbow-mode/rainbow-mode.el
b/packages/rainbow-mode/rainbow-mode.el
deleted file mode 100644
index e6bf1bd..0000000
--- a/packages/rainbow-mode/rainbow-mode.el
+++ /dev/null
@@ -1,1218 +0,0 @@
-;;; rainbow-mode.el --- Colorize color names in buffers
-
-;; Copyright (C) 2010-2020 Free Software Foundation, Inc
-
-;; Author: Julien Danjou <julien@danjou.info>
-;; Keywords: faces
-;; Version: 1.0.5
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This minor mode sets background color to strings that match color
-;; names, e.g. #0000ff is displayed in white with a blue background.
-;;
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'regexp-opt)
-(require 'faces)
-(require 'color)
-
-(unless (require 'xterm-color nil t)
- (require 'ansi-color))
-
-(defgroup rainbow nil
- "Show color strings with a background color."
- :tag "Rainbow"
- :group 'help)
-
-;;; Hexadecimal colors
-
-(defvar rainbow-hexadecimal-colors-font-lock-keywords
- '(("[^&]\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)\\{1,4\\}\\)"
- (1 (rainbow-colorize-itself 1)))
- ("^\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)\\{1,4\\}\\)"
- (0 (rainbow-colorize-itself)))
-
("[Rr][Gg][Bb]:[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}"
- (0 (rainbow-colorize-itself)))
- ("[Rr][Gg][Bb][Ii]:[0-9.]+/[0-9.]+/[0-9.]+"
- (0 (rainbow-colorize-itself)))
-
("\\(?:[Cc][Ii][Ee]\\(?:[Xx][Yy][Zz]\\|[Uu][Vv][Yy]\\|[Xx][Yy][Yy]\\|[Ll][Aa][Bb]\\|[Ll][Uu][Vv]\\)\\|[Tt][Ee][Kk][Hh][Vv][Cc]\\):[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?"
- (0 (rainbow-colorize-itself))))
- "Font-lock keywords to add for hexadecimal colors.")
-
-;;; rgb() colors
-
-(defvar rainbow-html-rgb-colors-font-lock-keywords
-
'(("rgb(\s*\\([0-9]\\{1,3\\}\\(?:\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*)"
- (0 (rainbow-colorize-rgb)))
-
("rgba(\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- (0 (rainbow-colorize-rgb)))
-
("hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
- (0 (rainbow-colorize-hsl)))
-
("hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- (0 (rainbow-colorize-hsl))))
- "Font-lock keywords to add for RGB colors.")
-
-;;; HTML colors
-
-(defvar rainbow-html-colors-font-lock-keywords nil
- "Font-lock keywords to add for HTML colors.")
-(make-variable-buffer-local 'rainbow-html-colors-font-lock-keywords)
-
-(defcustom rainbow-html-colors-alist
- '(("AliceBlue" . "#F0F8FF")
- ("AntiqueWhite" . "#FAEBD7")
- ("Aqua" . "#00FFFF")
- ("Aquamarine" . "#7FFFD4")
- ("Azure" . "#F0FFFF")
- ("Beige" . "#F5F5DC")
- ("Bisque" . "#FFE4C4")
- ("Black" . "#000000")
- ("BlanchedAlmond" . "#FFEBCD")
- ("Blue" . "#0000FF")
- ("BlueViolet" . "#8A2BE2")
- ("Brown" . "#A52A2A")
- ("BurlyWood" . "#DEB887")
- ("CadetBlue" . "#5F9EA0")
- ("Chartreuse" . "#7FFF00")
- ("Chocolate" . "#D2691E")
- ("Coral" . "#FF7F50")
- ("CornflowerBlue" . "#6495ED")
- ("Cornsilk" . "#FFF8DC")
- ("Crimson" . "#DC143C")
- ("Cyan" . "#00FFFF")
- ("DarkBlue" . "#00008B")
- ("DarkCyan" . "#008B8B")
- ("DarkGoldenRod" . "#B8860B")
- ("DarkGray" . "#A9A9A9")
- ("DarkGrey" . "#A9A9A9")
- ("DarkGreen" . "#006400")
- ("DarkKhaki" . "#BDB76B")
- ("DarkMagenta" . "#8B008B")
- ("DarkOliveGreen" . "#556B2F")
- ("Darkorange" . "#FF8C00")
- ("DarkOrchid" . "#9932CC")
- ("DarkRed" . "#8B0000")
- ("DarkSalmon" . "#E9967A")
- ("DarkSeaGreen" . "#8FBC8F")
- ("DarkSlateBlue" . "#483D8B")
- ("DarkSlateGray" . "#2F4F4F")
- ("DarkSlateGrey" . "#2F4F4F")
- ("DarkTurquoise" . "#00CED1")
- ("DarkViolet" . "#9400D3")
- ("DeepPink" . "#FF1493")
- ("DeepSkyBlue" . "#00BFFF")
- ("DimGray" . "#696969")
- ("DimGrey" . "#696969")
- ("DodgerBlue" . "#1E90FF")
- ("FireBrick" . "#B22222")
- ("FloralWhite" . "#FFFAF0")
- ("ForestGreen" . "#228B22")
- ("Fuchsia" . "#FF00FF")
- ("Gainsboro" . "#DCDCDC")
- ("GhostWhite" . "#F8F8FF")
- ("Gold" . "#FFD700")
- ("GoldenRod" . "#DAA520")
- ("Gray" . "#808080")
- ("Grey" . "#808080")
- ("Green" . "#008000")
- ("GreenYellow" . "#ADFF2F")
- ("HoneyDew" . "#F0FFF0")
- ("HotPink" . "#FF69B4")
- ("IndianRed" . "#CD5C5C")
- ("Indigo" . "#4B0082")
- ("Ivory" . "#FFFFF0")
- ("Khaki" . "#F0E68C")
- ("Lavender" . "#E6E6FA")
- ("LavenderBlush" . "#FFF0F5")
- ("LawnGreen" . "#7CFC00")
- ("LemonChiffon" . "#FFFACD")
- ("LightBlue" . "#ADD8E6")
- ("LightCoral" . "#F08080")
- ("LightCyan" . "#E0FFFF")
- ("LightGoldenRodYellow" . "#FAFAD2")
- ("LightGray" . "#D3D3D3")
- ("LightGrey" . "#D3D3D3")
- ("LightGreen" . "#90EE90")
- ("LightPink" . "#FFB6C1")
- ("LightSalmon" . "#FFA07A")
- ("LightSeaGreen" . "#20B2AA")
- ("LightSkyBlue" . "#87CEFA")
- ("LightSlateGray" . "#778899")
- ("LightSlateGrey" . "#778899")
- ("LightSteelBlue" . "#B0C4DE")
- ("LightYellow" . "#FFFFE0")
- ("Lime" . "#00FF00")
- ("LimeGreen" . "#32CD32")
- ("Linen" . "#FAF0E6")
- ("Magenta" . "#FF00FF")
- ("Maroon" . "#800000")
- ("MediumAquaMarine" . "#66CDAA")
- ("MediumBlue" . "#0000CD")
- ("MediumOrchid" . "#BA55D3")
- ("MediumPurple" . "#9370D8")
- ("MediumSeaGreen" . "#3CB371")
- ("MediumSlateBlue" . "#7B68EE")
- ("MediumSpringGreen" . "#00FA9A")
- ("MediumTurquoise" . "#48D1CC")
- ("MediumVioletRed" . "#C71585")
- ("MidnightBlue" . "#191970")
- ("MintCream" . "#F5FFFA")
- ("MistyRose" . "#FFE4E1")
- ("Moccasin" . "#FFE4B5")
- ("NavajoWhite" . "#FFDEAD")
- ("Navy" . "#000080")
- ("OldLace" . "#FDF5E6")
- ("Olive" . "#808000")
- ("OliveDrab" . "#6B8E23")
- ("Orange" . "#FFA500")
- ("OrangeRed" . "#FF4500")
- ("Orchid" . "#DA70D6")
- ("PaleGoldenRod" . "#EEE8AA")
- ("PaleGreen" . "#98FB98")
- ("PaleTurquoise" . "#AFEEEE")
- ("PaleVioletRed" . "#D87093")
- ("PapayaWhip" . "#FFEFD5")
- ("PeachPuff" . "#FFDAB9")
- ("Peru" . "#CD853F")
- ("Pink" . "#FFC0CB")
- ("Plum" . "#DDA0DD")
- ("PowderBlue" . "#B0E0E6")
- ("Purple" . "#800080")
- ("Red" . "#FF0000")
- ("RosyBrown" . "#BC8F8F")
- ("RoyalBlue" . "#4169E1")
- ("SaddleBrown" . "#8B4513")
- ("Salmon" . "#FA8072")
- ("SandyBrown" . "#F4A460")
- ("SeaGreen" . "#2E8B57")
- ("SeaShell" . "#FFF5EE")
- ("Sienna" . "#A0522D")
- ("Silver" . "#C0C0C0")
- ("SkyBlue" . "#87CEEB")
- ("SlateBlue" . "#6A5ACD")
- ("SlateGray" . "#708090")
- ("SlateGrey" . "#708090")
- ("Snow" . "#FFFAFA")
- ("SpringGreen" . "#00FF7F")
- ("SteelBlue" . "#4682B4")
- ("Tan" . "#D2B48C")
- ("Teal" . "#008080")
- ("Thistle" . "#D8BFD8")
- ("Tomato" . "#FF6347")
- ("Turquoise" . "#40E0D0")
- ("Violet" . "#EE82EE")
- ("Wheat" . "#F5DEB3")
- ("White" . "#FFFFFF")
- ("WhiteSmoke" . "#F5F5F5")
- ("Yellow" . "#FFFF00")
- ("YellowGreen" . "#9ACD32"))
- "Alist of HTML colors.
-Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR)."
- :type 'alist
- :group 'rainbow)
-
-(defcustom rainbow-html-colors-major-mode-list
- '(html-mode css-mode php-mode nxml-mode xml-mode)
- "List of major mode where HTML colors are enabled when
-`rainbow-html-colors' is set to auto."
- :type '(repeat (symbol :tag "Major-Mode"))
- :group 'rainbow)
-
-(defcustom rainbow-html-colors 'auto
- "When to enable HTML colors.
-If set to t, the HTML colors will be enabled. If set to nil, the
-HTML colors will not be enabled. If set to auto, the HTML colors
-will be enabled if a major mode has been detected from the
-`rainbow-html-colors-major-mode-list'."
- :type '(choice (symbol :tag "enable in certain modes" auto)
- (symbol :tag "enable globally" t)
- (symbol :tag "disable" nil))
- :group 'rainbow)
-
-;;; X colors
-
-(defvar rainbow-x-colors-font-lock-keywords
- `((,(regexp-opt (x-defined-colors) 'words)
- (0 (rainbow-colorize-itself))))
- "Font-lock keywords to add for X colors.")
-
-(defcustom rainbow-x-colors-major-mode-list
- '(emacs-lisp-mode lisp-interaction-mode c-mode c++-mode java-mode)
- "List of major mode where X colors are enabled when
-`rainbow-x-colors' is set to auto."
- :type '(repeat (symbol :tag "Major-Mode"))
- :group 'rainbow)
-
-(defcustom rainbow-x-colors 'auto
- "When to enable X colors.
-If set to t, the X colors will be enabled. If set to nil, the
-X colors will not be enabled. If set to auto, the X colors
-will be enabled if a major mode has been detected from the
-`rainbow-x-colors-major-mode-list'."
- :type '(choice (symbol :tag "enable in certain modes" auto)
- (symbol :tag "enable globally" t)
- (symbol :tag "disable" nil))
- :group 'rainbow)
-
-;;; LaTeX colors
-
-(defvar rainbow-latex-rgb-colors-font-lock-keywords
- '(("{rgb}{\\([0-9.]+\\),\s*\\([0-9.]+\\),\s*\\([0-9.]+\\)}"
- (0 (rainbow-colorize-rgb-float)))
-
("{RGB}{\\([0-9]\\{1,3\\}\\),\s*\\([0-9]\\{1,3\\}\\),\s*\\([0-9]\\{1,3\\}\\)}"
- (0 (rainbow-colorize-rgb)))
- ("{HTML}{\\([0-9A-Fa-f]\\{6\\}\\)}"
- (0 (rainbow-colorize-hexadecimal-without-sharp))))
- "Font-lock keywords to add for LaTeX colors.")
-
-(defcustom rainbow-latex-colors-major-mode-list
- '(latex-mode)
- "List of major mode where LaTeX colors are enabled when
-`rainbow-x-colors' is set to auto."
- :type '(repeat (symbol :tag "Major-Mode"))
- :group 'rainbow)
-
-(defcustom rainbow-latex-colors 'auto
- "When to enable LaTeX colors.
-If set to t, the LaTeX colors will be enabled. If set to nil, the
-LaTeX colors will not be enabled. If set to auto, the LaTeX colors
-will be enabled if a major mode has been detected from the
-`rainbow-latex-colors-major-mode-list'."
- :type '(choice (symbol :tag "enable in certain modes" auto)
- (symbol :tag "enable globally" t)
- (symbol :tag "disable" nil))
- :group 'rainbow)
-
-;;; Shell colors
-
-(defvar rainbow-ansi-colors-font-lock-keywords
- '(("\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\|\033\\)\\[\\([0-9;]*m\\)"
- (0 (rainbow-colorize-ansi))))
- "Font-lock keywords to add for ANSI colors.")
-
-(defcustom rainbow-ansi-colors-major-mode-list
- '(sh-mode c-mode c++-mode)
- "List of major mode where ANSI colors are enabled when
-`rainbow-ansi-colors' is set to auto."
- :type '(repeat (symbol :tag "Major-Mode"))
- :group 'rainbow)
-
-(defcustom rainbow-ansi-colors 'auto
- "When to enable ANSI colors.
-If set to t, the ANSI colors will be enabled. If set to nil, the
-ANSI colors will not be enabled. If set to auto, the ANSI colors
-will be enabled if a major mode has been detected from the
-`rainbow-ansi-colors-major-mode-list'."
- :type '(choice (symbol :tag "enable in certain modes" auto)
- (symbol :tag "enable globally" t)
- (symbol :tag "disable" nil))
- :group 'rainbow)
-
-;;; R colors
-
-(defvar rainbow-r-colors-font-lock-keywords nil
- "Font-lock keywords to add for R colors.")
-(make-variable-buffer-local 'rainbow-r-colors-font-lock-keywords)
-
-;; use the following code to generate the list in R
-;; output_colors <- function(colors) {for(color in colors) {col <-
col2rgb(color); cat(sprintf("(\"%s\" .
\"#%02X%02X%02X\")\n",color,col[1],col[2],col[3]));}}
-;; output_colors(colors())
-(defcustom rainbow-r-colors-alist
- '(("white" . "#FFFFFF")
- ("aliceblue" . "#F0F8FF")
- ("antiquewhite" . "#FAEBD7")
- ("antiquewhite1" . "#FFEFDB")
- ("antiquewhite2" . "#EEDFCC")
- ("antiquewhite3" . "#CDC0B0")
- ("antiquewhite4" . "#8B8378")
- ("aquamarine" . "#7FFFD4")
- ("aquamarine1" . "#7FFFD4")
- ("aquamarine2" . "#76EEC6")
- ("aquamarine3" . "#66CDAA")
- ("aquamarine4" . "#458B74")
- ("azure" . "#F0FFFF")
- ("azure1" . "#F0FFFF")
- ("azure2" . "#E0EEEE")
- ("azure3" . "#C1CDCD")
- ("azure4" . "#838B8B")
- ("beige" . "#F5F5DC")
- ("bisque" . "#FFE4C4")
- ("bisque1" . "#FFE4C4")
- ("bisque2" . "#EED5B7")
- ("bisque3" . "#CDB79E")
- ("bisque4" . "#8B7D6B")
- ("black" . "#000000")
- ("blanchedalmond" . "#FFEBCD")
- ("blue" . "#0000FF")
- ("blue1" . "#0000FF")
- ("blue2" . "#0000EE")
- ("blue3" . "#0000CD")
- ("blue4" . "#00008B")
- ("blueviolet" . "#8A2BE2")
- ("brown" . "#A52A2A")
- ("brown1" . "#FF4040")
- ("brown2" . "#EE3B3B")
- ("brown3" . "#CD3333")
- ("brown4" . "#8B2323")
- ("burlywood" . "#DEB887")
- ("burlywood1" . "#FFD39B")
- ("burlywood2" . "#EEC591")
- ("burlywood3" . "#CDAA7D")
- ("burlywood4" . "#8B7355")
- ("cadetblue" . "#5F9EA0")
- ("cadetblue1" . "#98F5FF")
- ("cadetblue2" . "#8EE5EE")
- ("cadetblue3" . "#7AC5CD")
- ("cadetblue4" . "#53868B")
- ("chartreuse" . "#7FFF00")
- ("chartreuse1" . "#7FFF00")
- ("chartreuse2" . "#76EE00")
- ("chartreuse3" . "#66CD00")
- ("chartreuse4" . "#458B00")
- ("chocolate" . "#D2691E")
- ("chocolate1" . "#FF7F24")
- ("chocolate2" . "#EE7621")
- ("chocolate3" . "#CD661D")
- ("chocolate4" . "#8B4513")
- ("coral" . "#FF7F50")
- ("coral1" . "#FF7256")
- ("coral2" . "#EE6A50")
- ("coral3" . "#CD5B45")
- ("coral4" . "#8B3E2F")
- ("cornflowerblue" . "#6495ED")
- ("cornsilk" . "#FFF8DC")
- ("cornsilk1" . "#FFF8DC")
- ("cornsilk2" . "#EEE8CD")
- ("cornsilk3" . "#CDC8B1")
- ("cornsilk4" . "#8B8878")
- ("cyan" . "#00FFFF")
- ("cyan1" . "#00FFFF")
- ("cyan2" . "#00EEEE")
- ("cyan3" . "#00CDCD")
- ("cyan4" . "#008B8B")
- ("darkblue" . "#00008B")
- ("darkcyan" . "#008B8B")
- ("darkgoldenrod" . "#B8860B")
- ("darkgoldenrod1" . "#FFB90F")
- ("darkgoldenrod2" . "#EEAD0E")
- ("darkgoldenrod3" . "#CD950C")
- ("darkgoldenrod4" . "#8B6508")
- ("darkgray" . "#A9A9A9")
- ("darkgreen" . "#006400")
- ("darkgrey" . "#A9A9A9")
- ("darkkhaki" . "#BDB76B")
- ("darkmagenta" . "#8B008B")
- ("darkolivegreen" . "#556B2F")
- ("darkolivegreen1" . "#CAFF70")
- ("darkolivegreen2" . "#BCEE68")
- ("darkolivegreen3" . "#A2CD5A")
- ("darkolivegreen4" . "#6E8B3D")
- ("darkorange" . "#FF8C00")
- ("darkorange1" . "#FF7F00")
- ("darkorange2" . "#EE7600")
- ("darkorange3" . "#CD6600")
- ("darkorange4" . "#8B4500")
- ("darkorchid" . "#9932CC")
- ("darkorchid1" . "#BF3EFF")
- ("darkorchid2" . "#B23AEE")
- ("darkorchid3" . "#9A32CD")
- ("darkorchid4" . "#68228B")
- ("darkred" . "#8B0000")
- ("darksalmon" . "#E9967A")
- ("darkseagreen" . "#8FBC8F")
- ("darkseagreen1" . "#C1FFC1")
- ("darkseagreen2" . "#B4EEB4")
- ("darkseagreen3" . "#9BCD9B")
- ("darkseagreen4" . "#698B69")
- ("darkslateblue" . "#483D8B")
- ("darkslategray" . "#2F4F4F")
- ("darkslategray1" . "#97FFFF")
- ("darkslategray2" . "#8DEEEE")
- ("darkslategray3" . "#79CDCD")
- ("darkslategray4" . "#528B8B")
- ("darkslategrey" . "#2F4F4F")
- ("darkturquoise" . "#00CED1")
- ("darkviolet" . "#9400D3")
- ("deeppink" . "#FF1493")
- ("deeppink1" . "#FF1493")
- ("deeppink2" . "#EE1289")
- ("deeppink3" . "#CD1076")
- ("deeppink4" . "#8B0A50")
- ("deepskyblue" . "#00BFFF")
- ("deepskyblue1" . "#00BFFF")
- ("deepskyblue2" . "#00B2EE")
- ("deepskyblue3" . "#009ACD")
- ("deepskyblue4" . "#00688B")
- ("dimgray" . "#696969")
- ("dimgrey" . "#696969")
- ("dodgerblue" . "#1E90FF")
- ("dodgerblue1" . "#1E90FF")
- ("dodgerblue2" . "#1C86EE")
- ("dodgerblue3" . "#1874CD")
- ("dodgerblue4" . "#104E8B")
- ("firebrick" . "#B22222")
- ("firebrick1" . "#FF3030")
- ("firebrick2" . "#EE2C2C")
- ("firebrick3" . "#CD2626")
- ("firebrick4" . "#8B1A1A")
- ("floralwhite" . "#FFFAF0")
- ("forestgreen" . "#228B22")
- ("gainsboro" . "#DCDCDC")
- ("ghostwhite" . "#F8F8FF")
- ("gold" . "#FFD700")
- ("gold1" . "#FFD700")
- ("gold2" . "#EEC900")
- ("gold3" . "#CDAD00")
- ("gold4" . "#8B7500")
- ("goldenrod" . "#DAA520")
- ("goldenrod1" . "#FFC125")
- ("goldenrod2" . "#EEB422")
- ("goldenrod3" . "#CD9B1D")
- ("goldenrod4" . "#8B6914")
- ("gray" . "#BEBEBE")
- ("gray0" . "#000000")
- ("gray1" . "#030303")
- ("gray2" . "#050505")
- ("gray3" . "#080808")
- ("gray4" . "#0A0A0A")
- ("gray5" . "#0D0D0D")
- ("gray6" . "#0F0F0F")
- ("gray7" . "#121212")
- ("gray8" . "#141414")
- ("gray9" . "#171717")
- ("gray10" . "#1A1A1A")
- ("gray11" . "#1C1C1C")
- ("gray12" . "#1F1F1F")
- ("gray13" . "#212121")
- ("gray14" . "#242424")
- ("gray15" . "#262626")
- ("gray16" . "#292929")
- ("gray17" . "#2B2B2B")
- ("gray18" . "#2E2E2E")
- ("gray19" . "#303030")
- ("gray20" . "#333333")
- ("gray21" . "#363636")
- ("gray22" . "#383838")
- ("gray23" . "#3B3B3B")
- ("gray24" . "#3D3D3D")
- ("gray25" . "#404040")
- ("gray26" . "#424242")
- ("gray27" . "#454545")
- ("gray28" . "#474747")
- ("gray29" . "#4A4A4A")
- ("gray30" . "#4D4D4D")
- ("gray31" . "#4F4F4F")
- ("gray32" . "#525252")
- ("gray33" . "#545454")
- ("gray34" . "#575757")
- ("gray35" . "#595959")
- ("gray36" . "#5C5C5C")
- ("gray37" . "#5E5E5E")
- ("gray38" . "#616161")
- ("gray39" . "#636363")
- ("gray40" . "#666666")
- ("gray41" . "#696969")
- ("gray42" . "#6B6B6B")
- ("gray43" . "#6E6E6E")
- ("gray44" . "#707070")
- ("gray45" . "#737373")
- ("gray46" . "#757575")
- ("gray47" . "#787878")
- ("gray48" . "#7A7A7A")
- ("gray49" . "#7D7D7D")
- ("gray50" . "#7F7F7F")
- ("gray51" . "#828282")
- ("gray52" . "#858585")
- ("gray53" . "#878787")
- ("gray54" . "#8A8A8A")
- ("gray55" . "#8C8C8C")
- ("gray56" . "#8F8F8F")
- ("gray57" . "#919191")
- ("gray58" . "#949494")
- ("gray59" . "#969696")
- ("gray60" . "#999999")
- ("gray61" . "#9C9C9C")
- ("gray62" . "#9E9E9E")
- ("gray63" . "#A1A1A1")
- ("gray64" . "#A3A3A3")
- ("gray65" . "#A6A6A6")
- ("gray66" . "#A8A8A8")
- ("gray67" . "#ABABAB")
- ("gray68" . "#ADADAD")
- ("gray69" . "#B0B0B0")
- ("gray70" . "#B3B3B3")
- ("gray71" . "#B5B5B5")
- ("gray72" . "#B8B8B8")
- ("gray73" . "#BABABA")
- ("gray74" . "#BDBDBD")
- ("gray75" . "#BFBFBF")
- ("gray76" . "#C2C2C2")
- ("gray77" . "#C4C4C4")
- ("gray78" . "#C7C7C7")
- ("gray79" . "#C9C9C9")
- ("gray80" . "#CCCCCC")
- ("gray81" . "#CFCFCF")
- ("gray82" . "#D1D1D1")
- ("gray83" . "#D4D4D4")
- ("gray84" . "#D6D6D6")
- ("gray85" . "#D9D9D9")
- ("gray86" . "#DBDBDB")
- ("gray87" . "#DEDEDE")
- ("gray88" . "#E0E0E0")
- ("gray89" . "#E3E3E3")
- ("gray90" . "#E5E5E5")
- ("gray91" . "#E8E8E8")
- ("gray92" . "#EBEBEB")
- ("gray93" . "#EDEDED")
- ("gray94" . "#F0F0F0")
- ("gray95" . "#F2F2F2")
- ("gray96" . "#F5F5F5")
- ("gray97" . "#F7F7F7")
- ("gray98" . "#FAFAFA")
- ("gray99" . "#FCFCFC")
- ("gray100" . "#FFFFFF")
- ("green" . "#00FF00")
- ("green1" . "#00FF00")
- ("green2" . "#00EE00")
- ("green3" . "#00CD00")
- ("green4" . "#008B00")
- ("greenyellow" . "#ADFF2F")
- ("grey" . "#BEBEBE")
- ("grey0" . "#000000")
- ("grey1" . "#030303")
- ("grey2" . "#050505")
- ("grey3" . "#080808")
- ("grey4" . "#0A0A0A")
- ("grey5" . "#0D0D0D")
- ("grey6" . "#0F0F0F")
- ("grey7" . "#121212")
- ("grey8" . "#141414")
- ("grey9" . "#171717")
- ("grey10" . "#1A1A1A")
- ("grey11" . "#1C1C1C")
- ("grey12" . "#1F1F1F")
- ("grey13" . "#212121")
- ("grey14" . "#242424")
- ("grey15" . "#262626")
- ("grey16" . "#292929")
- ("grey17" . "#2B2B2B")
- ("grey18" . "#2E2E2E")
- ("grey19" . "#303030")
- ("grey20" . "#333333")
- ("grey21" . "#363636")
- ("grey22" . "#383838")
- ("grey23" . "#3B3B3B")
- ("grey24" . "#3D3D3D")
- ("grey25" . "#404040")
- ("grey26" . "#424242")
- ("grey27" . "#454545")
- ("grey28" . "#474747")
- ("grey29" . "#4A4A4A")
- ("grey30" . "#4D4D4D")
- ("grey31" . "#4F4F4F")
- ("grey32" . "#525252")
- ("grey33" . "#545454")
- ("grey34" . "#575757")
- ("grey35" . "#595959")
- ("grey36" . "#5C5C5C")
- ("grey37" . "#5E5E5E")
- ("grey38" . "#616161")
- ("grey39" . "#636363")
- ("grey40" . "#666666")
- ("grey41" . "#696969")
- ("grey42" . "#6B6B6B")
- ("grey43" . "#6E6E6E")
- ("grey44" . "#707070")
- ("grey45" . "#737373")
- ("grey46" . "#757575")
- ("grey47" . "#787878")
- ("grey48" . "#7A7A7A")
- ("grey49" . "#7D7D7D")
- ("grey50" . "#7F7F7F")
- ("grey51" . "#828282")
- ("grey52" . "#858585")
- ("grey53" . "#878787")
- ("grey54" . "#8A8A8A")
- ("grey55" . "#8C8C8C")
- ("grey56" . "#8F8F8F")
- ("grey57" . "#919191")
- ("grey58" . "#949494")
- ("grey59" . "#969696")
- ("grey60" . "#999999")
- ("grey61" . "#9C9C9C")
- ("grey62" . "#9E9E9E")
- ("grey63" . "#A1A1A1")
- ("grey64" . "#A3A3A3")
- ("grey65" . "#A6A6A6")
- ("grey66" . "#A8A8A8")
- ("grey67" . "#ABABAB")
- ("grey68" . "#ADADAD")
- ("grey69" . "#B0B0B0")
- ("grey70" . "#B3B3B3")
- ("grey71" . "#B5B5B5")
- ("grey72" . "#B8B8B8")
- ("grey73" . "#BABABA")
- ("grey74" . "#BDBDBD")
- ("grey75" . "#BFBFBF")
- ("grey76" . "#C2C2C2")
- ("grey77" . "#C4C4C4")
- ("grey78" . "#C7C7C7")
- ("grey79" . "#C9C9C9")
- ("grey80" . "#CCCCCC")
- ("grey81" . "#CFCFCF")
- ("grey82" . "#D1D1D1")
- ("grey83" . "#D4D4D4")
- ("grey84" . "#D6D6D6")
- ("grey85" . "#D9D9D9")
- ("grey86" . "#DBDBDB")
- ("grey87" . "#DEDEDE")
- ("grey88" . "#E0E0E0")
- ("grey89" . "#E3E3E3")
- ("grey90" . "#E5E5E5")
- ("grey91" . "#E8E8E8")
- ("grey92" . "#EBEBEB")
- ("grey93" . "#EDEDED")
- ("grey94" . "#F0F0F0")
- ("grey95" . "#F2F2F2")
- ("grey96" . "#F5F5F5")
- ("grey97" . "#F7F7F7")
- ("grey98" . "#FAFAFA")
- ("grey99" . "#FCFCFC")
- ("grey100" . "#FFFFFF")
- ("honeydew" . "#F0FFF0")
- ("honeydew1" . "#F0FFF0")
- ("honeydew2" . "#E0EEE0")
- ("honeydew3" . "#C1CDC1")
- ("honeydew4" . "#838B83")
- ("hotpink" . "#FF69B4")
- ("hotpink1" . "#FF6EB4")
- ("hotpink2" . "#EE6AA7")
- ("hotpink3" . "#CD6090")
- ("hotpink4" . "#8B3A62")
- ("indianred" . "#CD5C5C")
- ("indianred1" . "#FF6A6A")
- ("indianred2" . "#EE6363")
- ("indianred3" . "#CD5555")
- ("indianred4" . "#8B3A3A")
- ("ivory" . "#FFFFF0")
- ("ivory1" . "#FFFFF0")
- ("ivory2" . "#EEEEE0")
- ("ivory3" . "#CDCDC1")
- ("ivory4" . "#8B8B83")
- ("khaki" . "#F0E68C")
- ("khaki1" . "#FFF68F")
- ("khaki2" . "#EEE685")
- ("khaki3" . "#CDC673")
- ("khaki4" . "#8B864E")
- ("lavender" . "#E6E6FA")
- ("lavenderblush" . "#FFF0F5")
- ("lavenderblush1" . "#FFF0F5")
- ("lavenderblush2" . "#EEE0E5")
- ("lavenderblush3" . "#CDC1C5")
- ("lavenderblush4" . "#8B8386")
- ("lawngreen" . "#7CFC00")
- ("lemonchiffon" . "#FFFACD")
- ("lemonchiffon1" . "#FFFACD")
- ("lemonchiffon2" . "#EEE9BF")
- ("lemonchiffon3" . "#CDC9A5")
- ("lemonchiffon4" . "#8B8970")
- ("lightblue" . "#ADD8E6")
- ("lightblue1" . "#BFEFFF")
- ("lightblue2" . "#B2DFEE")
- ("lightblue3" . "#9AC0CD")
- ("lightblue4" . "#68838B")
- ("lightcoral" . "#F08080")
- ("lightcyan" . "#E0FFFF")
- ("lightcyan1" . "#E0FFFF")
- ("lightcyan2" . "#D1EEEE")
- ("lightcyan3" . "#B4CDCD")
- ("lightcyan4" . "#7A8B8B")
- ("lightgoldenrod" . "#EEDD82")
- ("lightgoldenrod1" . "#FFEC8B")
- ("lightgoldenrod2" . "#EEDC82")
- ("lightgoldenrod3" . "#CDBE70")
- ("lightgoldenrod4" . "#8B814C")
- ("lightgoldenrodyellow" . "#FAFAD2")
- ("lightgray" . "#D3D3D3")
- ("lightgreen" . "#90EE90")
- ("lightgrey" . "#D3D3D3")
- ("lightpink" . "#FFB6C1")
- ("lightpink1" . "#FFAEB9")
- ("lightpink2" . "#EEA2AD")
- ("lightpink3" . "#CD8C95")
- ("lightpink4" . "#8B5F65")
- ("lightsalmon" . "#FFA07A")
- ("lightsalmon1" . "#FFA07A")
- ("lightsalmon2" . "#EE9572")
- ("lightsalmon3" . "#CD8162")
- ("lightsalmon4" . "#8B5742")
- ("lightseagreen" . "#20B2AA")
- ("lightskyblue" . "#87CEFA")
- ("lightskyblue1" . "#B0E2FF")
- ("lightskyblue2" . "#A4D3EE")
- ("lightskyblue3" . "#8DB6CD")
- ("lightskyblue4" . "#607B8B")
- ("lightslateblue" . "#8470FF")
- ("lightslategray" . "#778899")
- ("lightslategrey" . "#778899")
- ("lightsteelblue" . "#B0C4DE")
- ("lightsteelblue1" . "#CAE1FF")
- ("lightsteelblue2" . "#BCD2EE")
- ("lightsteelblue3" . "#A2B5CD")
- ("lightsteelblue4" . "#6E7B8B")
- ("lightyellow" . "#FFFFE0")
- ("lightyellow1" . "#FFFFE0")
- ("lightyellow2" . "#EEEED1")
- ("lightyellow3" . "#CDCDB4")
- ("lightyellow4" . "#8B8B7A")
- ("limegreen" . "#32CD32")
- ("linen" . "#FAF0E6")
- ("magenta" . "#FF00FF")
- ("magenta1" . "#FF00FF")
- ("magenta2" . "#EE00EE")
- ("magenta3" . "#CD00CD")
- ("magenta4" . "#8B008B")
- ("maroon" . "#B03060")
- ("maroon1" . "#FF34B3")
- ("maroon2" . "#EE30A7")
- ("maroon3" . "#CD2990")
- ("maroon4" . "#8B1C62")
- ("mediumaquamarine" . "#66CDAA")
- ("mediumblue" . "#0000CD")
- ("mediumorchid" . "#BA55D3")
- ("mediumorchid1" . "#E066FF")
- ("mediumorchid2" . "#D15FEE")
- ("mediumorchid3" . "#B452CD")
- ("mediumorchid4" . "#7A378B")
- ("mediumpurple" . "#9370DB")
- ("mediumpurple1" . "#AB82FF")
- ("mediumpurple2" . "#9F79EE")
- ("mediumpurple3" . "#8968CD")
- ("mediumpurple4" . "#5D478B")
- ("mediumseagreen" . "#3CB371")
- ("mediumslateblue" . "#7B68EE")
- ("mediumspringgreen" . "#00FA9A")
- ("mediumturquoise" . "#48D1CC")
- ("mediumvioletred" . "#C71585")
- ("midnightblue" . "#191970")
- ("mintcream" . "#F5FFFA")
- ("mistyrose" . "#FFE4E1")
- ("mistyrose1" . "#FFE4E1")
- ("mistyrose2" . "#EED5D2")
- ("mistyrose3" . "#CDB7B5")
- ("mistyrose4" . "#8B7D7B")
- ("moccasin" . "#FFE4B5")
- ("navajowhite" . "#FFDEAD")
- ("navajowhite1" . "#FFDEAD")
- ("navajowhite2" . "#EECFA1")
- ("navajowhite3" . "#CDB38B")
- ("navajowhite4" . "#8B795E")
- ("navy" . "#000080")
- ("navyblue" . "#000080")
- ("oldlace" . "#FDF5E6")
- ("olivedrab" . "#6B8E23")
- ("olivedrab1" . "#C0FF3E")
- ("olivedrab2" . "#B3EE3A")
- ("olivedrab3" . "#9ACD32")
- ("olivedrab4" . "#698B22")
- ("orange" . "#FFA500")
- ("orange1" . "#FFA500")
- ("orange2" . "#EE9A00")
- ("orange3" . "#CD8500")
- ("orange4" . "#8B5A00")
- ("orangered" . "#FF4500")
- ("orangered1" . "#FF4500")
- ("orangered2" . "#EE4000")
- ("orangered3" . "#CD3700")
- ("orangered4" . "#8B2500")
- ("orchid" . "#DA70D6")
- ("orchid1" . "#FF83FA")
- ("orchid2" . "#EE7AE9")
- ("orchid3" . "#CD69C9")
- ("orchid4" . "#8B4789")
- ("palegoldenrod" . "#EEE8AA")
- ("palegreen" . "#98FB98")
- ("palegreen1" . "#9AFF9A")
- ("palegreen2" . "#90EE90")
- ("palegreen3" . "#7CCD7C")
- ("palegreen4" . "#548B54")
- ("paleturquoise" . "#AFEEEE")
- ("paleturquoise1" . "#BBFFFF")
- ("paleturquoise2" . "#AEEEEE")
- ("paleturquoise3" . "#96CDCD")
- ("paleturquoise4" . "#668B8B")
- ("palevioletred" . "#DB7093")
- ("palevioletred1" . "#FF82AB")
- ("palevioletred2" . "#EE799F")
- ("palevioletred3" . "#CD6889")
- ("palevioletred4" . "#8B475D")
- ("papayawhip" . "#FFEFD5")
- ("peachpuff" . "#FFDAB9")
- ("peachpuff1" . "#FFDAB9")
- ("peachpuff2" . "#EECBAD")
- ("peachpuff3" . "#CDAF95")
- ("peachpuff4" . "#8B7765")
- ("peru" . "#CD853F")
- ("pink" . "#FFC0CB")
- ("pink1" . "#FFB5C5")
- ("pink2" . "#EEA9B8")
- ("pink3" . "#CD919E")
- ("pink4" . "#8B636C")
- ("plum" . "#DDA0DD")
- ("plum1" . "#FFBBFF")
- ("plum2" . "#EEAEEE")
- ("plum3" . "#CD96CD")
- ("plum4" . "#8B668B")
- ("powderblue" . "#B0E0E6")
- ("purple" . "#A020F0")
- ("purple1" . "#9B30FF")
- ("purple2" . "#912CEE")
- ("purple3" . "#7D26CD")
- ("purple4" . "#551A8B")
- ("red" . "#FF0000")
- ("red1" . "#FF0000")
- ("red2" . "#EE0000")
- ("red3" . "#CD0000")
- ("red4" . "#8B0000")
- ("rosybrown" . "#BC8F8F")
- ("rosybrown1" . "#FFC1C1")
- ("rosybrown2" . "#EEB4B4")
- ("rosybrown3" . "#CD9B9B")
- ("rosybrown4" . "#8B6969")
- ("royalblue" . "#4169E1")
- ("royalblue1" . "#4876FF")
- ("royalblue2" . "#436EEE")
- ("royalblue3" . "#3A5FCD")
- ("royalblue4" . "#27408B")
- ("saddlebrown" . "#8B4513")
- ("salmon" . "#FA8072")
- ("salmon1" . "#FF8C69")
- ("salmon2" . "#EE8262")
- ("salmon3" . "#CD7054")
- ("salmon4" . "#8B4C39")
- ("sandybrown" . "#F4A460")
- ("seagreen" . "#2E8B57")
- ("seagreen1" . "#54FF9F")
- ("seagreen2" . "#4EEE94")
- ("seagreen3" . "#43CD80")
- ("seagreen4" . "#2E8B57")
- ("seashell" . "#FFF5EE")
- ("seashell1" . "#FFF5EE")
- ("seashell2" . "#EEE5DE")
- ("seashell3" . "#CDC5BF")
- ("seashell4" . "#8B8682")
- ("sienna" . "#A0522D")
- ("sienna1" . "#FF8247")
- ("sienna2" . "#EE7942")
- ("sienna3" . "#CD6839")
- ("sienna4" . "#8B4726")
- ("skyblue" . "#87CEEB")
- ("skyblue1" . "#87CEFF")
- ("skyblue2" . "#7EC0EE")
- ("skyblue3" . "#6CA6CD")
- ("skyblue4" . "#4A708B")
- ("slateblue" . "#6A5ACD")
- ("slateblue1" . "#836FFF")
- ("slateblue2" . "#7A67EE")
- ("slateblue3" . "#6959CD")
- ("slateblue4" . "#473C8B")
- ("slategray" . "#708090")
- ("slategray1" . "#C6E2FF")
- ("slategray2" . "#B9D3EE")
- ("slategray3" . "#9FB6CD")
- ("slategray4" . "#6C7B8B")
- ("slategrey" . "#708090")
- ("snow" . "#FFFAFA")
- ("snow1" . "#FFFAFA")
- ("snow2" . "#EEE9E9")
- ("snow3" . "#CDC9C9")
- ("snow4" . "#8B8989")
- ("springgreen" . "#00FF7F")
- ("springgreen1" . "#00FF7F")
- ("springgreen2" . "#00EE76")
- ("springgreen3" . "#00CD66")
- ("springgreen4" . "#008B45")
- ("steelblue" . "#4682B4")
- ("steelblue1" . "#63B8FF")
- ("steelblue2" . "#5CACEE")
- ("steelblue3" . "#4F94CD")
- ("steelblue4" . "#36648B")
- ("tan" . "#D2B48C")
- ("tan1" . "#FFA54F")
- ("tan2" . "#EE9A49")
- ("tan3" . "#CD853F")
- ("tan4" . "#8B5A2B")
- ("thistle" . "#D8BFD8")
- ("thistle1" . "#FFE1FF")
- ("thistle2" . "#EED2EE")
- ("thistle3" . "#CDB5CD")
- ("thistle4" . "#8B7B8B")
- ("tomato" . "#FF6347")
- ("tomato1" . "#FF6347")
- ("tomato2" . "#EE5C42")
- ("tomato3" . "#CD4F39")
- ("tomato4" . "#8B3626")
- ("turquoise" . "#40E0D0")
- ("turquoise1" . "#00F5FF")
- ("turquoise2" . "#00E5EE")
- ("turquoise3" . "#00C5CD")
- ("turquoise4" . "#00868B")
- ("violet" . "#EE82EE")
- ("violetred" . "#D02090")
- ("violetred1" . "#FF3E96")
- ("violetred2" . "#EE3A8C")
- ("violetred3" . "#CD3278")
- ("violetred4" . "#8B2252")
- ("wheat" . "#F5DEB3")
- ("wheat1" . "#FFE7BA")
- ("wheat2" . "#EED8AE")
- ("wheat3" . "#CDBA96")
- ("wheat4" . "#8B7E66")
- ("whitesmoke" . "#F5F5F5")
- ("yellow" . "#FFFF00")
- ("yellow1" . "#FFFF00")
- ("yellow2" . "#EEEE00")
- ("yellow3" . "#CDCD00")
- ("yellow4" . "#8B8B00")
- ("yellowgreen" . "#9ACD32"))
- "Alist of R colors.
-Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR)."
- :type 'alist
- :group 'rainbow)
-
-(defcustom rainbow-r-colors-major-mode-list
- '(ess-mode)
- "List of major mode where R colors are enabled when
-`rainbow-r-colors' is set to auto."
- :type '(repeat (symbol :tag "Major-Mode"))
- :group 'rainbow)
-
-(defcustom rainbow-r-colors 'auto
- "When to enable R colors.
-If set to t, the R colors will be enabled. If set to nil, the
-R colors will not be enabled. If set to auto, the R colors
-will be enabled if a major mode has been detected from the
-`rainbow-r-colors-major-mode-list'."
- :type '(choice (symbol :tag "enable in certain modes" auto)
- (symbol :tag "enable globally" t)
- (symbol :tag "disable" nil))
- :group 'rainbow)
-
-;;; Functions
-
-(defun rainbow-colorize-match (color &optional match)
- "Return a matched string propertized with a face whose
-background is COLOR. The foreground is computed using
-`rainbow-color-luminance', and is either white or black."
- (let ((match (or match 0)))
- (put-text-property
- (match-beginning match) (match-end match)
- 'face `((:foreground ,(if (> 0.5 (rainbow-x-color-luminance color))
- "white" "black"))
- (:background ,color)))))
-
-(defun rainbow-colorize-itself (&optional match)
- "Colorize a match with itself."
- (rainbow-colorize-match (match-string-no-properties (or match 0)) match))
-
-(defun rainbow-colorize-hexadecimal-without-sharp ()
- "Colorize an hexadecimal colors and prepend # to it."
- (rainbow-colorize-match (concat "#" (match-string-no-properties 1))))
-
-(defun rainbow-colorize-by-assoc (assoc-list)
- "Colorize a match with its association from ASSOC-LIST."
- (rainbow-colorize-match (cdr (assoc-string (match-string-no-properties 0)
- assoc-list t))))
-
-(defun rainbow-rgb-relative-to-absolute (number)
- "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER.
-This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\".
-If the percentage value is above 100, it's converted to 100."
- (let ((string-length (- (length number) 1)))
- ;; Is this a number with %?
- (if (eq (elt number string-length) ?%)
- (/ (* (min (string-to-number (substring number 0 string-length)) 100)
255) 100)
- (string-to-number number))))
-
-(defun rainbow-colorize-hsl ()
- "Colorize a match with itself."
- (let ((h (/ (string-to-number (match-string-no-properties 1)) 360.0))
- (s (/ (string-to-number (match-string-no-properties 2)) 100.0))
- (l (/ (string-to-number (match-string-no-properties 3)) 100.0)))
- (rainbow-colorize-match
- (cl-destructuring-bind (r g b)
- (color-hsl-to-rgb h s l)
- (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))))
-
-(defun rainbow-colorize-rgb ()
- "Colorize a match with itself."
- (let ((r (rainbow-rgb-relative-to-absolute (match-string-no-properties 1)))
- (g (rainbow-rgb-relative-to-absolute (match-string-no-properties 2)))
- (b (rainbow-rgb-relative-to-absolute (match-string-no-properties 3))))
- (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
-
-(defun rainbow-colorize-rgb-float ()
- "Colorize a match with itself, with relative value."
- (let ((r (* (string-to-number (match-string-no-properties 1)) 255.0))
- (g (* (string-to-number (match-string-no-properties 2)) 255.0))
- (b (* (string-to-number (match-string-no-properties 3)) 255.0)))
- (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
-
-(defvar ansi-color-context)
-(defvar xterm-color-current)
-
-(defun rainbow-colorize-ansi ()
- "Return a matched string propertized with ansi color face."
- (let ((xterm-color? (featurep 'xterm-color))
- (string (match-string-no-properties 0))
- color)
- (save-match-data
- (let* ((replaced (concat
- (replace-regexp-in-string
- "^\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\)"
- "\033" string) "x"))
- xterm-color-current
- ansi-color-context
- (applied (funcall (if xterm-color?
- 'xterm-color-filter
- 'ansi-color-apply)
- replaced))
- (face-property (get-text-property
- 0
- (if xterm-color? 'face 'font-lock-face)
- applied)))
- (unless (listp (or (car-safe face-property) face-property))
- (setq face-property (list face-property)))
- (setq color (funcall (if xterm-color? 'cadr 'cdr)
- (or (assq (if xterm-color?
- :foreground
- 'foreground-color)
- face-property)
- (assq (if xterm-color?
- :background
- 'background-color)
- face-property))))))
- (when color
- (rainbow-colorize-match color))))
-
-(defun rainbow-color-luminance (red green blue)
- "Calculate the relative luminance of color composed of RED, GREEN and BLUE.
-Return a value between 0 and 1."
- (/ (+ (* .2126 red) (* .7152 green) (* .0722 blue)) 255))
-
-(defun rainbow-x-color-luminance (color)
- "Calculate the relative luminance of a color string (e.g. \"#ffaa00\",
\"blue\").
-Return a value between 0 and 1."
- (let* ((values (x-color-values color))
- (r (/ (car values) 256.0))
- (g (/ (cadr values) 256.0))
- (b (/ (caddr values) 256.0)))
- (rainbow-color-luminance r g b)))
-
-;;; Mode
-
-(defun rainbow-turn-on ()
- "Turn on rainbow-mode."
- (font-lock-add-keywords nil
- rainbow-hexadecimal-colors-font-lock-keywords
- t)
- ;; Activate X colors?
- (when (or (eq rainbow-x-colors t)
- (and (eq rainbow-x-colors 'auto)
- (memq major-mode rainbow-x-colors-major-mode-list)))
- (font-lock-add-keywords nil
- rainbow-x-colors-font-lock-keywords
- t))
- ;; Activate LaTeX colors?
- (when (or (eq rainbow-latex-colors t)
- (and (eq rainbow-latex-colors 'auto)
- (memq major-mode rainbow-latex-colors-major-mode-list)))
- (font-lock-add-keywords nil
- rainbow-latex-rgb-colors-font-lock-keywords
- t))
- ;; Activate ANSI colors?
- (when (or (eq rainbow-ansi-colors t)
- (and (eq rainbow-ansi-colors 'auto)
- (memq major-mode rainbow-ansi-colors-major-mode-list)))
- (font-lock-add-keywords nil
- rainbow-ansi-colors-font-lock-keywords
- t))
- ;; Activate HTML colors?
- (when (or (eq rainbow-html-colors t)
- (and (eq rainbow-html-colors 'auto)
- (memq major-mode rainbow-html-colors-major-mode-list)))
- (setq rainbow-html-colors-font-lock-keywords
- `((,(regexp-opt (mapcar 'car rainbow-html-colors-alist) 'words)
- (0 (rainbow-colorize-by-assoc rainbow-html-colors-alist)))))
- (font-lock-add-keywords nil
- `(,@rainbow-html-colors-font-lock-keywords
- ,@rainbow-html-rgb-colors-font-lock-keywords)
- t))
- ;; Activate R colors?
- (when (or (eq rainbow-r-colors t)
- (and (eq rainbow-r-colors 'auto)
- (memq major-mode rainbow-r-colors-major-mode-list)))
- (setq rainbow-r-colors-font-lock-keywords
- `((,(regexp-opt (mapcar 'car rainbow-r-colors-alist) 'words)
- (0 (rainbow-colorize-by-assoc rainbow-r-colors-alist)))))
- (font-lock-add-keywords nil
- rainbow-r-colors-font-lock-keywords
- t)))
-
-(defun rainbow-turn-off ()
- "Turn off rainbow-mode."
- (font-lock-remove-keywords
- nil
- `(,@rainbow-hexadecimal-colors-font-lock-keywords
- ,@rainbow-x-colors-font-lock-keywords
- ,@rainbow-latex-rgb-colors-font-lock-keywords
- ,@rainbow-r-colors-font-lock-keywords
- ,@rainbow-html-colors-font-lock-keywords
- ,@rainbow-html-rgb-colors-font-lock-keywords)))
-
-(defvar rainbow-keywords-hook nil
- "Hook used to add additional font-lock keywords.
-This hook is called by `rainbow-mode' before it re-enables
-`font-lock-mode'. Hook functions must only add additional
-keywords when `rainbow-mode' is non-nil. When that is nil,
-then they must remove those additional keywords again.")
-
-;;;###autoload
-(define-minor-mode rainbow-mode
- "Colorize strings that represent colors.
-This will fontify with colors the string like \"#aabbcc\" or \"blue\"."
- :lighter " Rbow"
- (if rainbow-mode
- (rainbow-turn-on)
- (rainbow-turn-off))
- ;; We cannot use `rainbow-mode-hook' because this has
- ;; to be done before `font-lock-mode' is re-enabled.
- (run-hooks 'rainbow-keywords-hook)
- ;; Call `font-lock-mode' to refresh the buffer when used
- ;; e.g. interactively.
- (font-lock-mode 1))
-
-(provide 'rainbow-mode)
-
-;; Local Variables:
-;; indent-tabs-mode: nil
-;; End:
-;;; rainbow-mode.el ends here
diff --git a/packages/rcirc-menu/rcirc-menu.el
b/packages/rcirc-menu/rcirc-menu.el
deleted file mode 100644
index 7b5a73a..0000000
--- a/packages/rcirc-menu/rcirc-menu.el
+++ /dev/null
@@ -1,308 +0,0 @@
-;;; rcirc-menu.el --- A menu of all your rcirc connections
-
-;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
-
-;; Author: Alex Schroeder <alex@gnu.org>
-;; Maintainer: Alex Schroeder <alex@gnu.org>
-;; Created: 2017-08-10
-;; Version: 1.1
-;; Keywords: comm
-
-;; This file is 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; If you are connected to too many channels, `rcirc-track-minor-mode'
-;; is useless because the modeline is too short. Bind `rcirc-menu' to
-;; a key instead:
-;;
-;; (global-set-key (kbd "C-c r") 'rcirc-menu)
-
-;;; Code:
-(require 'rcirc)
-
-;;;###autoload
-(defun rcirc-menu ()
- "Show a list of all your `rcirc' buffers."
- (interactive)
- (switch-to-buffer (get-buffer-create "*Rcirc Menu*"))
- (rcirc-menu-mode)
- (rcirc-menu-refresh)
- (tabulated-list-print))
-
-(defvar rcirc-menu-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map "v" 'Buffer-menu-select)
- (define-key map "2" 'Buffer-menu-2-window)
- (define-key map "1" 'Buffer-menu-1-window)
- (define-key map "f" 'Buffer-menu-this-window)
- (define-key map "e" 'Buffer-menu-this-window)
- (define-key map "\C-m" 'Buffer-menu-this-window)
- (define-key map "o" 'Buffer-menu-other-window)
- (define-key map "\C-o" 'Buffer-menu-switch-other-window)
- (define-key map "d" 'Buffer-menu-delete)
- (define-key map "k" 'Buffer-menu-delete)
- (define-key map "\C-k" 'Buffer-menu-delete)
- (define-key map "\C-d" 'Buffer-menu-delete-backwards)
- (define-key map "x" 'Buffer-menu-execute)
- (define-key map " " 'next-line)
- (define-key map "\177" 'Buffer-menu-backup-unmark)
- (define-key map "u" 'Buffer-menu-unmark)
- (define-key map "m" 'Buffer-menu-mark)
- (define-key map "b" 'Buffer-menu-bury)
- (define-key map (kbd "M-s a C-s") 'Buffer-menu-isearch-buffers)
- (define-key map (kbd "M-s a M-C-s") 'Buffer-menu-isearch-buffers-regexp)
- (define-key map (kbd "M-s a C-o") 'Buffer-menu-multi-occur)
- (define-key map "c" 'rcirc-menu-catchup)
- (define-key map "C" 'rcirc-menu-catchup-all)
-
- (define-key map [mouse-2] 'Buffer-menu-mouse-select)
- (define-key map [follow-link] 'mouse-face)
-
- (define-key map [menu-bar rcirc-menu-mode] (cons (purecopy "Rcirc-Menu")
menu-map))
- (bindings--define-key menu-map [quit]
- '(menu-item "Quit" quit-window
- :help "Remove the rcirc menu from the display"))
- (bindings--define-key menu-map [rev]
- '(menu-item "Refresh" revert-buffer
- :help "Refresh the *Rcirc Menu* buffer contents"))
- (bindings--define-key menu-map [s0] menu-bar-separator)
- (bindings--define-key menu-map [cata]
- '(menu-item "Catch up All" rcirc-menu-catchup-all
- :help "Mark all buffers as read"))
- (bindings--define-key menu-map [cat]
- '(menu-item "Catch up" rcirc-menu-catchup
- :help "Mark this buffer as read"))
- (bindings--define-key menu-map [s1] menu-bar-separator)
- (bindings--define-key menu-map [sel]
- '(menu-item "Select Marked" Buffer-menu-select
- :help "Select this line's buffer; also display buffers marked
with `>'"))
- (bindings--define-key menu-map [bm2]
- '(menu-item "Select Two" Buffer-menu-2-window
- :help "Select this line's buffer, with previous buffer in
second window"))
- (bindings--define-key menu-map [bm1]
- '(menu-item "Select Current" Buffer-menu-1-window
- :help "Select this line's buffer, alone, in full frame"))
- (bindings--define-key menu-map [ow]
- '(menu-item "Select in Other Window" Buffer-menu-other-window
- :help "Select this line's buffer in other window, leaving
buffer menu visible"))
- (bindings--define-key menu-map [tw]
- '(menu-item "Select in Current Window" Buffer-menu-this-window
- :help "Select this line's buffer in this window"))
- (bindings--define-key menu-map [s2] menu-bar-separator)
- (bindings--define-key menu-map [is]
- '(menu-item "Regexp Isearch Marked Buffers..."
Buffer-menu-isearch-buffers-regexp
- :help "Search for a regexp through all marked buffers using
Isearch"))
- (bindings--define-key menu-map [ir]
- '(menu-item "Isearch Marked Buffers..." Buffer-menu-isearch-buffers
- :help "Search for a string through all marked buffers using
Isearch"))
- (bindings--define-key menu-map [mo]
- '(menu-item "Multi Occur Marked Buffers..." Buffer-menu-multi-occur
- :help "Show lines matching a regexp in marked buffers using
Occur"))
- (bindings--define-key menu-map [s3] menu-bar-separator)
- (bindings--define-key menu-map [by]
- '(menu-item "Bury" Buffer-menu-bury
- :help "Bury the buffer listed on this line"))
- (bindings--define-key menu-map [ex]
- '(menu-item "Execute" Buffer-menu-execute
- :help "Delete buffers marked with k commands"))
- (bindings--define-key menu-map [s4] menu-bar-separator)
- (bindings--define-key menu-map [delb]
- '(menu-item "Mark for Delete and Move Backwards"
Buffer-menu-delete-backwards
- :help "Mark buffer on this line to be deleted by x command and
move up one line"))
- (bindings--define-key menu-map [del]
- '(menu-item "Mark for Delete" Buffer-menu-delete
- :help "Mark buffer on this line to be deleted by x command"))
- (bindings--define-key menu-map [umk]
- '(menu-item "Unmark" Buffer-menu-unmark
- :help "Cancel all requested operations on buffer on this line
and move down"))
- (bindings--define-key menu-map [mk]
- '(menu-item "Mark" Buffer-menu-mark
- :help "Mark buffer on this line for being displayed by v
command"))
- map)
- "Local keymap for `rcirc-menu-mode' buffers.")
-
-(define-derived-mode rcirc-menu-mode tabulated-list-mode "Rcirc Menu"
- "Major mode for Rcirc Menu buffers.
-The Rcirc Menu is invoked by the command \\[rcirc-menu].
-
-Columns:
- T - this buffer has a target, a live connection
- P - buffer priority
-
-In Rcirc Menu mode, the following commands are defined:
-\\<rcirc-menu-mode-map>
-\\[quit-window] Remove the Buffer Menu from the display.
-\\[tabulated-list-sort] sorts buffers according to the current
- column. With a numerical argument, sort by that column.
-\\[Buffer-menu-this-window] Select current line's buffer in place of the
buffer menu.
-\\[Buffer-menu-other-window] Select that buffer in another window,
- so the Buffer Menu remains visible in its window.
-\\[Buffer-menu-switch-other-window] Make another window display that buffer.
-\\[Buffer-menu-mark] Mark current line's buffer to be displayed.
-\\[Buffer-menu-select] Select current line's buffer.
- Also show buffers marked with m, in other windows.
-\\[Buffer-menu-1-window] Select that buffer in full-frame window.
-\\[Buffer-menu-2-window] Select that buffer in one window, together with the
- buffer selected before this one in another window.
-\\[Buffer-menu-isearch-buffers] Incremental search in the marked buffers.
-\\[Buffer-menu-isearch-buffers-regexp] Isearch for regexp in the marked
buffers.
-\\[Buffer-menu-multi-occur] Show lines matching regexp in the marked buffers.
-\\[Buffer-menu-delete] Mark that buffer to be deleted, and move down.
-\\[Buffer-menu-delete-backwards] Mark that buffer to be deleted, and move up.
-\\[Buffer-menu-execute] Delete or save marked buffers.
-\\[Buffer-menu-unmark] Remove all marks from current line.
- With prefix argument, also move up one line.
-\\[Buffer-menu-backup-unmark] Back up a line and remove marks.
-\\[revert-buffer] Update the list of buffers.
-\\[Buffer-menu-bury] Bury the buffer listed on this line."
- (add-hook 'tabulated-list-revert-hook 'rcirc-menu-refresh nil t))
-
-(defun rcirc-menu-refresh ()
- "Refresh the list of buffers."
- ;; Set up `tabulated-list-format'.
- (setq tabulated-list-format
- (vector '("T" 1 t)
- '("P" 1 rcirc-menu-sort-priority)
- '("Target" 30 t)
- '("Server" 20 t)
- '("Activity" 10 rcirc-menu-sort-activity))
- tabulated-list-sort-key '("Activity"))
- ;; Collect info for each buffer we're interested in.
- (let* ((pair (rcirc-split-activity rcirc-activity))
- (lopri (car pair))
- (hipri (cdr pair))
- entries)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'rcirc-mode)
- (push (list buf
- (vector
- (if rcirc-target "•" " ") ;; "T"
- (cond ((memq buf hipri) "↑")
- ((memq buf lopri) "↓")
- (t " ")) ;; "P"
- (or rcirc-target
- (car (split-string
- (buffer-name) "@"))) ;; "Target"
- (with-current-buffer rcirc-server-buffer
- rcirc-server-name) ;; "Server"
- (rcirc-menu-activity))) ;; "Activity"
- entries))))
- (setq tabulated-list-entries (nreverse entries)))
- (tabulated-list-init-header))
-
-(defun rcirc-menu-sort-priority (&rest args)
- "Sort by priority.
-ARGS is a list of two elements having the same form as the
-elements of ‘tabulated-list-entries’."
- (setq args (mapcar (lambda (v)
- (let ((s (aref (cadr v) 1)))
- (cond ((string= s "↑") 1)
- ((string= s "↓") 3)
- (t 2))))
- args))
- (apply '< args))
-
-(defun rcirc-menu-sort-activity (&rest args)
- "Sort by activity.
-ARGS is a list of two elements having the same form as the
-elements of ‘tabulated-list-entries’. At this point, we only have
-the comma-separated string produced by `rcirc-menu-activity' in
-the vector. The alternative is to simply visit the buffers and
-examine `rcirc-activity-types'."
- (setq args (mapcar (lambda (v)
- (let ((buf (car v)))
- (with-current-buffer buf
- (cond ((null rcirc-target) 5)
- ((memq 'nick rcirc-activity-types) 1)
- ((memq 'keyword rcirc-activity-types) 2)
- (rcirc-activity-types 3)
- (t 4)))))
- args))
- (apply '< args))
-
-(defun rcirc-menu-sort-activity-symbols (&rest args)
- "Sort by activity symbols.
-ARGS are symbols from `rcirc-activity-types'."
- (setq args (mapcar (lambda (v)
- (cond ((eq v 'nick) 1)
- ((eq v 'keyword) 2)
- ((not v) 3)
- (t 4)))
- args))
- (apply '< args))
-
-(defun rcirc-menu-activity ()
- "Return string describing activity in the current buffer."
- (mapconcat (lambda (s)
- (cond ((eq s 'nick)
- (rcirc-facify "nick" 'rcirc-track-nick))
- ((eq s 'keyword)
- (rcirc-facify "keyword" 'rcirc-track-keyword))
- (t "yes")))
- (sort (copy-sequence rcirc-activity-types)
- 'rcirc-menu-sort-activity-symbols)
- ", "))
-
-(defun rcirc-menu-catchup ()
- "Mark the current buffer or the marked buffers as read.
-This resets their activity."
- (interactive)
- (let* ((this-buffer (list (Buffer-menu-buffer t)))
- (marked-buffers (Buffer-menu-marked-buffers))
- (buffers (or marked-buffers this-buffer)))
- (dolist (buf buffers)
- (rcirc-clear-activity buf)))
- (rcirc-menu-catchup-finish))
-
-(defun rcirc-menu-catchup-all ()
- "Mark all the buffers as read, i.e. no activity."
- (interactive)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when rcirc-activity-types
- (rcirc-clear-activity buf))))
- (rcirc-menu-catchup-finish))
-
-(defun rcirc-menu-catchup-finish ()
- "Update buffer and activity string after catching up."
- ;; Don't call rcirc-menu-update which reverts the tabulated list.
- (let ((rcirc-update-activity-string-hook
- (delete 'rcirc-menu-update rcirc-update-activity-string-hook)))
- (rcirc-update-activity-string))
- ;; These two are from `tabulated-list-revert' but we don't want to
- ;; move point.
- (run-hooks 'tabulated-list-revert-hook)
- (tabulated-list-print))
-
-(add-hook 'rcirc-update-activity-string-hook
- 'rcirc-menu-update)
-
-(defun rcirc-menu-update ()
- "Update the Rcirc Menu buffer, if any."
- (let ((buf (get-buffer "*Rcirc Menu*")))
- (when buf
- (with-current-buffer buf
- (when (derived-mode-p 'tabulated-list-mode)
- ;; this will move point
- (tabulated-list-revert))))))
-
-(provide 'rcirc-menu)
-
-;;; rcirc-menu.el ends here
diff --git a/packages/scroll-restore/scroll-restore.el
b/packages/scroll-restore/scroll-restore.el
deleted file mode 100644
index 5c99207..0000000
--- a/packages/scroll-restore/scroll-restore.el
+++ /dev/null
@@ -1,478 +0,0 @@
-;;; scroll-restore.el --- restore original position after scrolling -*-
lexical-binding:t -*-
-
-;; Copyright (C) 2007,2014 Free Software Foundation, Inc.
-
-;; Time-stamp: "2007-12-05 10:44:11 martin"
-;; Author: Martin Rudalics <rudalics@gmx.at>
-;; Keywords: scrolling
-;; Version: 1.0
-
-;; scroll-restore.el is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; scroll-restore.el 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Scroll Restore mode is a minor mode to restore the position of
-;; `point' in a sequence of scrolling commands whenever that position
-;; has gone off-screen and becomes visible again. The user option
-;; `scroll-restore-commands' specifies the set of commands that may
-;; constitute such a sequence.
-
-;; The following additional options are provided:
-
-;; - Recenter the window when restoring the original position, see
-;; `scroll-restore-recenter'.
-
-;; - Jump back to the original position before executing a command not
-;; in `scroll-restore-commands', see `scroll-restore-jump-back'. The
-;; resulting behavior is similar to that provided by a number of word
-;; processors.
-
-;; - Change the appearance of the cursor in the selected window to
-;; indicate that the original position is off-screen, see
-;; `scroll-restore-handle-cursor'.
-
-;; - With `transient-mark-mode' non-nil Emacs highlights the region
-;; between `point' and `mark' when the mark is active. If you scroll
-;; `point' off-screen, Emacs relocates `point' _and_ the region.
-;; Customizing `scroll-restore-handle-region' permits to highlight the
-;; original region as long as the original position of `point' is
-;; off-screen, and restore the original region whenever the original
-;; position of `point' becomes visible again.
-
-
-;; Caveats:
-
-;; - Scroll Restore mode does not handle `switch-frame' and
-;; `vertical-scroll-bar' events executed within the loops in
-;; `mouse-show-mark' and `scroll-bar-drag' (these don't call
-;; `post-command-hook' as needed by Scroll Restore mode).
-
-;; - Scroll Restore mode may disregard your customizations of
-;; `scroll-margin'. Handling `scroll-margin' on the Elisp level is
-;; tedious and might not work correctly.
-
-;; - Scroll Restore mode should handle `make-cursor-line-fully-visible'
-;; but there might be problems.
-
-;; - Scroll Restore mode can handle region and cursor only in the
-;; selected window. This makes a difference when you have set
-;; `highlight-nonselected-windows' to a non-nil value.
-
-;; - Scroll Restore mode has not been tested with emulation modes like
-;; `cua-mode' or `pc-selection-mode'. In particular, the former's
-;; handling of `cursor-type' and `cursor-color' might be affected by
-;; Scroll Restore mode."
-
-;; - Scroll Restore mode might interact badly with `follow-mode'. For
-;; example, the latter may deliberately select a window A when the
-;; original position of a window B appears in it. This won't restore
-;; the appearance of the cursor when Scroll Restore mode handles it.
-
-
-;;; Code:
-
-(defgroup scroll-restore nil
- "Restore original position after scrolling."
- :version "23.1"
- :group 'windows)
-
-(defun scroll-restore--set (symbol value)
- (set-default symbol value)
- (when (and (boundp 'scroll-restore-mode) scroll-restore-mode)
- (scroll-restore-mode -1)
- (scroll-restore-mode 1)))
-
-(defcustom scroll-restore-commands
- ;; FIXME: How 'bout using the `scroll-command' property?
- '(handle-select-window handle-switch-frame
- scroll-up scroll-down
- scroll-up-command scroll-down-command
- scroll-bar-toolkit-scroll mwheel-scroll
- scroll-other-window scroll-other-window-down
- scroll-bar-scroll-up scroll-bar-scroll-down scroll-bar-drag)
- "Commands handled by Scroll Restore mode.
-Scroll Restore mode will try to restore the original position of
-`point' after executing a sequence of any of these commands."
- :type '(repeat symbol)
- :set #'(lambda (symbol value)
- (when (boundp 'scroll-restore-commands)
- (dolist (cmd scroll-restore-commands)
- (put cmd 'scroll-restore nil)))
- (set-default symbol value)
- (dolist (cmd scroll-restore-commands)
- (put cmd 'scroll-restore t))))
-
-;; Recenter.
-(defcustom scroll-restore-recenter nil
- "Non-nil means scrolling back recenters the original position.
-Setting this to a non-nil value can be useful to detect the original
-position more easily and coherently when scrolling back."
- :type 'boolean)
-
-;; Jump back.
-(defcustom scroll-restore-jump-back nil
- "Non-nil means jump back to original position after scrolling.
-When this option is non-nil, Scroll Restore mode resets `point'
-to the original position when scrolling has moved that position
-off-screen and a command not in `scroll-restore-commands' shall
-be executed. The resulting behavior is similar to that of some
-word processors. You probably want to remove commands like
-`scroll-up' and `scroll-down' from `scroll-restore-commands' when
-activating this option.
-
-Alternatively you may consider binding the command
-`scroll-restore-jump-back' to a key of your choice."
- :type 'boolean
- :set #'scroll-restore--set)
-
-;;; Cursor handling.
-(defvar scroll-restore-buffer nil
- "Buffer for `scroll-restore-cursor-type'.")
-
-;; Note: nil is a valid cursor-type.
-(defvar scroll-restore-buffer-cursor-type 'invalid
- "Original cursor-type of `scroll-restore-buffer'.")
-
-(defvar scroll-restore-frame nil
- "Frame for `scroll-restore-cursor-color'.")
-
-(defvar scroll-restore-frame-cursor-color nil
- "Original cursor-color of `scroll-restore-frame'.")
-
-(defcustom scroll-restore-handle-cursor nil
- "Non-nil means Scroll Restore mode may change appearance of cursor.
-Scroll Restore mode can change the appearance of the cursor in
-the selected window while the original position is off-screen.
-Customize `scroll-restore-cursor-type' to change the type of the
-cursor and `scroll-restore-cursor-color' to change its color."
- :type '(choice
- (const :tag "Off" nil)
- (const :tag "Cursor type" type)
- (const :tag "Cursor color" color)
- (const :tag "Type and color" t))
- :set #'scroll-restore--set)
-
-(defcustom scroll-restore-cursor-type 'box
- "Type of cursor when original position is off-screen.
-Applied if and only if `scroll-restore-handle-cursor' is either
-`type' or t.
-
-Be careful when another application uses that type. Otherwise,
-you might get unexpected results when Scroll Restore mode resets
-the cursor type to its \"original\" value after a sequence of
-scrolling commands and the application has changed the cursor
-type in between.
-
-To guard against unexpected results, Scroll Restore mode does not
-reset the type of the cursor whenever its value does not equal
-the value of scroll-restore-cursor-type."
- :type '(choice
- (const :tag "No cursor" nil)
- (const :tag "Filled box" box)
- (const :tag "Hollow box" hollow)
- (const :tag "Vertical bar" bar)
- (const :tag "Horizontal bar" hbar))
- :set #'scroll-restore--set)
-
-(defcustom scroll-restore-cursor-color "DarkCyan"
- "Background color of cursor when original position is off-screen.
-Applied if and only if `scroll-restore-handle-cursor' is either
-`color' or t.
-
-Observe that when Emacs changes the color of the cursor, the
-change applies to all windows on the associated frame.
-
-Be careful when another application is allowed to change the
-cursor-color. Otherwise, you might get unexpected results when
-Scroll Restore mode resets the cursor color to its \"original\"
-value and the application has changed the cursor color in
-between.
-
-To guard against unexpected results Scroll Restore mode does not
-reset the color of the cursor whenever its value does not equal
-the value of scroll-restore-cursor-color."
- :type 'color
- :set #'scroll-restore--set)
-
-;;; Region handling.
-
-;; FIXME: We should try to use pre-redisplay-function instead.
-
-(defvar scroll-restore-region-overlay
- (let ((overlay (make-overlay (point-min) (point-min))))
- (overlay-put overlay 'face 'scroll-restore-region)
- (delete-overlay overlay)
- overlay)
- "Overlay used for highlighting the region.")
-
-(defcustom scroll-restore-handle-region nil
- "Non-nil means Scroll Restore mode handles the region.
-This affects the behavior of Emacs in `transient-mark-mode' only.
-In particular, Emacs will suppress highlighting the region as
-long as the original position of `point' is off-screen. Rather,
-Emacs will highlight the original region \(the region before
-scrolling started\) in `scroll-restore-region' face. Scrolling
-back to the original position will restore the region to its
-original state.
-
-Note that Scroll Restore mode does not deactivate the mark during
-scrolling. Hence any operation on the region will not use the
-original but the _actual_ value of `point'.
-
-If you mark the region via `mouse-drag-region', setting this
-option has no effect since Scroll Restore mode cannot track mouse
-drags."
- :type 'boolean
- :set #'scroll-restore--set)
-
-(defface scroll-restore-region
- '((t :inherit region))
- "Face for Scroll Restore region when `scroll-restore-handle-region' is
-non-nil.")
-
-;; Note: We can't use `point-before-scroll' for our purposes because
-;; that variable is buffer-local. We need a variable that recorded
-;; `window-point' before a sequence of scroll operations. Also
-;; `point-before-scroll' is not handled by mwheel.el and some other
-;; commands that do implicit scrolling. hence, the original position is
-;; handled, among others, by the following alist.
-(defvar scroll-restore-alist nil
- "List of <window, buffer, point> quadruples.
-`window' is the window affected, `buffer' its buffer. `pos' is
-the original position of `point' in that window. `off' non-nil
-means `pos' was off-screen \(didn't appear in `window'\).")
-
-(defun scroll-restore-pre-command ()
- "Scroll Restore's pre-command function."
- (let ((overlay-buffer (overlay-buffer scroll-restore-region-overlay)))
- ;; Handle region overlay.
- (when overlay-buffer
- ;; Remove `transient-mark-mode' binding in any case.
- (with-current-buffer overlay-buffer
- (kill-local-variable 'transient-mark-mode))
- (delete-overlay scroll-restore-region-overlay)))
- ;; Handle cursor-type.
- (when (and scroll-restore-buffer
- (not (eq scroll-restore-buffer-cursor-type 'invalid))
- (with-current-buffer scroll-restore-buffer
- (eq cursor-type scroll-restore-cursor-type)))
- (with-current-buffer scroll-restore-buffer
- (setq cursor-type scroll-restore-buffer-cursor-type)
- (setq scroll-restore-buffer-cursor-type 'invalid)))
- ;; Handle cursor-color.
- (when (and scroll-restore-frame scroll-restore-frame-cursor-color
- (eq (frame-parameter scroll-restore-frame 'cursor-color)
- scroll-restore-cursor-color))
- (let ((frame (selected-frame)))
- (select-frame scroll-restore-frame)
- (set-cursor-color scroll-restore-frame-cursor-color)
- (setq scroll-restore-frame-cursor-color nil)
- (select-frame frame)))
- ;; Handle jumping.
- (when (and scroll-restore-jump-back
- (not (get this-command 'scroll-restore)))
- (let ((entry (assq (selected-window) scroll-restore-alist)))
- (when entry
- (let ((window (car entry))
- ;; (buffer (nth 1 entry))
- (pos (nth 2 entry)))
- (set-window-point window pos)
- ;; We are on-screen now.
- (setcdr (nthcdr 2 entry) (list nil))))))
- ;; Paranoia.
- (unless (or scroll-restore-jump-back scroll-restore-handle-region
- scroll-restore-handle-cursor)
- ;; Should be never reached.
- (remove-hook 'pre-command-hook 'scroll-restore-pre-command)))
-
-(defun scroll-restore-remove (&optional all)
- "Remove stale entries from `scroll-restore-alist'.
-Optional argument ALL non-nil means remove them all."
- (dolist (entry scroll-restore-alist)
- (let ((window (car entry))
- (buffer (nth 1 entry))
- (pos (nth 2 entry)))
- (when (or all (not (window-live-p window))
- (not (eq (window-buffer window) buffer))
- (not (markerp pos)) (not (marker-position pos)))
- (when (markerp pos)
- (set-marker pos nil))
- (setq scroll-restore-alist
- (assq-delete-all window scroll-restore-alist))))))
-
-(defun scroll-restore-add ()
- "Add new entries to `scroll-restore-alist'."
- (walk-windows
- (lambda (window)
- (unless (assq window scroll-restore-alist)
- (let ((buffer (window-buffer window)))
- (setq scroll-restore-alist
- (cons
- (list
- window buffer
- (with-current-buffer buffer
- (copy-marker (window-point window)))
- nil)
- scroll-restore-alist)))))
- 'no-mini t))
-
-(defun scroll-restore-update (how window buffer pos)
- "Update various things in `scroll-restore-post-command'.
-HOW must be either on-off, on-on, off-off, off-on, or t. WINDOW
-and BUFFER are affected window and buffer. POS is the original
-position."
- (when (eq window (selected-window))
- (with-current-buffer buffer
- ;; Handle region.
- (when scroll-restore-handle-region
- (if (and transient-mark-mode mark-active
- (not deactivate-mark)
- (memq how '(on-off off-off)))
- (progn
- (move-overlay scroll-restore-region-overlay
- (min pos (mark)) (max pos (mark)) buffer)
- (overlay-put scroll-restore-region-overlay 'window window)
- ;; Temporarily disable `transient-mark-mode' in this buffer.
- (set (make-local-variable 'transient-mark-mode) nil))
- (delete-overlay scroll-restore-region-overlay)))
- ;; Handle cursor.
- (when (and scroll-restore-handle-cursor
- (memq how '(on-off off-off))
- ;; Change cursor iff there was a visible cursor.
- cursor-type)
- (when (memq scroll-restore-handle-cursor '(type t))
- (setq scroll-restore-buffer buffer)
- (setq scroll-restore-buffer-cursor-type cursor-type)
- (setq cursor-type scroll-restore-cursor-type))
- (when (memq scroll-restore-handle-cursor '(color t))
- (setq scroll-restore-frame (window-frame window))
- (setq scroll-restore-frame-cursor-color
- (frame-parameter scroll-restore-frame 'cursor-color))
- (let ((frame (selected-frame)))
- (select-frame scroll-restore-frame)
- (set-cursor-color scroll-restore-cursor-color)
- (select-frame frame)))))))
-
-(defun scroll-restore-post-command ()
- "Scroll Restore mode post-command function."
- (scroll-restore-remove)
- (let (recenter)
- (dolist (entry scroll-restore-alist)
- (let ((window (car entry))
- (buffer (nth 1 entry))
- (pos (nth 2 entry))
- (off (nth 3 entry)))
- (if (get this-command 'scroll-restore)
- ;; A scroll restore command.
- (if off
- ;; `pos' was off-screen.
- (if (pos-visible-in-window-p (marker-position pos) window)
- ;; `pos' is on-screen now.
- (progn
- ;; Move cursor to original position.
- (set-window-point window pos)
- ;; Recenter if desired.
- (when (and scroll-restore-recenter
- (eq window (selected-window)))
- (setq recenter (/ (window-height window) 2)))
- ;; Record on-screen status.
- (setcdr (nthcdr 2 entry) (list nil))
- (scroll-restore-update 'off-on window buffer pos))
- ;; `pos' is still off-screen
- (scroll-restore-update 'off-off window buffer pos))
- ;; `pos' was on-screen.
- (if (pos-visible-in-window-p pos window)
- ;; `pos' is still on-screen.
- (progn
- ;; Occasionally Emacs deliberately changes
- ;; `window-point' during scrolling even when
- ;; it's visible. Maybe this is due to
- ;; `make-cursor-line-fully-visible' maybe due to
- ;; `scroll-margin' maybe due to something else.
- ;; We override that behavior here.
- (unless (= (window-point) pos)
- (set-window-point window pos))
- (scroll-restore-update 'on-on window buffer pos))
- ;; `pos' moved off-screen.
- ;; Record off-screen state.
- (setcdr (nthcdr 2 entry) (list t))
- (scroll-restore-update 'on-off window buffer pos)))
- ;; Not a scroll-restore command.
- (let ((window-point (window-point window)))
- (when (and (eq window (selected-window))
- (or (/= window-point pos) off))
- ;; Record position and on-screen status.
- (setcdr
- (nthcdr 1 entry)
- (list (move-marker pos (window-point window)) nil)))
- (scroll-restore-update t window buffer pos)))))
- (scroll-restore-add)
- (when recenter (recenter recenter))))
-
-(defun scroll-restore-jump-back ()
- "Jump back to original position.
-The orginal position is the value of `window-point' in the
-selected window before you started scrolling.
-
-This command does not push the mark."
- (interactive)
- (let ((entry (assq (selected-window) scroll-restore-alist)))
- (if entry
- (goto-char (nth 2 entry))
- (error "No jump-back position available"))))
-
-;;;###autoload
-(define-minor-mode scroll-restore-mode
- "Toggle Scroll Restore mode.
-With arg, turn Scroll Restore mode on if arg is positive, off
-otherwise.
-
-In Scroll Restore mode Emacs attempts to restore the original
-position that existed before executing a sequence of scrolling
-commands whenever that position becomes visible again. The
-option `scroll-restore-commands' permits to specify the set of
-commands that may constitute such a sequence. In addition you
-can
-
-- recenter the window when you scroll back to the original
- position, see the option `scroll-restore-recenter',
-
-- aggressively jump back to the original position before
- executing a command not in `scroll-restore-commands', see
- `scroll-restore-jump-back',
-
-- change the appearance of the cursor in the selected window
- while the original position is off-screen, see the option
- `scroll-restore-handle-cursor',
-
-- change the appearance of the region in the selected window
- while the original position is off-screen, see the option
- `scroll-restore-handle-region'."
- :global t
- :group 'scroll-restore
- :init-value nil
- :link '(emacs-commentary-link "scroll-restore.el")
- (if scroll-restore-mode
- (progn
- (scroll-restore-add)
- (when (or scroll-restore-jump-back scroll-restore-handle-region
- scroll-restore-handle-cursor)
- (add-hook 'pre-command-hook 'scroll-restore-pre-command))
- (add-hook 'post-command-hook 'scroll-restore-post-command t))
- (scroll-restore-remove 'all)
- (remove-hook 'pre-command-hook 'scroll-restore-pre-command)
- (remove-hook 'post-command-hook 'scroll-restore-post-command)))
-
-(provide 'scroll-restore)
-;;; scroll-restore.el ends here
diff --git a/packages/sed-mode/sed-mode.el b/packages/sed-mode/sed-mode.el
deleted file mode 100644
index 1b35c7a..0000000
--- a/packages/sed-mode/sed-mode.el
+++ /dev/null
@@ -1,140 +0,0 @@
-;;; sed-mode.el --- Major mode to edit sed scripts -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Version: 1.0
-;; Keywords:
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; If you need this major mode, you might also want to
-;; consider spending some time with `M-x doctor'.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'smie)
-
-(defgroup sed-mode nil
- "Major mode to edit sed code."
- :group 'programming)
-
-
-(defvar sed-mode-syntax-table
- (let ((st (make-syntax-table)))
- (modify-syntax-entry ?# "<" st)
- (modify-syntax-entry ?\n ">" st)
- (modify-syntax-entry ?\\ "." st)
- st))
-
-(defconst sed-commands ":=aiqQrRbcdDhHgGlnNpPstTwWxy")
-
-(eval-and-compile
- (defconst sed-command-prefix-regexp "\\(?:^\\|[$/0-9;]\\)[ \t]*")
- (defconst sed-address-prefix-regexp "\\(?:^\\|[,;]\\)[ \t]*"))
-
-(defconst sed-label-regexp "[[:alnum:]]+")
-
-(defun sed-syntax-propertize (beg end)
- (goto-char beg)
- (sed-syntax-propertize-string end)
- (funcall
- (syntax-propertize-rules
- ("\\\\$"
- (0 (unless (nth 8 (save-excursion (syntax-ppss (match-beginning 0))))
- (put-text-property (match-beginning 0) (match-end 0)
- 'syntax-table (string-to-syntax "|"))
- (sed-syntax-propertize-string end)
- nil)))
- ((concat "\\(?:" sed-address-prefix-regexp
- "\\(?:\\(?1:/\\)\\|\\\\\\(?1:.\\)\\)"
- "\\|" sed-command-prefix-regexp "[sy]\\(?1:.\\)"
- "\\)")
- (0 (unless (nth 8 (save-excursion (syntax-ppss (match-beginning 0))))
- (put-text-property (match-beginning 1) (match-end 1)
- 'syntax-table (string-to-syntax "\""))
- (sed-syntax-propertize-string end)
- nil))))
- (point) end))
-
-(defun sed-syntax-propertize-string (end)
- (let* ((ppss (syntax-ppss))
- (c (nth 3 ppss)))
- (when c
- (let ((count (cond
- ((or (eq c t)
- (not (memq (char-before (nth 8 ppss)) '(?s ?y))))
- 1)
- (t 2))))
- (goto-char (1+ (nth 8 ppss)))
- (when (re-search-forward
- (if (eq c t) "[^\\]\n" (regexp-quote (string c)))
- end 'move count)
- (put-text-property (1- (match-end 0)) (match-end 0)
- 'syntax-table
- (if (eq c t) (string-to-syntax "|")
- (string-to-syntax "\""))))))))
-
-(defun sed--font-lock-command (cmd)
- (unless (nth 8 (syntax-ppss))
- (pcase cmd
- (?: (if (looking-at (concat "[ ]*\\(" sed-label-regexp "\\)"))
- (put-text-property (match-beginning 1) (match-end 1) 'face
- font-lock-function-name-face)))
- ((or ?b ?t ?T)
- (if (looking-at (concat "[ ]*\\(" sed-label-regexp "\\)"))
- (put-text-property (match-beginning 1) (match-end 1) 'face
- font-lock-constant-face))))
- font-lock-keyword-face))
-
-(defconst sed-font-lock-keywords
- `((,(concat sed-command-prefix-regexp "\\([" sed-commands "]\\)")
- (1 (sed--font-lock-command (char-after (match-beginning 1)))))))
-
-(defconst sed-smie-grammar nil)
-
-(defun sed-smie-rules (kind token)
- (pcase (cons kind token)
- (`(:list-intro . ,_) t)
- ))
-
-;;;###autoload (add-to-list 'auto-mode-alist '("\\.sed\\'" . sed-mode))
-;;;###autoload (add-to-list 'interpreter-mode-alist '("sed" . sed-mode))
-
-;;;###autoload
-(define-derived-mode sed-mode prog-mode "Sed"
- "Sed editing mode."
- ;; (setq-local font-lock-support-mode nil) ;; To help debugging.
- (setq-local comment-start "# ")
- (setq-local comment-end "")
- (setq-local parse-sexp-lookup-properties t)
- (setq-local open-paren-in-column-0-is-defun-start nil)
- (setq-local syntax-propertize-function #'sed-syntax-propertize)
- (setq-local font-lock-defaults '(sed-font-lock-keywords))
- (smie-setup sed-smie-grammar #'sed-smie-rules
- ;; :backward-token #'sm-c-smie-backward-token
- ;; :forward-token #'sm-c-smie-forward-token
- )
- ;; Backslash auto-realign.
- ;; (add-hook 'after-change-functions #'sm-c--bs-after-change nil t)
- ;; (add-hook 'post-command-hook #'sm-c--bs-realign nil t)
- ;; (setq-local add-log-current-defun-header-regexp sm-c--def-regexp)
- ;; (setq-local imenu-generic-expression `((nil ,sm-c--def-regexp 1)))
- )
-
-(provide 'sed-mode)
-;;; sed-mode.el ends here
diff --git a/packages/seq/seq-24.el b/packages/seq/seq-24.el
deleted file mode 100644
index 3ca0964..0000000
--- a/packages/seq/seq-24.el
+++ /dev/null
@@ -1,496 +0,0 @@
-;;; seq-24.el --- seq.el implementation for Emacs 24.x -*- lexical-binding: t
-*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Keywords: sequences
-
-;; Maintainer: emacs-devel@gnu.org
-
-;; This file is 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Sequence-manipulation functions that complement basic functions
-;; provided by subr.el.
-;;
-;; All functions are prefixed with "seq-".
-;;
-;; All provided functions work on lists, strings and vectors.
-;;
-;; Functions taking a predicate or iterating over a sequence using a
-;; function as argument take the function as their first argument and
-;; the sequence as their second argument. All other functions take
-;; the sequence as their first argument.
-
-;;; Code:
-
-(defmacro seq-doseq (spec &rest body)
- "Loop over a sequence.
-Similar to `dolist' but can be applied to lists, strings, and vectors.
-
-Evaluate BODY with VAR bound to each element of SEQ, in turn.
-
-\(fn (VAR SEQ) BODY...)"
- (declare (indent 1) (debug ((symbolp form &optional form) body)))
- (let ((length (make-symbol "length"))
- (seq (make-symbol "seq"))
- (index (make-symbol "index")))
- `(let* ((,seq ,(cadr spec))
- (,length (if (listp ,seq) nil (seq-length ,seq)))
- (,index (if ,length 0 ,seq)))
- (while (if ,length
- (< ,index ,length)
- (consp ,index))
- (let ((,(car spec) (if ,length
- (prog1 (seq-elt ,seq ,index)
- (setq ,index (+ ,index 1)))
- (pop ,index))))
- ,@body)))))
-
-;; Implementation of `seq-let' compatible with Emacs<25.1.
-(defmacro seq-let (args sequence &rest body)
- "Bind the variables in ARGS to the elements of SEQUENCE then evaluate BODY.
-
-ARGS can also include the `&rest' marker followed by a variable
-name to be bound to the rest of SEQUENCE."
- (declare (indent 2) (debug t))
- (let ((seq-var (make-symbol "seq")))
- `(let* ((,seq-var ,sequence)
- ,@(seq--make-bindings args seq-var))
- ,@body)))
-
-(defun seq-drop (sequence n)
- "Return a subsequence of SEQUENCE without its first N elements.
-The result is a sequence of the same type as SEQUENCE.
-
-If N is a negative integer or zero, SEQUENCE is returned."
- (if (<= n 0)
- sequence
- (if (listp sequence)
- (seq--drop-list sequence n)
- (let ((length (seq-length sequence)))
- (seq-subseq sequence (min n length) length)))))
-
-(defun seq-take (sequence n)
- "Return a subsequence of SEQUENCE with its first N elements.
-The result is a sequence of the same type as SEQUENCE.
-
-If N is a negative integer or zero, an empty sequence is
-returned."
- (if (listp sequence)
- (seq--take-list sequence n)
- (seq-subseq sequence 0 (min (max n 0) (seq-length sequence)))))
-
-(defun seq-drop-while (predicate sequence)
- "Return a sequence from the first element for which (PREDICATE element) is
nil in SEQUENCE.
-The result is a sequence of the same type as SEQUENCE."
- (if (listp sequence)
- (seq--drop-while-list predicate sequence)
- (seq-drop sequence (seq--count-successive predicate sequence))))
-
-(defun seq-take-while (predicate sequence)
- "Return the successive elements for which (PREDICATE element) is non-nil in
SEQUENCE.
-The result is a sequence of the same type as SEQUENCE."
- (if (listp sequence)
- (seq--take-while-list predicate sequence)
- (seq-take sequence (seq--count-successive predicate sequence))))
-
-(defun seq-filter (predicate sequence)
- "Return a list of all the elements for which (PREDICATE element) is non-nil
in SEQUENCE."
- (let ((exclude (make-symbol "exclude")))
- (delq exclude (seq-map (lambda (elt)
- (if (funcall predicate elt)
- elt
- exclude))
- sequence))))
-
-(defun seq-map-indexed (function sequence)
- "Return the result of applying FUNCTION to each element of SEQUENCE.
-Unlike `seq-map', FUNCTION takes two arguments: the element of
-the sequence, and its index within the sequence."
- (let ((index 0))
- (seq-map (lambda (elt)
- (prog1
- (funcall function elt index)
- (setq index (1+ index))))
- sequence)))
-
-(defun seq-remove (predicate sequence)
- "Return a list of all the elements for which (PREDICATE element) is nil in
SEQUENCE."
- (seq-filter (lambda (elt) (not (funcall predicate elt)))
- sequence))
-
-(defun seq-reduce (function sequence initial-value)
- "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE.
-
-Return the result of calling FUNCTION with INITIAL-VALUE and the
-first element of SEQUENCE, then calling FUNCTION with that result and
-the second element of SEQUENCE, then with that result and the third
-element of SEQUENCE, etc.
-
-If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
- (if (seq-empty-p sequence)
- initial-value
- (let ((acc initial-value))
- (seq-doseq (elt sequence)
- (setq acc (funcall function acc elt)))
- acc)))
-
-(defun seq-some (predicate sequence)
- "Return the first value for which if (PREDICATE element) is non-nil for in
SEQUENCE."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (let ((result (funcall predicate elt)))
- (when result
- (throw 'seq--break result))))
- nil))
-
-(defun seq-find (predicate sequence &optional default)
- "Return the first element for which (PREDICATE element) is non-nil in
SEQUENCE.
-If no element is found, return DEFAULT.
-
-Note that `seq-find' has an ambiguity if the found element is
-identical to DEFAULT, as it cannot be known if an element was
-found or not."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (when (funcall predicate elt)
- (throw 'seq--break elt)))
- default))
-
-(defun seq-every-p (predicate sequence)
- "Return non-nil if (PREDICATE element) is non-nil for all elements of the
sequence SEQUENCE."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (or (funcall predicate elt)
- (throw 'seq--break nil)))
- t))
-
-(defun seq-count (predicate sequence)
- "Return the number of elements for which (PREDICATE element) is non-nil in
SEQUENCE."
- (let ((count 0))
- (seq-doseq (elt sequence)
- (when (funcall predicate elt)
- (setq count (+ 1 count))))
- count))
-
-(defun seq-empty-p (sequence)
- "Return non-nil if the sequence SEQUENCE is empty, nil otherwise."
- (if (listp sequence)
- (null sequence)
- (= 0 (seq-length sequence))))
-
-(defun seq-sort (predicate sequence)
- "Return a sorted sequence comparing using PREDICATE the elements of SEQUENCE.
-The result is a sequence of the same type as SEQUENCE."
- (if (listp sequence)
- (sort (seq-copy sequence) predicate)
- (let ((result (seq-sort predicate (append sequence nil))))
- (seq-into result (type-of sequence)))))
-
-(defun seq-sort-by (function pred sequence)
- "Sort SEQUENCE using PRED as a comparison function.
-Elements of SEQUENCE are transformed by FUNCTION before being
-sorted. FUNCTION must be a function of one argument."
- (seq-sort (lambda (a b)
- (funcall pred
- (funcall function a)
- (funcall function b)))
- sequence))
-
-(defun seq-contains (sequence elt &optional testfn)
- "Return the first element in SEQUENCE that equals to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-some (lambda (e)
- (funcall (or testfn #'equal) elt e))
- sequence))
-
-(defun seq-set-equal-p (sequence1 sequence2 &optional testfn)
- "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements,
regardless of order.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (and (seq-every-p (lambda (item1) (seq-contains sequence2 item1 testfn))
sequence1)
- (seq-every-p (lambda (item2) (seq-contains sequence1 item2 testfn))
sequence2)))
-
-(defun seq-position (sequence elt &optional testfn)
- "Return the index of the first element in SEQUENCE that is equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (let ((index 0))
- (catch 'seq--break
- (seq-doseq (e sequence)
- (when (funcall (or testfn #'equal) e elt)
- (throw 'seq--break index))
- (setq index (1+ index)))
- nil)))
-
-(defun seq-uniq (sequence &optional testfn)
- "Return a list of the elements of SEQUENCE with duplicates removed.
-TESTFN is used to compare elements, or `equal' if TESTFN is nil."
- (let ((result '()))
- (seq-doseq (elt sequence)
- (unless (seq-contains result elt testfn)
- (setq result (cons elt result))))
- (nreverse result)))
-
-(defun seq-subseq (sequence start &optional end)
- "Return the subsequence of SEQUENCE from START to END.
-If END is omitted, it defaults to the length of the sequence.
-If START or END is negative, it counts from the end."
- (cond ((or (stringp sequence) (vectorp sequence)) (substring sequence start
end))
- ((listp sequence)
- (let (len (errtext (format "Bad bounding indices: %s, %s" start end)))
- (and end (< end 0) (setq end (+ end (setq len (seq-length
sequence)))))
- (if (< start 0) (setq start (+ start (or len (setq len (seq-length
sequence))))))
- (when (> start 0)
- (setq sequence (nthcdr (1- start) sequence))
- (or sequence (error "%s" errtext))
- (setq sequence (cdr sequence)))
- (if end
- (let ((res nil))
- (while (and (>= (setq end (1- end)) start) sequence)
- (push (pop sequence) res))
- (or (= (1+ end) start) (error "%s" errtext))
- (nreverse res))
- (seq-copy sequence))))
- (t (error "Unsupported sequence: %s" sequence))))
-
-(defun seq-concatenate (type &rest seqs)
- "Concatenate, into a sequence of type TYPE, the sequences SEQS.
-TYPE must be one of following symbols: vector, string or list.
-
-\n(fn TYPE SEQUENCE...)"
- (pcase type
- (`vector (apply #'vconcat seqs))
- (`string (apply #'concat seqs))
- (`list (apply #'append (append seqs '(nil))))
- (_ (error "Not a sequence type name: %S" type))))
-
-(defun seq-mapcat (function sequence &optional type)
- "Concatenate the result of applying FUNCTION to each element of SEQUENCE.
-The result is a sequence of type TYPE, or a list if TYPE is nil."
- (apply #'seq-concatenate (or type 'list)
- (seq-map function sequence)))
-
-(defun seq-mapn (function sequence &rest seqs)
- "Like `seq-map' but FUNCTION is mapped over all SEQS.
-The arity of FUNCTION must match the number of SEQS, and the
-mapping stops on the shortest sequence.
-Return a list of the results.
-
-\(fn FUNCTION SEQS...)"
- (let ((result nil)
- (seqs (seq-map (lambda (s)
- (seq-into s 'list))
- (cons sequence seqs))))
- (while (not (memq nil seqs))
- (push (apply function (seq-map #'car seqs)) result)
- (setq seqs (seq-map #'cdr seqs)))
- (nreverse result)))
-
-(defun seq-partition (sequence n)
- "Return a list of the elements of SEQUENCE grouped into sub-sequences of
length N.
-The last sequence may contain less than N elements. If N is a
-negative integer or 0, nil is returned."
- (unless (< n 1)
- (let ((result '()))
- (while (not (seq-empty-p sequence))
- (push (seq-take sequence n) result)
- (setq sequence (seq-drop sequence n)))
- (nreverse result))))
-
-(defun seq-intersection (seq1 seq2 &optional testfn)
- "Return a list of the elements that appear in both SEQ1 and SEQ2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-reduce (lambda (acc elt)
- (if (seq-contains seq2 elt testfn)
- (cons elt acc)
- acc))
- (seq-reverse seq1)
- '()))
-
-(defun seq-difference (seq1 seq2 &optional testfn)
- "Return a list of the elements that appear in SEQ1 but not in SEQ2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-reduce (lambda (acc elt)
- (if (not (seq-contains seq2 elt testfn))
- (cons elt acc)
- acc))
- (seq-reverse seq1)
- '()))
-
-(defun seq-group-by (function sequence)
- "Apply FUNCTION to each element of SEQUENCE.
-Separate the elements of SEQUENCE into an alist using the results as
-keys. Keys are compared using `equal'."
- (seq-reduce
- (lambda (acc elt)
- (let* ((key (funcall function elt))
- (cell (assoc key acc)))
- (if cell
- (setcdr cell (push elt (cdr cell)))
- (push (list key elt) acc))
- acc))
- (seq-reverse sequence)
- nil))
-
-(defalias 'seq-reverse
- (if (ignore-errors (reverse [1 2]))
- #'reverse
- (lambda (sequence)
- "Return the reversed copy of list, vector, or string SEQUENCE.
-See also the function `nreverse', which is used more often."
- (let ((result '()))
- (seq-map (lambda (elt) (push elt result))
- sequence)
- (if (listp sequence)
- result
- (seq-into result (type-of sequence)))))))
-
-(defun seq-into (sequence type)
- "Convert the sequence SEQUENCE into a sequence of type TYPE.
-TYPE can be one of the following symbols: vector, string or list."
- (pcase type
- (`vector (seq--into-vector sequence))
- (`string (seq--into-string sequence))
- (`list (seq--into-list sequence))
- (_ (error "Not a sequence type name: %S" type))))
-
-(defun seq-min (sequence)
- "Return the smallest element of SEQUENCE.
-SEQUENCE must be a sequence of numbers or markers."
- (apply #'min (seq-into sequence 'list)))
-
-(defun seq-max (sequence)
- "Return the largest element of SEQUENCE.
-SEQUENCE must be a sequence of numbers or markers."
- (apply #'max (seq-into sequence 'list)))
-
-(defun seq-random-elt (sequence)
- "Return a random element from SEQUENCE.
-Signal an error if SEQUENCE is empty."
- (if (seq-empty-p sequence)
- (error "Sequence cannot be empty")
- (seq-elt sequence (random (seq-length sequence)))))
-
-(defun seq--drop-list (list n)
- "Return a list from LIST without its first N elements.
-This is an optimization for lists in `seq-drop'."
- (nthcdr n list))
-
-(defun seq--take-list (list n)
- "Return a list from LIST made of its first N elements.
-This is an optimization for lists in `seq-take'."
- (let ((result '()))
- (while (and list (> n 0))
- (setq n (1- n))
- (push (pop list) result))
- (nreverse result)))
-
-(defun seq--drop-while-list (predicate list)
- "Return a list from the first element for which (PREDICATE element) is nil
in LIST.
-This is an optimization for lists in `seq-drop-while'."
- (while (and list (funcall predicate (car list)))
- (setq list (cdr list)))
- list)
-
-(defun seq--take-while-list (predicate list)
- "Return the successive elements for which (PREDICATE element) is non-nil in
LIST.
-This is an optimization for lists in `seq-take-while'."
- (let ((result '()))
- (while (and list (funcall predicate (car list)))
- (push (pop list) result))
- (nreverse result)))
-
-(defun seq--count-successive (predicate sequence)
- "Return the number of successive elements for which (PREDICATE element) is
non-nil in SEQUENCE."
- (let ((n 0)
- (len (seq-length sequence)))
- (while (and (< n len)
- (funcall predicate (seq-elt sequence n)))
- (setq n (+ 1 n)))
- n))
-
-;; Helper function for the Backward-compatible version of `seq-let'
-;; for Emacs<25.1.
-(defun seq--make-bindings (args sequence &optional bindings)
- "Return a list of bindings of the variables in ARGS to the elements of a
sequence.
-if BINDINGS is non-nil, append new bindings to it, and return
-BINDINGS."
- (let ((index 0)
- (rest-marker nil))
- (seq-doseq (name args)
- (unless rest-marker
- (pcase name
- ((pred seqp)
- (setq bindings (seq--make-bindings (seq--elt-safe args index)
- `(seq--elt-safe ,sequence ,index)
- bindings)))
- (`&rest
- (progn (push `(,(seq--elt-safe args (1+ index))
- (seq-drop ,sequence ,index))
- bindings)
- (setq rest-marker t)))
- (_
- (push `(,name (seq--elt-safe ,sequence ,index)) bindings))))
- (setq index (1+ index)))
- bindings))
-
-(defun seq--elt-safe (sequence n)
- "Return element of SEQUENCE at the index N.
-If no element is found, return nil."
- (when (or (listp sequence)
- (and (sequencep sequence)
- (> (seq-length sequence) n)))
- (seq-elt sequence n)))
-
-(defun seq--activate-font-lock-keywords ()
- "Activate font-lock keywords for some symbols defined in seq."
- (font-lock-add-keywords 'emacs-lisp-mode
- '("\\<seq-doseq\\>" "\\<seq-let\\>")))
-
-(defalias 'seq-copy #'copy-sequence)
-(defalias 'seq-elt #'elt)
-(defalias 'seq-length #'length)
-(defalias 'seq-do #'mapc)
-(defalias 'seq-each #'seq-do)
-(defalias 'seq-map #'mapcar)
-(defalias 'seqp #'sequencep)
-
-(defun seq--into-list (sequence)
- "Concatenate the elements of SEQUENCE into a list."
- (if (listp sequence)
- sequence
- (append sequence nil)))
-
-(defun seq--into-vector (sequence)
- "Concatenate the elements of SEQUENCE into a vector."
- (if (vectorp sequence)
- sequence
- (vconcat sequence)))
-
-(defun seq--into-string (sequence)
- "Concatenate the elements of SEQUENCE into a string."
- (if (stringp sequence)
- sequence
- (concat sequence)))
-
-(unless (fboundp 'elisp--font-lock-flush-elisp-buffers)
- ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others)
- ;; we automatically highlight macros.
- (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords))
-
-(provide 'seq-24)
-;;; seq-24.el ends here
diff --git a/packages/seq/seq-25.el b/packages/seq/seq-25.el
deleted file mode 100644
index d3f8277..0000000
--- a/packages/seq/seq-25.el
+++ /dev/null
@@ -1,601 +0,0 @@
-;;; seq-25.el --- seq.el implementation for Emacs 25.x -*- lexical-binding: t
-*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Keywords: sequences
-
-;; Maintainer: emacs-devel@gnu.org
-
-;; This file is 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Sequence-manipulation functions that complement basic functions
-;; provided by subr.el.
-;;
-;; All functions are prefixed with "seq-".
-;;
-;; All provided functions work on lists, strings and vectors.
-;;
-;; Functions taking a predicate or iterating over a sequence using a
-;; function as argument take the function as their first argument and
-;; the sequence as their second argument. All other functions take
-;; the sequence as their first argument.
-;;
-;; seq.el can be extended to support new type of sequences. Here are
-;; the generic functions that must be implemented by new seq types:
-;; - `seq-elt'
-;; - `seq-length'
-;; - `seq-do'
-;; - `seqp'
-;; - `seq-subseq'
-;; - `seq-into-sequence'
-;; - `seq-copy'
-;; - `seq-into'
-
-;;; Code:
-
-;; When loading seq.el in Emacs 24.x, this file gets byte-compiled, even if
-;; never used. This takes care of byte-compilation warnings is emitted, by
-;; emitting nil in the macro expansion in Emacs 24.x.
-(defmacro seq--when-emacs-25-p (&rest body)
- "Execute BODY if in Emacs>=25.x."
- (declare (indent (lambda (&rest x) 0)) (debug t))
- (when (version<= "25" emacs-version)
- `(progn ,@body)))
-
-(seq--when-emacs-25-p
-
- (eval-when-compile (require 'cl-generic))
-
-;; We used to use some sequence functions from cl-lib, but this
-;; dependency was swapped around so that it will be easier to make
-;; seq.el preloaded in the future. See also Bug#39761#26.
-
-(defmacro seq-doseq (spec &rest body)
- "Loop over a sequence.
-Evaluate BODY with VAR bound to each element of SEQUENCE, in turn.
-
-Similar to `dolist' but can be applied to lists, strings, and vectors.
-
-\(fn (VAR SEQUENCE) BODY...)"
- (declare (indent 1) (debug ((symbolp form &optional form) body)))
- `(seq-do (lambda (,(car spec))
- ,@body)
- ,(cadr spec)))
-
-(pcase-defmacro seq (&rest patterns)
- "Build a `pcase' pattern that matches elements of SEQUENCE.
-
-The `pcase' pattern will match each element of PATTERNS against the
-corresponding element of SEQUENCE.
-
-Extra elements of the sequence are ignored if fewer PATTERNS are
-given, and the match does not fail."
- `(and (pred seqp)
- ,@(seq--make-pcase-bindings patterns)))
-
-(defmacro seq-let (args sequence &rest body)
- "Bind the variables in ARGS to the elements of SEQUENCE, then evaluate BODY.
-
-ARGS can also include the `&rest' marker followed by a variable
-name to be bound to the rest of SEQUENCE."
- (declare (indent 2) (debug (sexp form body)))
- `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence))
- ,@body))
-
-
-;;; Basic seq functions that have to be implemented by new sequence types
-(cl-defgeneric seq-elt (sequence n)
- "Return Nth element of SEQUENCE."
- (elt sequence n))
-
-;; Default gv setters for `seq-elt'.
-;; It can be a good idea for new sequence implementations to provide a
-;; "gv-setter" for `seq-elt'.
-(cl-defmethod (setf seq-elt) (store (sequence array) n)
- (aset sequence n store))
-
-(cl-defmethod (setf seq-elt) (store (sequence cons) n)
- (setcar (nthcdr n sequence) store))
-
-(cl-defgeneric seq-length (sequence)
- "Return the number of elements of SEQUENCE."
- (length sequence))
-
-(defun seq-first (sequence)
- "Return the first element of SEQUENCE."
- (seq-elt sequence 0))
-
-(defun seq-rest (sequence)
- "Return a sequence of the elements of SEQUENCE except the first one."
- (seq-drop sequence 1))
-
-(cl-defgeneric seq-do (function sequence)
- "Apply FUNCTION to each element of SEQUENCE, presumably for side effects.
-Return SEQUENCE."
- (mapc function sequence))
-
-(defalias 'seq-each #'seq-do)
-
-(defun seq-do-indexed (function sequence)
- "Apply FUNCTION to each element of SEQUENCE and return nil.
-Unlike `seq-map', FUNCTION takes two arguments: the element of
-the sequence, and its index within the sequence."
- (let ((index 0))
- (seq-do (lambda (elt)
- (funcall function elt index)
- (setq index (1+ index)))
- sequence)))
-
-(cl-defgeneric seqp (object)
- "Return non-nil if OBJECT is a sequence, nil otherwise."
- (sequencep object))
-
-(cl-defgeneric seq-copy (sequence)
- "Return a shallow copy of SEQUENCE."
- (copy-sequence sequence))
-
-(cl-defgeneric seq-subseq (sequence start &optional end)
- "Return the sequence of elements of SEQUENCE from START to END.
-END is exclusive.
-
-If END is omitted, it defaults to the length of the sequence. If
-START or END is negative, it counts from the end. Signal an
-error if START or END are outside of the sequence (i.e too large
-if positive or too small if negative)."
- (cond
- ((or (stringp sequence) (vectorp sequence)) (substring sequence start end))
- ((listp sequence)
- (let (len
- (errtext (format "Bad bounding indices: %s, %s" start end)))
- (and end (< end 0) (setq end (+ end (setq len (length sequence)))))
- (if (< start 0) (setq start (+ start (or len (setq len (length
sequence))))))
- (unless (>= start 0)
- (error "%s" errtext))
- (when (> start 0)
- (setq sequence (nthcdr (1- start) sequence))
- (or sequence (error "%s" errtext))
- (setq sequence (cdr sequence)))
- (if end
- (let ((res nil))
- (while (and (>= (setq end (1- end)) start) sequence)
- (push (pop sequence) res))
- (or (= (1+ end) start) (error "%s" errtext))
- (nreverse res))
- (copy-sequence sequence))))
- (t (error "Unsupported sequence: %s" sequence))))
-
-
-(cl-defgeneric seq-map (function sequence)
- "Return the result of applying FUNCTION to each element of SEQUENCE."
- (let (result)
- (seq-do (lambda (elt)
- (push (funcall function elt) result))
- sequence)
- (nreverse result)))
-
-(defun seq-map-indexed (function sequence)
- "Return the result of applying FUNCTION to each element of SEQUENCE.
-Unlike `seq-map', FUNCTION takes two arguments: the element of
-the sequence, and its index within the sequence."
- (let ((index 0))
- (seq-map (lambda (elt)
- (prog1
- (funcall function elt index)
- (setq index (1+ index))))
- sequence)))
-
-
-;; faster implementation for sequences (sequencep)
-(cl-defmethod seq-map (function (sequence sequence))
- (mapcar function sequence))
-
-(cl-defgeneric seq-mapn (function sequence &rest sequences)
- "Like `seq-map' but FUNCTION is mapped over all SEQUENCES.
-The arity of FUNCTION must match the number of SEQUENCES, and the
-mapping stops on the shortest sequence.
-Return a list of the results.
-
-\(fn FUNCTION SEQUENCES...)"
- (let ((result nil)
- (sequences (seq-map (lambda (s)
- (seq-into s 'list))
- (cons sequence sequences))))
- (while (not (memq nil sequences))
- (push (apply function (seq-map #'car sequences)) result)
- (setq sequences (seq-map #'cdr sequences)))
- (nreverse result)))
-
-(cl-defgeneric seq-drop (sequence n)
- "Remove the first N elements of SEQUENCE and return the result.
-The result is a sequence of the same type as SEQUENCE.
-
-If N is a negative integer or zero, SEQUENCE is returned."
- (if (<= n 0)
- sequence
- (let ((length (seq-length sequence)))
- (seq-subseq sequence (min n length) length))))
-
-(cl-defgeneric seq-take (sequence n)
- "Take the first N elements of SEQUENCE and return the result.
-The result is a sequence of the same type as SEQUENCE.
-
-If N is a negative integer or zero, an empty sequence is
-returned."
- (seq-subseq sequence 0 (min (max n 0) (seq-length sequence))))
-
-(cl-defgeneric seq-drop-while (pred sequence)
- "Remove the successive elements of SEQUENCE for which PRED returns non-nil.
-PRED is a function of one argument. The result is a sequence of
-the same type as SEQUENCE."
- (seq-drop sequence (seq--count-successive pred sequence)))
-
-(cl-defgeneric seq-take-while (pred sequence)
- "Take the successive elements of SEQUENCE for which PRED returns non-nil.
-PRED is a function of one argument. The result is a sequence of
-the same type as SEQUENCE."
- (seq-take sequence (seq--count-successive pred sequence)))
-
-(cl-defgeneric seq-empty-p (sequence)
- "Return non-nil if the SEQUENCE is empty, nil otherwise."
- (= 0 (seq-length sequence)))
-
-(cl-defgeneric seq-sort (pred sequence)
- "Sort SEQUENCE using PRED as comparison function.
-The result is a sequence of the same type as SEQUENCE."
- (let ((result (seq-sort pred (append sequence nil))))
- (seq-into result (type-of sequence))))
-
-(cl-defmethod seq-sort (pred (list list))
- (sort (seq-copy list) pred))
-
-(defun seq-sort-by (function pred sequence)
- "Sort SEQUENCE using PRED as a comparison function.
-Elements of SEQUENCE are transformed by FUNCTION before being
-sorted. FUNCTION must be a function of one argument."
- (seq-sort (lambda (a b)
- (funcall pred
- (funcall function a)
- (funcall function b)))
- sequence))
-
-(cl-defgeneric seq-reverse (sequence)
- "Return a sequence with elements of SEQUENCE in reverse order."
- (let ((result '()))
- (seq-map (lambda (elt)
- (push elt result))
- sequence)
- (seq-into result (type-of sequence))))
-
-;; faster implementation for sequences (sequencep)
-(cl-defmethod seq-reverse ((sequence sequence))
- (reverse sequence))
-
-(cl-defgeneric seq-concatenate (type &rest sequences)
- "Concatenate SEQUENCES into a single sequence of type TYPE.
-TYPE must be one of following symbols: vector, string or list.
-
-\n(fn TYPE SEQUENCE...)"
- (pcase type
- ('vector (apply #'vconcat sequences))
- ('string (apply #'concat sequences))
- ('list (apply #'append (append sequences '(nil))))
- (_ (error "Not a sequence type name: %S" type))))
-
-(cl-defgeneric seq-into-sequence (sequence)
- "Convert SEQUENCE into a sequence.
-
-The default implementation is to signal an error if SEQUENCE is not a
-sequence, specific functions should be implemented for new types
-of sequence."
- (unless (sequencep sequence)
- (error "Cannot convert %S into a sequence" sequence))
- sequence)
-
-(cl-defgeneric seq-into (sequence type)
- "Concatenate the elements of SEQUENCE into a sequence of type TYPE.
-TYPE can be one of the following symbols: vector, string or
-list."
- (pcase type
- (`vector (seq--into-vector sequence))
- (`string (seq--into-string sequence))
- (`list (seq--into-list sequence))
- (_ (error "Not a sequence type name: %S" type))))
-
-(cl-defgeneric seq-filter (pred sequence)
- "Return a list of all the elements for which (PRED element) is non-nil in
SEQUENCE."
- (let ((exclude (make-symbol "exclude")))
- (delq exclude (seq-map (lambda (elt)
- (if (funcall pred elt)
- elt
- exclude))
- sequence))))
-
-(cl-defgeneric seq-remove (pred sequence)
- "Return a list of all the elements for which (PRED element) is nil in
SEQUENCE."
- (seq-filter (lambda (elt) (not (funcall pred elt)))
- sequence))
-
-(cl-defgeneric seq-reduce (function sequence initial-value)
- "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE.
-
-Return the result of calling FUNCTION with INITIAL-VALUE and the
-first element of SEQUENCE, then calling FUNCTION with that result and
-the second element of SEQUENCE, then with that result and the third
-element of SEQUENCE, etc.
-
-If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
- (if (seq-empty-p sequence)
- initial-value
- (let ((acc initial-value))
- (seq-doseq (elt sequence)
- (setq acc (funcall function acc elt)))
- acc)))
-
-(cl-defgeneric seq-every-p (pred sequence)
- "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (or (funcall pred elt)
- (throw 'seq--break nil)))
- t))
-
-(cl-defgeneric seq-some (pred sequence)
- "Return non-nil if PRED is satisfied for at least one element of SEQUENCE.
-If so, return the first non-nil value returned by PRED."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (let ((result (funcall pred elt)))
- (when result
- (throw 'seq--break result))))
- nil))
-
-(cl-defgeneric seq-find (pred sequence &optional default)
- "Return the first element for which (PRED element) is non-nil in SEQUENCE.
-If no element is found, return DEFAULT.
-
-Note that `seq-find' has an ambiguity if the found element is
-identical to DEFAULT, as it cannot be known if an element was
-found or not."
- (catch 'seq--break
- (seq-doseq (elt sequence)
- (when (funcall pred elt)
- (throw 'seq--break elt)))
- default))
-
-(cl-defgeneric seq-count (pred sequence)
- "Return the number of elements for which (PRED element) is non-nil in
SEQUENCE."
- (let ((count 0))
- (seq-doseq (elt sequence)
- (when (funcall pred elt)
- (setq count (+ 1 count))))
- count))
-
-(cl-defgeneric seq-contains (sequence elt &optional testfn)
- (declare (obsolete seq-contains-p "27.1"))
- "Return the first element in SEQUENCE that is equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-some (lambda (e)
- (when (funcall (or testfn #'equal) elt e)
- e))
- sequence))
-
-(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
- "Return non-nil if SEQUENCE contains an element equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (catch 'seq--break
- (seq-doseq (e sequence)
- (when (funcall (or testfn #'equal) e elt)
- (throw 'seq--break t)))
- nil))
-
-(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn)
- "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements,
regardless of order.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn))
sequence1)
- (seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn))
sequence2)))
-
-(cl-defgeneric seq-position (sequence elt &optional testfn)
- "Return the index of the first element in SEQUENCE that is equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (let ((index 0))
- (catch 'seq--break
- (seq-doseq (e sequence)
- (when (funcall (or testfn #'equal) e elt)
- (throw 'seq--break index))
- (setq index (1+ index)))
- nil)))
-
-(cl-defgeneric seq-uniq (sequence &optional testfn)
- "Return a list of the elements of SEQUENCE with duplicates removed.
-TESTFN is used to compare elements, or `equal' if TESTFN is nil."
- (let ((result '()))
- (seq-doseq (elt sequence)
- (unless (seq-contains-p result elt testfn)
- (setq result (cons elt result))))
- (nreverse result)))
-
-(cl-defgeneric seq-mapcat (function sequence &optional type)
- "Concatenate the result of applying FUNCTION to each element of SEQUENCE.
-The result is a sequence of type TYPE, or a list if TYPE is nil."
- (apply #'seq-concatenate (or type 'list)
- (seq-map function sequence)))
-
-(cl-defgeneric seq-partition (sequence n)
- "Return a list of the elements of SEQUENCE grouped into sub-sequences of
length N.
-The last sequence may contain less than N elements. If N is a
-negative integer or 0, nil is returned."
- (unless (< n 1)
- (let ((result '()))
- (while (not (seq-empty-p sequence))
- (push (seq-take sequence n) result)
- (setq sequence (seq-drop sequence n)))
- (nreverse result))))
-
-(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
- "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-reduce (lambda (acc elt)
- (if (seq-contains-p sequence2 elt testfn)
- (cons elt acc)
- acc))
- (seq-reverse sequence1)
- '()))
-
-(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
- "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-reduce (lambda (acc elt)
- (if (seq-contains-p sequence2 elt testfn)
- acc
- (cons elt acc)))
- (seq-reverse sequence1)
- '()))
-
-(cl-defgeneric seq-group-by (function sequence)
- "Apply FUNCTION to each element of SEQUENCE.
-Separate the elements of SEQUENCE into an alist using the results as
-keys. Keys are compared using `equal'."
- (seq-reduce
- (lambda (acc elt)
- (let* ((key (funcall function elt))
- (cell (assoc key acc)))
- (if cell
- (setcdr cell (push elt (cdr cell)))
- (push (list key elt) acc))
- acc))
- (seq-reverse sequence)
- nil))
-
-(cl-defgeneric seq-min (sequence)
- "Return the smallest element of SEQUENCE.
-SEQUENCE must be a sequence of numbers or markers."
- (apply #'min (seq-into sequence 'list)))
-
-(cl-defgeneric seq-max (sequence)
- "Return the largest element of SEQUENCE.
-SEQUENCE must be a sequence of numbers or markers."
- (apply #'max (seq-into sequence 'list)))
-
-(defun seq--count-successive (pred sequence)
- "Return the number of successive elements for which (PRED element) is
non-nil in SEQUENCE."
- (let ((n 0)
- (len (seq-length sequence)))
- (while (and (< n len)
- (funcall pred (seq-elt sequence n)))
- (setq n (+ 1 n)))
- n))
-
-(defun seq--make-pcase-bindings (args)
- "Return a list of bindings of the variables in ARGS to the elements of a
sequence."
- (let ((bindings '())
- (index 0)
- (rest-marker nil))
- (seq-doseq (name args)
- (unless rest-marker
- (pcase name
- (`&rest
- (progn (push `(app (pcase--flip seq-drop ,index)
- ,(seq--elt-safe args (1+ index)))
- bindings)
- (setq rest-marker t)))
- (_
- (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings))))
- (setq index (1+ index)))
- bindings))
-
-(defun seq--make-pcase-patterns (args)
- "Return a list of `(seq ...)' pcase patterns from the argument list ARGS."
- (cons 'seq
- (seq-map (lambda (elt)
- (if (seqp elt)
- (seq--make-pcase-patterns elt)
- elt))
- args)))
-
-;; TODO: make public?
-(defun seq--elt-safe (sequence n)
- "Return element of SEQUENCE at the index N.
-If no element is found, return nil."
- (ignore-errors (seq-elt sequence n)))
-
-(cl-defgeneric seq-random-elt (sequence)
- "Return a random element from SEQUENCE.
-Signal an error if SEQUENCE is empty."
- (if (seq-empty-p sequence)
- (error "Sequence cannot be empty")
- (seq-elt sequence (random (seq-length sequence)))))
-
-
-;;; Optimized implementations for lists
-
-(cl-defmethod seq-drop ((list list) n)
- "Optimized implementation of `seq-drop' for lists."
- (nthcdr n list))
-
-(cl-defmethod seq-take ((list list) n)
- "Optimized implementation of `seq-take' for lists."
- (let ((result '()))
- (while (and list (> n 0))
- (setq n (1- n))
- (push (pop list) result))
- (nreverse result)))
-
-(cl-defmethod seq-drop-while (pred (list list))
- "Optimized implementation of `seq-drop-while' for lists."
- (while (and list (funcall pred (car list)))
- (setq list (cdr list)))
- list)
-
-(cl-defmethod seq-empty-p ((list list))
- "Optimized implementation of `seq-empty-p' for lists."
- (null list))
-
-
-(defun seq--into-list (sequence)
- "Concatenate the elements of SEQUENCE into a list."
- (if (listp sequence)
- sequence
- (append sequence nil)))
-
-(defun seq--into-vector (sequence)
- "Concatenate the elements of SEQUENCE into a vector."
- (if (vectorp sequence)
- sequence
- (vconcat sequence)))
-
-(defun seq--into-string (sequence)
- "Concatenate the elements of SEQUENCE into a string."
- (if (stringp sequence)
- sequence
- (concat sequence)))
-
-(defun seq--activate-font-lock-keywords ()
- "Activate font-lock keywords for some symbols defined in seq."
- (font-lock-add-keywords 'emacs-lisp-mode
- '("\\<seq-doseq\\>" "\\<seq-let\\>")))
-
-(unless (fboundp 'elisp--font-lock-flush-elisp-buffers)
- ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others)
- ;; we automatically highlight macros.
- (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords))
-
-) ; end seq--when-emacs-25-p
-
-(provide 'seq-25)
-;;; seq-25.el ends here
diff --git a/packages/seq/seq.el b/packages/seq/seq.el
deleted file mode 100644
index d02e25a..0000000
--- a/packages/seq/seq.el
+++ /dev/null
@@ -1,48 +0,0 @@
-;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Keywords: sequences
-;; Version: 2.22
-;; Package: seq
-
-;; Maintainer: emacs-devel@gnu.org
-
-;; This file is 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Sequence-manipulation functions that complement basic functions
-;; provided by subr.el.
-;;
-;; All functions are prefixed with "seq-".
-;;
-;; All provided functions work on lists, strings and vectors.
-;;
-;; Functions taking a predicate or iterating over a sequence using a
-;; function as argument take the function as their first argument and
-;; the sequence as their second argument. All other functions take
-;; the sequence as their first argument.
-
-;;; Code:
-
-(if (version< emacs-version "25")
- (require 'seq-24)
- (require 'seq-25))
-
-(provide 'seq)
-;;; seq.el ends here
diff --git a/packages/seq/tests/seq-tests.el b/packages/seq/tests/seq-tests.el
deleted file mode 100644
index d53fa36..0000000
--- a/packages/seq/tests/seq-tests.el
+++ /dev/null
@@ -1,382 +0,0 @@
-;;; seq-tests.el --- Tests for sequences.el
-
-;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Maintainer: emacs-devel@gnu.org
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Tests for seq.el
-
-;;; Code:
-
-(require 'ert)
-(require 'seq)
-
-(defmacro with-test-sequences (spec &rest body)
- "Successively bind VAR to a list, vector, and string built from SEQ.
-Evaluate BODY for each created sequence.
-
-\(fn (var seq) body)"
- (declare (indent 1) (debug ((symbolp form) body)))
- (let ((initial-seq (make-symbol "initial-seq")))
- `(let ((,initial-seq ,(cadr spec)))
- ,@(mapcar (lambda (s)
- `(let ((,(car spec) (apply (function ,s) ,initial-seq)))
- ,@body))
- '(list vector string)))))
-
-(defun same-contents-p (seq1 seq2)
- "Return t if SEQ1 and SEQ2 have the same contents, nil otherwise."
- (equal (append seq1 '()) (append seq2 '())))
-
-(defun test-sequences-evenp (integer)
- "Return t if INTEGER is even."
- (eq (logand integer 1) 0))
-
-(defun test-sequences-oddp (integer)
- "Return t if INTEGER is odd."
- (not (test-sequences-evenp integer)))
-
-(ert-deftest test-seq-drop ()
- (with-test-sequences (seq '(1 2 3 4))
- (should (equal (seq-drop seq 0) seq))
- (should (equal (seq-drop seq 1) (seq-subseq seq 1)))
- (should (equal (seq-drop seq 2) (seq-subseq seq 2)))
- (should (seq-empty-p (seq-drop seq 4)))
- (should (seq-empty-p (seq-drop seq 10))))
- (with-test-sequences (seq '())
- (should (seq-empty-p (seq-drop seq 0)))
- (should (seq-empty-p (seq-drop seq 1)))))
-
-(ert-deftest test-seq-take ()
- (with-test-sequences (seq '(2 3 4 5))
- (should (seq-empty-p (seq-take seq 0)))
- (should (= (seq-length (seq-take seq 1)) 1))
- (should (= (seq-elt (seq-take seq 1) 0) 2))
- (should (same-contents-p (seq-take seq 3) '(2 3 4)))
- (should (equal (seq-take seq 10) seq))))
-
-(ert-deftest test-seq-drop-while ()
- (with-test-sequences (seq '(1 3 2 4))
- (should (equal (seq-drop-while #'test-sequences-oddp seq)
- (seq-drop seq 2)))
- (should (equal (seq-drop-while #'test-sequences-evenp seq)
- seq))
- (should (seq-empty-p (seq-drop-while #'numberp seq))))
- (with-test-sequences (seq '())
- (should (seq-empty-p (seq-drop-while #'test-sequences-oddp seq)))))
-
-(ert-deftest test-seq-take-while ()
- (with-test-sequences (seq '(1 3 2 4))
- (should (equal (seq-take-while #'test-sequences-oddp seq)
- (seq-take seq 2)))
- (should (seq-empty-p (seq-take-while #'test-sequences-evenp seq)))
- (should (equal (seq-take-while #'numberp seq) seq)))
- (with-test-sequences (seq '())
- (should (seq-empty-p (seq-take-while #'test-sequences-oddp seq)))))
-
-(ert-deftest test-seq-map-indexed ()
- (should (equal (seq-map-indexed (lambda (elt i)
- (list elt i))
- nil)
- nil))
- (should (equal (seq-map-indexed (lambda (elt i)
- (list elt i))
- '(a b c d))
- '((a 0) (b 1) (c 2) (d 3)))))
-
-(ert-deftest test-seq-filter ()
- (with-test-sequences (seq '(6 7 8 9 10))
- (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10)))
- (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9)))
- (should (equal (seq-filter (lambda (elt) nil) seq) '())))
- (with-test-sequences (seq '())
- (should (equal (seq-filter #'test-sequences-evenp seq) '()))))
-
-(ert-deftest test-seq-remove ()
- (with-test-sequences (seq '(6 7 8 9 10))
- (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9)))
- (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10)))
- (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq)))
- (with-test-sequences (seq '())
- (should (equal (seq-remove #'test-sequences-evenp seq) '()))))
-
-(ert-deftest test-seq-count ()
- (with-test-sequences (seq '(6 7 8 9 10))
- (should (equal (seq-count #'test-sequences-evenp seq) 3))
- (should (equal (seq-count #'test-sequences-oddp seq) 2))
- (should (equal (seq-count (lambda (elt) nil) seq) 0)))
- (with-test-sequences (seq '())
- (should (equal (seq-count #'test-sequences-evenp seq) 0))))
-
-(ert-deftest test-seq-reduce ()
- (with-test-sequences (seq '(1 2 3 4))
- (should (= (seq-reduce #'+ seq 0) 10))
- (should (= (seq-reduce #'+ seq 5) 15)))
- (with-test-sequences (seq '())
- (should (eq (seq-reduce #'+ seq 0) 0))
- (should (eq (seq-reduce #'+ seq 7) 7))))
-
-(ert-deftest test-seq-some ()
- (with-test-sequences (seq '(4 3 2 1))
- (should (seq-some #'test-sequences-evenp seq))
- (should (seq-some #'test-sequences-oddp seq))
- (should-not (seq-some (lambda (elt) (> elt 10)) seq)))
- (with-test-sequences (seq '())
- (should-not (seq-some #'test-sequences-oddp seq)))
- (should (seq-some #'null '(1 nil 2))))
-
-(ert-deftest test-seq-find ()
- (with-test-sequences (seq '(4 3 2 1))
- (should (= 4 (seq-find #'test-sequences-evenp seq)))
- (should (= 3 (seq-find #'test-sequences-oddp seq)))
- (should-not (seq-find (lambda (elt) (> elt 10)) seq)))
- (should-not (seq-find #'null '(1 nil 2)))
- (should-not (seq-find #'null '(1 nil 2) t))
- (should-not (seq-find #'null '(1 2 3)))
- (should (seq-find #'null '(1 2 3) 'sentinel)))
-
-(ert-deftest test-seq-contains ()
- (with-test-sequences (seq '(3 4 5 6))
- (should (seq-contains seq 3))
- (should-not (seq-contains seq 7)))
- (with-test-sequences (seq '())
- (should-not (seq-contains seq 3))
- (should-not (seq-contains seq nil))))
-
-(ert-deftest test-seq-every-p ()
- (with-test-sequences (seq '(43 54 22 1))
- (should (seq-every-p (lambda (elt) t) seq))
- (should-not (seq-every-p #'test-sequences-oddp seq))
- (should-not (seq-every-p #'test-sequences-evenp seq)))
- (with-test-sequences (seq '(42 54 22 2))
- (should (seq-every-p #'test-sequences-evenp seq))
- (should-not (seq-every-p #'test-sequences-oddp seq)))
- (with-test-sequences (seq '())
- (should (seq-every-p #'identity seq))
- (should (seq-every-p #'test-sequences-evenp seq))))
-
-(ert-deftest test-seq-empty-p ()
- (with-test-sequences (seq '(0))
- (should-not (seq-empty-p seq)))
- (with-test-sequences (seq '(0 1 2))
- (should-not (seq-empty-p seq)))
- (with-test-sequences (seq '())
- (should (seq-empty-p seq))))
-
-(ert-deftest test-seq-sort ()
- (should (equal (seq-sort #'< "cbaf") "abcf"))
- (should (equal (seq-sort #'< '(2 1 9 4)) '(1 2 4 9)))
- (should (equal (seq-sort #'< [2 1 9 4]) [1 2 4 9]))
- (should (equal (seq-sort #'< "") "")))
-
-(ert-deftest test-seq-uniq ()
- (with-test-sequences (seq '(2 4 6 8 6 4 3))
- (should (equal (seq-uniq seq) '(2 4 6 8 3))))
- (with-test-sequences (seq '(3 3 3 3 3))
- (should (equal (seq-uniq seq) '(3))))
- (with-test-sequences (seq '())
- (should (equal (seq-uniq seq) '()))))
-
-(ert-deftest test-seq-subseq ()
- (with-test-sequences (seq '(2 3 4 5))
- (should (equal (seq-subseq seq 0 4) seq))
- (should (same-contents-p (seq-subseq seq 2 4) '(4 5)))
- (should (same-contents-p (seq-subseq seq 1 3) '(3 4)))
- (should (same-contents-p (seq-subseq seq 1 -1) '(3 4))))
- (should (vectorp (seq-subseq [2 3 4 5] 2)))
- (should (stringp (seq-subseq "foo" 2 3)))
- (should (listp (seq-subseq '(2 3 4 4) 2 3)))
- (should-error (seq-subseq '(1 2 3) 4))
- (should-not (seq-subseq '(1 2 3) 3))
- (should (seq-subseq '(1 2 3) -3))
- (should-error (seq-subseq '(1 2 3) 1 4))
- (should (seq-subseq '(1 2 3) 1 3)))
-
-(ert-deftest test-seq-concatenate ()
- (with-test-sequences (seq '(2 4 6))
- (should (equal (seq-concatenate 'string seq [8]) (string 2 4 6 8)))
- (should (equal (seq-concatenate 'list seq '(8 10)) '(2 4 6 8 10)))
- (should (equal (seq-concatenate 'vector seq '(8 10)) [2 4 6 8 10]))
- (should (equal (seq-concatenate 'vector nil '(8 10)) [8 10]))
- (should (equal (seq-concatenate 'vector seq nil) [2 4 6]))))
-
-(ert-deftest test-seq-mapcat ()
- (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)))
- '(1 2 3 4 5 6)))
- (should (equal (seq-mapcat #'seq-reverse '[(3 2 1) (6 5 4)])
- '(1 2 3 4 5 6)))
- (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)) 'vector)
- '[1 2 3 4 5 6])))
-
-(ert-deftest test-seq-partition ()
- (should (same-contents-p (seq-partition '(0 1 2 3 4 5 6 7) 3)
- '((0 1 2) (3 4 5) (6 7))))
- (should (same-contents-p (seq-partition '[0 1 2 3 4 5 6 7] 3)
- '([0 1 2] [3 4 5] [6 7])))
- (should (same-contents-p (seq-partition "Hello world" 2)
- '("He" "ll" "o " "wo" "rl" "d")))
- (should (equal (seq-partition '() 2) '()))
- (should (equal (seq-partition '(1 2 3) -1) '())))
-
-(ert-deftest test-seq-group-by ()
- (with-test-sequences (seq '(1 2 3 4))
- (should (equal (seq-group-by #'test-sequences-oddp seq)
- '((t 1 3) (nil 2 4)))))
- (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2)))
- '((b (b 3)) (c (c 4)) (a (a 1) (a 2))))))
-
-(ert-deftest test-seq-reverse ()
- (with-test-sequences (seq '(1 2 3 4))
- (should (same-contents-p (seq-reverse seq) '(4 3 2 1)))
- (should (equal (type-of (seq-reverse seq))
- (type-of seq)))))
-
-(ert-deftest test-seq-into ()
- (let* ((vector [1 2 3])
- (list (seq-into vector 'list)))
- (should (same-contents-p vector list))
- (should (listp list)))
- (let* ((list '(hello world))
- (vector (seq-into list 'vector)))
- (should (same-contents-p vector list))
- (should (vectorp vector)))
- (let* ((string "hello")
- (list (seq-into string 'list)))
- (should (same-contents-p string list))
- (should (stringp string)))
- (let* ((string "hello")
- (vector (seq-into string 'vector)))
- (should (same-contents-p string vector))
- (should (stringp string)))
- (let* ((list nil)
- (vector (seq-into list 'vector)))
- (should (same-contents-p list vector))
- (should (vectorp vector))))
-
-(ert-deftest test-seq-intersection ()
- (let ((v1 [2 3 4 5])
- (v2 [1 3 5 6 7]))
- (should (same-contents-p (seq-intersection v1 v2)
- '(3 5))))
- (let ((l1 '(2 3 4 5))
- (l2 '(1 3 5 6 7)))
- (should (same-contents-p (seq-intersection l1 l2)
- '(3 5))))
- (let ((v1 [2 4 6])
- (v2 [1 3 5]))
- (should (seq-empty-p (seq-intersection v1 v2)))))
-
-(ert-deftest test-seq-difference ()
- (let ((v1 [2 3 4 5])
- (v2 [1 3 5 6 7]))
- (should (same-contents-p (seq-difference v1 v2)
- '(2 4))))
- (let ((l1 '(2 3 4 5))
- (l2 '(1 3 5 6 7)))
- (should (same-contents-p (seq-difference l1 l2)
- '(2 4))))
- (let ((v1 [2 4 6])
- (v2 [2 4 6]))
- (should (seq-empty-p (seq-difference v1 v2)))))
-
-(ert-deftest test-seq-let ()
- (with-test-sequences (seq '(1 2 3 4))
- (seq-let (a b c d e) seq
- (should (= a 1))
- (should (= b 2))
- (should (= c 3))
- (should (= d 4))
- (should (null e)))
- (seq-let (a b &rest others) seq
- (should (= a 1))
- (should (= b 2))
- (should (same-contents-p others (seq-drop seq 2)))))
- (let ((seq '(1 (2 (3 (4))))))
- (seq-let (_ (_ (_ (a)))) seq
- (should (= a 4))))
- (let (seq)
- (seq-let (a b c) seq
- (should (null a))
- (should (null b))
- (should (null c)))))
-
-(ert-deftest test-seq-min-max ()
- (with-test-sequences (seq '(4 5 3 2 0 4))
- (should (= (seq-min seq) 0))
- (should (= (seq-max seq) 5))))
-
-(ert-deftest test-seq-position ()
- (with-test-sequences (seq '(2 4 6))
- (should (null (seq-position seq 1)))
- (should (= (seq-position seq 4) 1)))
- (let ((seq '(a b c)))
- (should (null (seq-position seq 'd #'eq)))
- (should (= (seq-position seq 'a #'eq) 0))
- (should (null (seq-position seq (make-symbol "a") #'eq)))))
-
-(ert-deftest test-seq-mapn ()
- (should-error (seq-mapn #'identity))
- (with-test-sequences (seq '(1 2 3 4 5 6 7))
- (should (equal (append seq nil)
- (seq-mapn #'identity seq)))
- (should (equal (seq-mapn #'1+ seq)
- (seq-map #'1+ seq)))
-
- (with-test-sequences (seq-2 '(10 20 30 40 50))
- (should (equal (seq-mapn #'+ seq seq-2)
- '(11 22 33 44 55)))
- (should (equal (seq-mapn #'+ seq seq-2 nil) nil)))))
-
-(ert-deftest test-seq-sort-by ()
- (let ((seq ["x" "xx" "xxx"]))
- (should (equal (seq-sort-by #'seq-length #'> seq)
- ["xxx" "xx" "x"]))))
-
-(ert-deftest test-seq-random-elt-take-all ()
- (let ((seq '(a b c d e))
- (elts '()))
- (should (= 0 (length elts)))
- (dotimes (_ 1000)
- (let ((random-elt (seq-random-elt seq)))
- (add-to-list 'elts
- random-elt)))
- (should (= 5 (length elts)))))
-
-(ert-deftest test-seq-random-elt-signal-on-empty ()
- (should-error (seq-random-elt nil))
- (should-error (seq-random-elt []))
- (should-error (seq-random-elt "")))
-
-(ert-deftest test-seq-mapn-circular-lists ()
- (let ((l1 '#1=(1 . #1#)))
- (should (equal (seq-mapn #'+ '(3 4 5 7) l1)
- '(4 5 6 8)))))
-
-(ert-deftest test-seq-into-and-identity ()
- (let ((lst '(1 2 3))
- (vec [1 2 3])
- (str "foo bar"))
- (should (eq (seq-into lst 'list) lst))
- (should (eq (seq-into vec 'vector) vec))
- (should (eq (seq-into str 'string) str))))
-
-(provide 'seq-tests)
-;;; seq-tests.el ends here
diff --git a/packages/shelisp/shelisp.el b/packages/shelisp/shelisp.el
deleted file mode 100644
index d470e5c..0000000
--- a/packages/shelisp/shelisp.el
+++ /dev/null
@@ -1,218 +0,0 @@
-;;; shelisp.el --- execute elisp in shell -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2018-2019 Free Software Foundation, Inc.
-
-;; Author: Michael R. Mauger <michael@mauger.com>
-;; Version: 0.9.1
-;; Package-Type: simple
-;; Keywords: terminals, lisp, processes
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Comint process (likely shell-mode) can write out Emacs Lisp
-;; expressions and have them executed.
-
-;; When the shell process writes out a string of the form:
-;; \e_#EMACS# elisp-expr \a
-;;
-;; Where, "elisp-expr" is a valid elisp expression. The elisp
-;; expression is executed as if you had invoked the function
-;; within Emacs itself. The elisp expression may include a call to
-;; the function `f' which will expand the filename parameter into an
-;; appropriate filename for Emacs using the appropriate Tramp prefix
-;; if necessary.
-
-;; This script also defines an Alist variable that creates shell
-;; commands and the `printf'-style format to generate the full elisp
-;; expression with command parameters substituted into the command. A
-;; function is placed in the `shell-mode-hook' to actually create the
-;; shell functions and aliases to format the elisp expressions and
-;; embed them in an escape sequence so that they are detected and
-;; executed.
-
-;; In most usage this mode merely allows you to type "e filename"
-;; rather than "C-x C-f filename" which isn't much of a savings.
-;; However, with this mode enabled, you can write shell scripts to
-;; invoke Emacs Lisp functions. But beware, the shell script will not
-;; wait for completion of the elisp expression, nor return anything
-;; back (see ToDo's below).
-
-;; INSTALLATION
-
-;; After installing this package from ELPA, you must add the following
-;; to your Emacs initialization script:
-
-;; (add-hook 'shell-mode-hook #'shelisp-mode)
-
-;; TO DOs:
-
-;; * Provide a security feature that prompts the Emacs user to approve
-;; * the execution of any elisp expressions submitted thru the shelisp
-;; * escape sequence.
-
-;; * Support `term-mode' like `shell-mode'
-
-;; * Provide support for creation of shell commands for command shells
-;; other than bash -- csh, tcsh, zsh, ksh, ash, dash, fish, mosh, sh.
-;;
-;; Support for non-Linux shells is left as an exercise for a
-;; masochistic hacker.
-
-;; * Implement a wait for completion facility similar to `emacsclient'
-;; or the work done in `with-editor' with the "sleeping editor."
-;; That is, pause the shell activity with a long sleep, until C-c
-;; C-c or C-c C-k is typed in Emacs and the caller is awoken with a
-;; signal.
-
-;; KNOWN BUGS
-
-;; The simplistic implementation of the shell functions will not
-;; properly handle filenames containing double quote characters (\")
-;; nor backslashes (\\). While this is an error, it does not
-;; represent a significant limitation in the implementation. The
-;; caller can properly add backslashes to the filename string before
-;; passing it to printf to generate the elisp expression. In the end,
-;; the purpose is to create a valid elisp expression string.
-
-;;; Code:
-(require 'cl-lib)
-(require 'pp)
-
-;;;###autoload
-(define-minor-mode shelisp-mode
- "Enable elisp expressions embedded in ANSI APC (Application
-Program Control) escape sequences to be located and executed
-while in a shell mode buffer."
- nil " ShElisp" nil
-
- (if (not shelisp-mode)
- (remove-hook 'comint-preoutput-filter-functions
- #'shelisp-exec-lisp)
- ;; Parse elisp escape sequences
- (add-hook 'comint-preoutput-filter-functions
- #'shelisp-exec-lisp 'append)
- (shelisp-add-commands)))
-
-;;;###autoload
-(defvar shelisp-debug nil
- "When non-nil, display messages showing the elisp expression.")
-
-(defun shelisp--file-name (file)
- "Apply remote host in `default-directory' to FILE."
- (if (and (file-name-absolute-p file)
- (not (file-remote-p file)))
- (concat (file-remote-p default-directory) file)
- file))
-
-(defun shelisp--result-as-string (result)
- "Return RESULT as a string.
-If it already is a string, then just return it. Otherwise,
-convert it to a string."
- (cond ((null result) "")
- ((stringp result) result)
- (:else (pp-to-string result))))
-
-(defun shelisp-exec-lisp (&optional str)
- "Detect escape sequence in STR to execute Emacs Lisp."
- (interactive)
-
- (when (and shelisp-mode str)
- (let* ((APC "\\(?:\e_\\|\x9f\\)")
- (tag "#EMACS#")
- (ST "\\(?:[\a\x9c]\\|[\e][\\\\]\\)")
- (cmd-re "\\(?:[^\a\x9c\e]\\|\e[^\\\\]\\)")
- (apc-re (concat APC tag "\\(" cmd-re "*\\)" ST))
- (case-fold-search nil)
- cmd rep)
-
- ;; Look for APC escape sequences
- (while (string-match apc-re str)
- (setq cmd (match-string 1 str)
- rep "")
- ;; Trace, if requested
- (when shelisp-debug
- (message "shelisp> `%s'" cmd))
-
- ;; Replace the elisp expresssion with it's value
- ;; if the value is nil, treat it as an empty string
- (setq rep (save-match-data
- (save-excursion
- (condition-case err
- (shelisp--result-as-string
- (eval `(cl-flet ((f (file) (shelisp--file-name
file)))
- ,(read cmd))
- t))
- ;; When an error occurs, replace with the error message
- (error
- (format "shelisp: `%s': %S" cmd err)))))
- str (replace-match
- (concat rep (unless (string-equal "" rep) "\n"))
- t t str)))))
- str)
-
-
-;;;###autoload
-(defvar shelisp-commands (let ((cmds '(("e" . "(find-file-other-window (f
\"%s\"))")
- ("v" . "(view-file-other-window (f
\"%s\"))")
- ("dired" . "(dired \"%s\")")
- ("ediff" . "(ediff (f \"%s\") (f
\"%s\"))"))))
- (when (locate-library "magit")
- (push '("magit" . "(magit-status)") cmds))
- (when (or (bound-and-true-p viper-mode)
- (bound-and-true-p evil-mode))
- (push '("vim" . "(find-file-other-window (f
\"%s\"))") cmds)
- (push '("vi" . "(find-file-other-window (f
\"%s\"))") cmds))
- cmds)
-
- "Alist of shell commands and corresponding Lisp expressions.
-Each entry in the alist consists of the shell alias to be set as the
-command, and the `printf' style string to generate the elisp
-expression to be executed.
-
-If a parameter to the elisp expression is a filename, then we
-need to be sure that proper filename parsing in context occurs.
-We do this by passing filename parameters through the elisp
-function `f'[1]. This function makes sure that filename has
-proper Tramp prefixes if the shell session is remote. So, rather
-than just embedding the filename in the elisp expression, using
-printf, with \"\\\"%s\\\"\", you use \\=`(f \\\"%s\\\")\\='.
-
-[1] The `f' function is `cl-flet' bound for the shelisp
-expression and cannot be used elsewhere.")
-
-(defun shelisp-add-commands ()
- "Add Emacs Lisp to shell aliases (assumes GNU bash syntax)."
-
- (when (and shelisp-mode shelisp-commands)
- (let ((proc (get-buffer-process (current-buffer))))
- (dolist (c shelisp-commands)
- (let ((cmd (car c))
- (expr (cdr c)))
- (process-send-string
- proc
- (apply #'format
- (mapconcat #'identity
- '("unset -f shelisp_%s"
- "function shelisp_%s { printf '\\e_#EMACS# %s
\\a' \"$@\"; }"
- "alias %s=shelisp_%s" "")
- " ; ")
- (list cmd cmd
- (replace-regexp-in-string "\"" "\\\\\"" expr)
- cmd cmd)))))
- (process-send-string proc "\n"))))
-
-(provide 'shelisp)
-;;; shelisp.el ends here
diff --git a/packages/shell-quasiquote/shell-quasiquote.el
b/packages/shell-quasiquote/shell-quasiquote.el
deleted file mode 100644
index a0bf7c8..0000000
--- a/packages/shell-quasiquote/shell-quasiquote.el
+++ /dev/null
@@ -1,123 +0,0 @@
-;;; shell-quasiquote.el --- Turn s-expressions into shell command strings.
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-;; Keywords: extensions, unix
-;; Version: 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; "Shell quasiquote" -- turn s-expressions into POSIX shell command strings.
-;;
-;; Shells other than POSIX sh are not supported.
-;;
-;; Quoting is automatic and safe against injection.
-;;
-;; (let ((file1 "file one")
-;; (file2 "file two"))
-;; (shqq (cp -r ,file1 ,file2 "My Files")))
-;; => "cp -r 'file one' 'file two' 'My Files'"
-;;
-;; You can splice many arguments into place with ,@foo.
-;;
-;; (let ((files (list "file one" "file two")))
-;; (shqq (cp -r ,@files "My Files")))
-;; => "cp -r 'file one' 'file two' 'My Files'"
-;;
-;; Note that the quoting disables a variety of shell expansions like ~/foo,
-;; $ENV_VAR, and e.g. {x..y} in GNU Bash.
-;;
-;; You can use ,,foo to escape the quoting.
-;;
-;; (let ((files "file1 file2"))
-;; (shqq (cp -r ,,files "My Files")))
-;; => "cp -r file1 file2 'My Files'"
-;;
-;; And ,,@foo to splice and escape quoting.
-;;
-;; (let* ((arglist '("-x 'foo bar' -y baz"))
-;; (arglist (append arglist '("-z 'qux fux'"))))
-;; (shqq (command ,,@arglist)))
-;; => "command -x 'foo bar' -y baz -z 'qux fux'"
-;;
-;; Neat, eh?
-
-
-;;; Code:
-
-(defun shqq--atom-to-string (atom)
- (cond
- ((symbolp atom) (symbol-name atom))
- ((stringp atom) atom)
- ((numberp atom) (number-to-string atom))
- (t (error "Bad shqq atom: %S" atom))))
-
-(defun shqq--quote-atom (atom)
- (shell-quote-argument (shqq--atom-to-string atom)))
-
-(defmacro shqq (parts)
- "First, PARTS is turned into a list of strings. For this,
-every element of PARTS must be one of:
-
-- a symbol, evaluating to its name,
-
-- a string, evaluating to itself,
-
-- a number, evaluating to its decimal representation,
-
-- \",expr\", where EXPR must evaluate to an atom that will be
- interpreted according to the previous rules,
-
-- \",@list-expr\", where LIST-EXPR must evaluate to a list whose
- elements will each be interpreted like the EXPR in an \",EXPR\"
- form, and spliced into the list of strings,
-
-- \",,expr\", where EXPR is interpreted like in \",expr\",
-
-- or \",,@expr\", where EXPR is interpreted like in \",@expr\".
-
-In the resulting list of strings, all elements except the ones
-resulting from \",,expr\" and \",,@expr\" forms are quoted for
-shell grammar.
-
-Finally, the resulting list of strings is concatenated with
-separating spaces."
- (let ((parts
- (mapcar
- (lambda (part)
- (cond
- ((atom part) (shqq--quote-atom part))
- ;; We use the match-comma helpers because pcase can't match ,foo.
- (t (pcase part
- ;; ,,foo i.e. (, (, foo))
- (`(,`\, (,`\, ,form)) form)
- ;; ,,@foo i.e. (, (,@ foo))
- (`(,`\, (,`\,@ ,form)) `(mapconcat #'identity ,form " "))
- ;; ,foo
- (`(,`\, ,form) `(shqq--quote-atom ,form))
- ;; ,@foo
- (`,@,form `(mapconcat #'shqq--quote-atom ,form " "))
- (_
- (error "Bad shqq part: %S" part))))))
- parts)))
- `(mapconcat #'identity (list ,@parts) " ")))
-
-(provide 'shell-quasiquote)
-;; Local Variables:
-;; coding: utf-8
-;; End:
-;;; shell-quasiquote.el ends here
diff --git a/packages/smart-yank/smart-yank.el
b/packages/smart-yank/smart-yank.el
deleted file mode 100644
index 699c0e7..0000000
--- a/packages/smart-yank/smart-yank.el
+++ /dev/null
@@ -1,192 +0,0 @@
-;;; smart-yank.el --- A different approach of yank pointer handling -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2016-2020 Free Software Foundation, Inc
-
-;; Author: Michael Heerdegen <michael_heerdegen@web.de>
-;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
-;; Created: 14 May 2016
-;; Keywords: convenience
-;; Compatibility: GNU Emacs 24
-;; Version: 0.1.1
-;; Package-Requires: ((emacs "24"))
-
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-;;
-;; Introduction
-;; ============
-;;
-;; This library implements the global minor mode `smart-yank-mode'
-;; that changes the way Emacs handles the `kill-ring-yank-pointer' in
-;; a way that some people prefer over the default behavior.
-;;
-;; Normally, only a kill command resets the yank pointer. With
-;; `smart-yank-mode' enabled, any command except yank commands resets
-;; it.
-;;
-;; In addition, when yanking any "older" element from the kill-ring
-;; with yank-pop (and not replacing it with a subsequent yank-pop), it
-;; is automatically moved to the "first position" so `yank' invoked
-;; later will yank this element again.
-;;
-;; Finally, `yank-pop' (normally bound to M-y) is replaced with
-;; `smart-yank-yank-pop' that is a bit more sophisticated:
-;;
-;; - When _not_ called after a `yank', instead of raising an error
-;; like `yank-pop', yank the next-to-the-last kill.
-;;
-;; - Hit M-y twice in fast succession (delay < 0.2 secs by default)
-;; when you got lost. This will remove the yanked text. If you
-;; bind a command to `smart-yank-browse-kill-ring-command', this
-;; command will be called too (typically something like
-;; `browse-kill-ring').
-;;
-;;
-;; Example: you want to manually replace some words in some buffer
-;; with a new word "foo". With `smart-yank-mode' enabled, you can do
-;; it like this:
-;;
-;; 1. Put "foo" into the kill ring.
-;; 2. Move to the next word to be replaced.
-;; 3. M-d M-y
-;; 4. Back to 2, iterate.
-;;
-;;
-;; Setup
-;; =====
-;;
-;; Just enable `smart-yank-mode' and you are done.
-
-
-
-;;; Code:
-
-;;;; Configuration stuff
-
-(defgroup smart-yank nil
- "A different approach of yank pointer handling."
- :group 'killing)
-
-(defcustom smart-yank-yank-pop-multikey-delay .2
- "Max delay between two \\[smart-yank-yank-pop] invocations revealing special
behavior.
-See `smart-yank-yank-pop' for details."
- :type 'number)
-
-(defcustom smart-yank-browse-kill-ring-command nil
- "Command to invoke when hitting \\[smart-yank-yank-pop] twice (fast)."
- :type '(choice (const :tag "None" nil)
- (const browse-kill-ring)
- (const helm-show-kill-ring)
- (function :tag "Other Function")))
-
-(defvar smart-yank-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [remap yank-pop] #'smart-yank-yank-pop)
- map)
- "Map used by `smart-yank-mode'.")
-
-
-;;;; Internals
-
-(defun smart-yank--stopwatch ()
- "Return a fresh stopwatch.
-This is a function accepting zero arguments that upon each call
-will return the time difference from its last call in seconds.
-When called the first time it will return nil."
- (let ((last-invocation nil))
- (lambda ()
- (prog1 (and last-invocation
- (time-to-seconds (time-subtract (current-time)
last-invocation)))
- (setq last-invocation (current-time))))))
-
-(defun smart-yank-reset-yank-pointer ()
- (unless (eq last-command #'yank)
- (setq kill-ring-yank-pointer kill-ring)))
-
-(defun smart-yank--before-ad (&rest _args)
- "Before advice function for `yank'.
-
-Reset `kill-ring-yank-pointer'. For yank-pop, move the really
-yanked text \"to the beginning\" of the kill ring."
- (unless (eq kill-ring kill-ring-yank-pointer)
- (let ((last-yank (car kill-ring-yank-pointer)))
- (when last-yank
- (setq kill-ring (cons last-yank (delete last-yank kill-ring)))
- (smart-yank-reset-yank-pointer)))))
-
-(defalias 'smart-yank-yank-pop
- (let ((r (smart-yank--stopwatch)))
- (lambda (&optional arg)
- "\"smart-yank\"'s private version of `yank-pop'.
-
-When called directly after a `yank' command (including itself),
-call `yank-pop'.
-
-If its key was hit two times in fast succession - i.e. with a
-delay less than `smart-yank-yank-pop-multikey-delay' - delete any
-yanked text; in addition call
-`smart-yank-browse-kill-ring-command' when set.
-
-When not called after a yank, yank the next-to-the-last
-`kill-ring' entry; with prefix arg, call the
-`smart-yank-browse-kill-ring-command'."
- (interactive "P")
- (let ((diff (funcall r)))
- (cond
- ((not (eq last-command 'yank)) (if arg (call-interactively
smart-yank-browse-kill-ring-command)
- (rotate-yank-pointer 1)
- (yank)))
- ((or (not diff)
- (> diff smart-yank-yank-pop-multikey-delay))
- (call-interactively #'yank-pop))
- (t (funcall (or yank-undo-function
#'delete-region)
- (region-beginning)
(region-end))
- (when
smart-yank-browse-kill-ring-command
- (call-interactively
smart-yank-browse-kill-ring-command))))))))
-
-(declare-function smart-yank-yank-pop 'smart-yank)
-
-
-;;;; User stuff
-
-;;;###autoload
-(define-minor-mode smart-yank-mode
- "Alter the behavior of yank commands in several ways.
-
-Turning on this mode has the following effects:
-
- - Makes any command except yank commands reset the
- `kill-ring-yank-pointer', instead of only killing commands.
-
- - Remaps `yank-pop' to `smart-yank-yank-pop'.
-
- - When yanking an older element from the `kill-ring' with
- \\[smart-yank-yank-pop] (and not replacing it with a subsequent
\\[smart-yank-yank-pop]), the
- element is automatically \"moved to the first position\" of
- the `kill-ring' so that `yank' invoked later will again yank
- this element."
- :global t
- (if smart-yank-mode
- (advice-add 'yank :before #'smart-yank--before-ad)
- (advice-remove 'yank #'smart-yank--before-ad)))
-
-
-(provide 'smart-yank)
-
-;;; smart-yank.el ends here
diff --git a/packages/sokoban/sokoban.el b/packages/sokoban/sokoban.el
deleted file mode 100644
index 128d59a..0000000
--- a/packages/sokoban/sokoban.el
+++ /dev/null
@@ -1,983 +0,0 @@
-;;; sokoban.el --- Implementation of Sokoban for Emacs. -*- lexical-binding: t
-*-
-
-;; Copyright (C) 1998, 2013, 2017, 2019 Free Software Foundation, Inc.
-
-;; Author: Glynn Clements <glynn.clements@xemacs.org>
-;; Maintainer: Dieter Deyke <dieter.deyke@gmail.com>
-;; Version: 1.4.8
-;; Comment: While we set lexical-binding, it currently doesn't make use
-;; of closures, which is why it can still work in Emacs-23.1.
-;; Package-Requires: ((emacs "23.1") (cl-lib "0.5"))
-;; Created: 1997-09-11
-;; Keywords: games
-;; Package-Type: multi
-
-;; This file is part of XEmacs.
-
-;; XEmacs 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.
-
-;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free
-;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-;; 02111-1307, USA.
-
-;;; Synched up with: Not synched.
-
-;;; Commentary:
-
-;; Modified: 1998-01-09, conditionalised use of locate-data-directory
-;; Modified: 1998-01-27, added mouse interface code
-;; (provided by Sean MacLennan <bn932@freenet.carleton.ca>
-;; Modified: 1998-02-06, fixed bug, where sokoban-done wasn't reset to
-;; zero in sokoban-restart-level
-;; Modified: 1998-02-27, patches from Hrvoje Niksic
-;; added bounds check to sokoban-goto-level
-;; added popup menu
-;; display level and score in modeline
-;; Modified: 1998-06-04, added `undo' feature
-;; added number of blocks done/total to score and modeline
-;; Modified: 2003-06-14, update email address, remove URL
-
-;; The game is based upon XSokoban, by
-;; Michael Bischoff <mbi@mo.math.nat.tu-bs.de>
-
-;; The levels and some of the pixmaps were
-;; taken directly from XSokoban
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-
-(require 'gamegrid)
-(require 'xml)
-
-;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar sokoban-use-glyphs t
- "Non-nil means use glyphs when available.")
-
-(defvar sokoban-use-color t
- "Non-nil means use color when available.")
-
-(defvar sokoban-font "-*-courier-medium-r-*-*-*-200-100-75-*-*-iso8859-*"
- "Name of the font used in X mode.")
-
-(defvar sokoban-buffer-name "*Sokoban*")
-
-(defvar sokoban-level-file
- (if (fboundp 'locate-data-file)
- (locate-data-file "sokoban.levels")
- (or (locate-library "sokoban.levels")
- (let ((file (expand-file-name
- "sokoban.levels"
- (if load-file-name
- (file-name-directory load-file-name)))))
- (and (file-exists-p file) file))
- (expand-file-name "sokoban.levels" data-directory))))
-
-(defvar sokoban-width)
-(defvar sokoban-height)
-
-(defvar sokoban-buffer-width)
-(defvar sokoban-buffer-height)
-
-(defvar sokoban-score-x)
-(defvar sokoban-score-y)
-
-(defvar sokoban-level-data nil)
-
-(defconst sokoban-state-filename (locate-user-emacs-file "sokoban-state"))
-
-;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defconst sokoban-floor-xpm "\
-/* XPM */
-static char * floor_xpm[] = {
-\"32 32 1 1\",
-\" c None\",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-};
-")
-
-(defconst sokoban-target-xpm "\
-/* XPM */
-static char * target_xpm[] = {
-\"32 32 3 1\",
-\" c None\",
-\". c black\",
-\"X c green\",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" ............ \",
-\" .XXXXXXXXXX. \",
-\" .XXXXXXXX. \",
-\" .XXXXXX. \",
-\" .. .XXXX. .. \",
-\" .X. .XX. .X. \",
-\" .XX. .. .XX. \",
-\" .XXX. .XXX. \",
-\" .XXXX. .XXXX. \",
-\" .XXXXX. .XXXXX. \",
-\" .XXXXX. .XXXXX. \",
-\" .XXXX. .XXXX. \",
-\" .XXX. .XXX. \",
-\" .XX. .. .XX. \",
-\" .X. .XX. .X. \",
-\" .. .XXXX. .. \",
-\" .XXXXXX. \",
-\" .XXXXXXXX. \",
-\" .XXXXXXXXXX. \",
-\" ............ \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-\" \",
-};
-")
-
-(defconst sokoban-wall-xpm "\
-/* XPM */
-static char * wall_xpm[] = {
-\"32 32 2 1\",
-\" c white\",
-\". c SteelBlue\",
-\" .............................. \",
-\". ............................ .\",
-\".. .......................... . \",
-\"... ........................ . .\",
-\".... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... ...................... . .\",
-\".... ...................... . . \",
-\".... . .\",
-\"... . . . . . . . . . . . . . \",
-\".. . . . . . . . . . . . . . .\",
-\". . . . . . . . . . . . . . . \",
-\" . . . . . . . . . . . . . . . \",
-};
-")
-
-(defconst sokoban-block-xpm "\
-/* XPM */
-static char * block_xpm[] = {
-\"32 32 3 1\",
-\" c None\",
-\". c black\",
-\"X c yellow\",
-\"............................. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".............................XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.\",
-\" .............................\",
-};
-")
-
-(defconst sokoban-block-on-target-xpm "\
-/* XPM */
-static char * block_on_target_xpm[] = {
-\"32 32 3 1\",
-\" c None\",
-\". c black\",
-\"X c green\",
-\"............................. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.X. \",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\".............................XX.\",
-\".XXXXXXXXXXXXXXXXXXXXXXXXXXX.XX.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.X.\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX..\",
-\" .XXXXXXXXXXXXXXXXXXXXXXXXXXX.\",
-\" .............................\",
-};
-")
-
-(defconst sokoban-player-xpm "\
-/* XPM */
-static char * player_xpm[] = {
-\"32 32 3 1\",
-\" c None\",
-\"o c white\",
-\". c black\",
-\" \",
-\" \",
-\" \",
-\" oooooooo \",
-\" o......o \",
-\" o.oooooo.o \",
-\" o.oooooo.o \",
-\" o.oooooooo.o \",
-\" o.o..oo..o.o \",
-\" o.oooooooo.o \",
-\" oo.o....o.oo \",
-\" oo..oo..oo..oo \",
-\" o....o..o....o \",
-\" o.o..o..o..o.o \",
-\" o.o...oo...o.o \",
-\" o.oo........oo.o \",
-\" o.oo........oo.o \",
-\" o.ooo........ooo.o \",
-\" o.ooo........ooo.o \",
-\" o.ooo........ooo.o \",
-\" o.oo........oo.o \",
-\" o.oo........oo.o \",
-\" o.o..........o.o \",
-\" o............o \",
-\" o..........o \",
-\" o........o \",
-\" o.o.oooo.o.o \",
-\" o.....oo.....o \",
-\" o......oo......o \",
-\" o.......oo.......o \",
-\" o..o..o..oo.oo..o..o \",
-\" oooooooooooooooooooo \",
-};
-")
-
-(defconst sokoban-player-on-target-xpm "\
-/* XPM */
-static char * player_on_target_xpm[] = {
-\"32 32 4 1\",
-\" c None\",
-\"o c white\",
-\". c black\",
-\"X c green\",
-\" \",
-\" \",
-\" \",
-\" oooooooo \",
-\" o......o \",
-\" o.oooooo.o \",
-\" .o.oooooo.o. \",
-\" o.oooooooo.o \",
-\" o.o..oo..o.o \",
-\" o.oooooooo.o \",
-\" .. oo.o....o.oo .. \",
-\" .X.oo..oo..oo..oo.X. \",
-\" .XXo....o..o....oXX. \",
-\" .XXo.o..o..o..o.oXX. \",
-\" .XXo.o...oo...o.oXX. \",
-\" .Xo.oo........oo.oX. \",
-\" .Xo.oo........oo.oX. \",
-\" .o.ooo........ooo.o. \",
-\" .o.ooo........ooo.o. \",
-\" .o.ooo........ooo.o. \",
-\" .Xo.oo........oo.oX. \",
-\" ..o.oo........oo.o.. \",
-\" o.o..........o.o \",
-\" o............o \",
-\" o..........o \",
-\" .o........o. \",
-\" o.o.oooo.o.o \",
-\" o.....oo.....o \",
-\" o......oo......o \",
-\" o.......oo.......o \",
-\" o..o..o..oo.oo..o..o \",
-\" oooooooooooooooooooo \",
-};
-")
-
-(defconst sokoban-floor ?\&)
-;; note - space character in level file is also allowed to indicate floor
-(defconst sokoban-target ?\.)
-(defconst sokoban-wall ?\#)
-(defconst sokoban-block ?\$)
-(defconst sokoban-player ?\@)
-(defconst sokoban-block-on-target ?\*)
-(defconst sokoban-player-on-target ?\+)
-
-;; ;;;;;;;;;;;;; display options ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar sokoban-floor-options
- `(((glyph
- [xpm :data ,sokoban-floor-xpm])
- (t ?\040))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [0 0 0])
- (color-tty "black"))))
-
-(defvar sokoban-target-options
- `(((glyph
- [xpm :data ,sokoban-target-xpm])
- ((mono-x mono-tty emacs-tty) ?\.)
- (t ?\040))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [1 1 0.5])
- (color-tty "yellow"))))
-
-(defvar sokoban-wall-options
- `(((glyph
- [xpm :data ,sokoban-wall-xpm])
- (emacs-tty ?\X)
- (t ?\040))
- ((color-x color-x)
- (mono-x mono-x)
- (color-tty color-tty)
- (mono-tty mono-tty))
- (((glyph color-x) [0 0 1])
- (color-tty "blue"))))
-
-(defvar sokoban-block-options
- `(((glyph
- [xpm :data ,sokoban-block-xpm])
- ((mono-x mono-tty emacs-tty) ?\O)
- (t ?\040))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [1 0 0])
- (color-tty "red"))))
-
-(defvar sokoban-block-on-target-options
- `(((glyph
- [xpm :data ,sokoban-block-on-target-xpm])
- ((mono-x mono-tty emacs-tty) ?\O)
- (t ?\040))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [1 0 0])
- (color-tty "red"))))
-
-(defvar sokoban-player-options
- `(((glyph
- [xpm :data ,sokoban-player-xpm])
- (t ?\*))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [0 1 0])
- (color-tty "green"))))
-
-(defvar sokoban-player-on-target-options
- `(((glyph
- [xpm :data ,sokoban-player-on-target-xpm])
- (t ?\*))
- ((color-x color-x)
- (mono-x grid-x)
- (color-tty color-tty))
- (((glyph color-x) [0 1 0])
- (color-tty "green"))))
-
-;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar sokoban-level 0)
-(make-variable-buffer-local 'sokoban-level)
-(defvar sokoban-level-map nil)
-(make-variable-buffer-local 'sokoban-level-map)
-(defvar sokoban-targets 0)
-(make-variable-buffer-local 'sokoban-targets)
-(defvar sokoban-x 0)
-(make-variable-buffer-local 'sokoban-x)
-(defvar sokoban-y 0)
-(make-variable-buffer-local 'sokoban-y)
-(defvar sokoban-moves 0)
-(make-variable-buffer-local 'sokoban-moves)
-(defvar sokoban-pushes 0)
-(make-variable-buffer-local 'sokoban-pushes)
-(defvar sokoban-done 0)
-(make-variable-buffer-local 'sokoban-done)
-(defvar sokoban-mouse-x 0)
-(make-variable-buffer-local 'sokoban-mouse-x)
-(defvar sokoban-mouse-y 0)
-(make-variable-buffer-local 'sokoban-mouse-y)
-(defvar sokoban-undo-list nil)
-(make-variable-buffer-local 'sokoban-undo-list)
-
-;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar sokoban-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "n" 'sokoban-start-game)
- (define-key map "r" 'sokoban-restart-level)
- (define-key map "g" 'sokoban-goto-level)
- (define-key map "F" 'fit-frame-to-buffer)
- (define-key map "s" 'sokoban-save)
- (define-key map "l" 'sokoban-load)
-
- (define-key map [left] 'sokoban-move-left)
- (define-key map [right] 'sokoban-move-right)
- (define-key map [up] 'sokoban-move-up)
- (define-key map [down] 'sokoban-move-down)
-
- (define-key map [down-mouse-2] 'sokoban-mouse-event-start)
- (define-key map [mouse-2] 'sokoban-mouse-event-end)
- ;; On some systems (OS X) middle mouse is difficult.
- ;; FIXME: Use follow-link?
- (define-key map [down-mouse-1] 'sokoban-mouse-event-start)
- (define-key map [mouse-1] 'sokoban-mouse-event-end)
-
- (define-key map [(control ?/)] 'sokoban-undo)
- map))
-
-;; ;;;;;;;;;;;;;;;; level file parsing functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defconst sokoban-level-regexp "^;LEVEL [0-9]+$")
-
-(defconst sokoban-comment-regexp "^;")
-
-(defun sokoban-convert-xml-to-plain-text ()
- (let ((n 0) (tree (xml-parse-region)))
- (erase-buffer)
- (dolist (SokobanLevels tree)
- (dolist (LevelCollection (xml-get-children SokobanLevels
'LevelCollection))
- (dolist (Level (xml-get-children LevelCollection 'Level))
- (cl-incf n)
- (insert (format ";LEVEL %d\n" n))
- (dolist (L (xml-get-children Level 'L))
- (insert (car (xml-node-children L)))
- (insert "\n"))))))
- (goto-char (point-min)))
-
-(defun sokoban-init-level-data ()
- (setq sokoban-level-data nil
- sokoban-width 15 ; need at least 15 for score display
- sokoban-height 1)
- (with-temp-buffer
- (insert-file-contents sokoban-level-file)
- (goto-char (point-min))
- (if (looking-at "<\\?xml version=")
- (sokoban-convert-xml-to-plain-text))
- (re-search-forward sokoban-level-regexp nil t)
- (forward-char)
- (let (r)
- (while (not (eobp))
- (while (looking-at sokoban-comment-regexp)
- (forward-line))
- (setq r 0)
- (while (not (or (eobp)
- (looking-at sokoban-comment-regexp)))
- (cl-incf r)
- (setq sokoban-height (max sokoban-height r)
- sokoban-width (max sokoban-width (- (line-end-position)
(line-beginning-position))))
- (forward-line))))
- (setq sokoban-buffer-width sokoban-width
- sokoban-buffer-height (+ 4 sokoban-height)
- sokoban-score-x 0
- sokoban-score-y (1+ sokoban-height))
-
- (goto-char (point-min))
- (re-search-forward sokoban-level-regexp nil t)
- (forward-char)
- (while (not (eobp))
- (while (looking-at sokoban-comment-regexp)
- (forward-line))
- (let ((data (make-vector sokoban-height nil))
- (fmt (format "%%-%ds" sokoban-width)))
- (dotimes (y sokoban-height)
- (cond ((or (eobp)
- (looking-at sokoban-comment-regexp))
- (aset data y (format fmt "")))
- (t
- (let ((start (point))
- (end (line-end-position)))
- (aset data
- y
- (format fmt (buffer-substring start end)))
- (goto-char (1+ end))))))
- (push data sokoban-level-data)))
- (kill-buffer (current-buffer))
- (setq sokoban-level-data (nreverse sokoban-level-data))))
-
-;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun sokoban-display-options ()
- (let ((options (make-vector 256 nil)))
- (dotimes (c 256)
- (aset options c
- (cond ((= c sokoban-floor)
- sokoban-floor-options)
- ((= c sokoban-target)
- sokoban-target-options)
- ((= c sokoban-wall)
- sokoban-wall-options)
- ((= c sokoban-block)
- sokoban-block-options)
- ((= c sokoban-block-on-target)
- sokoban-block-on-target-options)
- ((= c sokoban-player)
- sokoban-player-options)
- ((= c sokoban-player-on-target)
- sokoban-player-on-target-options)
- (t
- '(nil nil nil)))))
- options))
-
-(defun sokoban-get-level-data ()
- (setq sokoban-level-map (nth (1- sokoban-level) sokoban-level-data)
- sokoban-targets 0)
- (dotimes (y sokoban-height)
- (dotimes (x sokoban-width)
- (let ((c (aref (aref sokoban-level-map y) x)))
- (cond
- ((or (eq c sokoban-target)
- (eq c sokoban-player-on-target))
- (cl-incf sokoban-targets))
- ((eq c sokoban-block-on-target)
- (cl-incf sokoban-targets)
- (cl-incf sokoban-done))
- ((= c ?\040) ;; treat space characters in level file as floor
- (aset (aref sokoban-level-map y) x sokoban-floor)))))))
-
-(defun sokoban-init-buffer ()
- (gamegrid-init-buffer sokoban-buffer-width
- sokoban-buffer-height
- ?\040)
- (dotimes (y sokoban-height)
- (dotimes (x sokoban-width)
- (let ((c (aref (aref sokoban-level-map y) x)))
- (if (or (eq c sokoban-player)
- (eq c sokoban-player-on-target))
- (setq sokoban-x x
- sokoban-y y))
- (gamegrid-set-cell x y c)))))
-
-(defun sokoban-draw-score ()
- (let ((y sokoban-score-y))
- (dolist (string (list (format "Moves: %05d" sokoban-moves)
- (format "Pushes: %05d" sokoban-pushes)
- (format "Done: %d/%d "
- sokoban-done
- sokoban-targets)))
- (let* ((len (length string)))
- (dotimes (x len)
- (gamegrid-set-cell (+ sokoban-score-x x)
- y (aref string x))))
- (cl-incf y)))
- (setq mode-line-format
- (format "Sokoban: Level: %d/%d Moves: %05d Pushes: %05d Done:
%d/%d"
- sokoban-level (length sokoban-level-data) sokoban-moves
sokoban-pushes
- sokoban-done sokoban-targets))
- (force-mode-line-update))
-
-(defun sokoban-add-move (dx dy)
- (push (list 'move dx dy) sokoban-undo-list)
- (cl-incf sokoban-moves)
- (sokoban-draw-score))
-
-(defun sokoban-add-push (dx dy)
- (push (list 'push dx dy) sokoban-undo-list)
- (cl-incf sokoban-moves)
- (cl-incf sokoban-pushes)
- (sokoban-draw-score))
-
-(defun sokoban-targetp (x y)
- (let ((c (aref (aref sokoban-level-map y) x)))
- (or (eq c sokoban-target)
- (eq c sokoban-block-on-target)
- (eq c sokoban-player-on-target))))
-
-(defun sokoban-set-floor (x y)
- (gamegrid-set-cell x y
- (if (sokoban-targetp x y)
- sokoban-target
- sokoban-floor)))
-
-(defun sokoban-set-player (x y)
- (gamegrid-set-cell x y
- (if (sokoban-targetp x y)
- sokoban-player-on-target
- sokoban-player)))
-
-(defun sokoban-set-block (x y)
- (gamegrid-set-cell x y
- (if (sokoban-targetp x y)
- sokoban-block-on-target
- sokoban-block)))
-
-(defun sokoban-undo ()
- "Undo previous Sokoban change."
- (interactive)
- ;; FIXME: Use the normal undo (via `apply' undo entries).
- (if (null sokoban-undo-list)
- (message "Nothing to undo")
- (let* ((entry (pop sokoban-undo-list))
- (type (car entry))
- (dx (nth 1 entry))
- (dy (nth 2 entry)))
- (cond ((eq type 'push)
- (let* ((x (+ sokoban-x dx))
- (y (+ sokoban-y dy)))
- (sokoban-set-floor x y)
- (if (sokoban-targetp x y)
- (cl-decf sokoban-done))
- (sokoban-set-block sokoban-x sokoban-y)
- (if (sokoban-targetp sokoban-x sokoban-y)
- (cl-incf sokoban-done)))
- (setq sokoban-x (- sokoban-x dx))
- (setq sokoban-y (- sokoban-y dy))
- (sokoban-set-player sokoban-x sokoban-y)
- (cl-decf sokoban-pushes)
- (cl-decf sokoban-moves))
- ((eq type 'move)
- (sokoban-set-floor sokoban-x sokoban-y)
- (setq sokoban-x (- sokoban-x dx))
- (setq sokoban-y (- sokoban-y dy))
- (sokoban-set-player sokoban-x sokoban-y)
- (cl-decf sokoban-moves))
- (t
- (message "Invalid entry in sokoban-undo-list")))
- (sokoban-draw-score))))
-
-(defun sokoban-move (dx dy)
- (let* ((x (+ sokoban-x dx))
- (y (+ sokoban-y dy))
- (c (gamegrid-get-cell x y)))
- (cond ((or (eq c sokoban-floor)
- (eq c sokoban-target))
- (sokoban-set-floor sokoban-x sokoban-y)
- (setq sokoban-x x
- sokoban-y y)
- (sokoban-set-player sokoban-x sokoban-y)
- (sokoban-add-move dx dy))
- ((or (eq c sokoban-block)
- (eq c sokoban-block-on-target))
- (let* ((xx (+ x dx))
- (yy (+ y dy))
- (cc (gamegrid-get-cell xx yy)))
- (cond ((or (eq cc sokoban-floor)
- (eq cc sokoban-target))
- (if (sokoban-targetp x y)
- (cl-decf sokoban-done))
- (sokoban-set-block xx yy)
- (sokoban-set-player x y)
- (sokoban-set-floor sokoban-x sokoban-y)
- (setq sokoban-x x
- sokoban-y y)
- (if (sokoban-targetp xx yy)
- (cl-incf sokoban-done))
- (sokoban-add-push dx dy)
- (cond ((= sokoban-done sokoban-targets)
- (let ((level sokoban-level))
- (with-temp-file sokoban-state-filename
- (print level (current-buffer))))
- (sit-for 3)
- (sokoban-next-level))))))))))
-
-(defun sokoban-event-x (event)
- (let ((x (gamegrid-event-x event)))
- ;; 32.0 is the pixel width of the xpm image
- (floor x (/ 32.0 (frame-char-width)))))
-
-(defun sokoban-event-y (event)
- (let ((y (gamegrid-event-y event)))
- (floor y (/ 32.0 (frame-char-height)))))
-
-(defun sokoban-mouse-event-start (event)
- "Record the beginning of a mouse click."
- (interactive "e")
- (setq sokoban-mouse-x (sokoban-event-x event))
- (setq sokoban-mouse-y (sokoban-event-y event)))
-
-(defun sokoban-mouse-event-end (event)
- "Move according to the clicked position."
- (interactive "e")
- (let* ((x (sokoban-event-x event))
- (y (sokoban-event-y event))
- (dx (- x sokoban-x))
- (dy (- y sokoban-y)))
- (cond
- ;; Ensure that press and release are in the same square
- ;; (which allows you to abort a move)
- ((not (and (eq sokoban-mouse-x x) (eq sokoban-mouse-y y)))
- nil)
- ;; Check that the move isn't diagonal
- ((not (or (eq dx 0) (eq dy 0)))
- nil)
- ((< dx 0) ;; Left
- (while (< dx 0)
- (sokoban-move -1 0)
- (setq dx (1+ dx))))
- ((> dx 0) ;; Right
- (while (> dx 0)
- (sokoban-move 1 0)
- (setq dx (1- dx))))
- ((> dy 0) ;; Up
- (while (> dy 0)
- (sokoban-move 0 1)
- (setq dy (1- dy))))
- ((< dy 0) ;; Down
- (while (< dy 0)
- (sokoban-move 0 -1)
- (setq dy (1+ dy)))))))
-
-(defun sokoban-move-left ()
- "Move one square left."
- (interactive)
- (sokoban-move -1 0))
-
-(defun sokoban-move-right ()
- "Move one square right."
- (interactive)
- (sokoban-move 1 0))
-
-(defun sokoban-move-up ()
- "Move one square up."
- (interactive)
- (sokoban-move 0 -1))
-
-(defun sokoban-move-down ()
- "Move one square down."
- (interactive)
- (sokoban-move 0 1))
-
-(defun sokoban-restart-level ()
- "Restart the current level."
- (interactive)
- (setq sokoban-moves 0
- sokoban-pushes 0
- sokoban-done 0
- sokoban-undo-list nil)
- (sokoban-get-level-data)
- (sokoban-init-buffer)
- (sokoban-draw-score))
-
-(defun sokoban-next-level ()
- (sokoban-goto-level (1+ sokoban-level)))
-
-(defun sokoban-goto-level (level)
- "Jump to a specified LEVEL."
- (interactive "nLevel: ")
- (when (or (< level 1)
- (> level (length sokoban-level-data)))
- (signal 'args-out-of-range
- (list
- (format "No such level number %d, should be 1..%d"
- level (length sokoban-level-data)))))
- (setq sokoban-level level)
- (sokoban-restart-level))
-
-(defun sokoban-start-game ()
- "Start a new game of Sokoban."
- (interactive)
- (setq sokoban-level 0)
- (sokoban-next-level))
-
-(defvar sokoban-grid-state)
-
-(defconst sokoban-state-variables '(
- sokoban-level
- sokoban-level-map
- sokoban-targets
- sokoban-x
- sokoban-y
- sokoban-moves
- sokoban-pushes
- sokoban-done
- sokoban-undo-list
- sokoban-grid-state
- ))
-(defun sokoban-save (filename)
- "Save current Sokoban state."
- (interactive "FSave file: ")
- (let ((buf (current-buffer)))
- (setq sokoban-grid-state nil)
- (dotimes (y sokoban-height)
- (dotimes (x sokoban-width)
- (push (gamegrid-get-cell x y) sokoban-grid-state)))
- (setq sokoban-grid-state (reverse sokoban-grid-state))
- (with-temp-file filename
- (dolist (var sokoban-state-variables)
- (print
- (with-current-buffer buf (eval var))
- (current-buffer))))))
-
-(defun sokoban-load (filename)
- "Restore saved Sokoban state."
- (interactive "fLoad file: ")
- (let ((buf (current-buffer)))
- (with-temp-buffer
- (insert-file-contents filename)
- (goto-char (point-min))
- (dolist (var sokoban-state-variables)
- (let ((value (read (current-buffer))))
- (with-current-buffer buf (set var value))))))
- (dotimes (y sokoban-height)
- (dotimes (x sokoban-width)
- (gamegrid-set-cell x y (pop sokoban-grid-state))))
- (sokoban-draw-score))
-
-(easy-menu-define sokoban-popup-menu nil "Popup menu for Sokoban mode."
- '("Sokoban Commands"
- ["Restart this level" sokoban-restart-level]
- ["Start new game" sokoban-start-game]
- ["Go to specific level" sokoban-goto-level]
- ["Fit frame to buffer" fit-frame-to-buffer]
- ["Save current state" sokoban-save]
- ["Restore saved state" sokoban-load]))
-(define-key sokoban-mode-map [down-mouse-3] sokoban-popup-menu)
-
-(define-derived-mode sokoban-mode special-mode "Sokoban"
- "A mode for playing Sokoban.
-
-sokoban-mode keybindings:
- \\{sokoban-mode-map}"
-
- (set (make-local-variable 'gamegrid-use-glyphs) sokoban-use-glyphs)
- (set (make-local-variable 'gamegrid-use-color) sokoban-use-color)
- (set (make-local-variable 'gamegrid-font) sokoban-font)
-
- (gamegrid-init (sokoban-display-options))
-
- (if (null sokoban-level-data)
- (sokoban-init-level-data)))
-
-;;;###autoload
-(defun sokoban ()
- "Sokoban.
-
-Push the blocks onto the target squares.
-
-sokoban-mode keybindings:
- \\<sokoban-mode-map>
-\\[sokoban-start-game] Starts a new game of Sokoban
-\\[sokoban-restart-level] Restarts the current level
-\\[sokoban-goto-level] Jumps to a specified level
-\\[fit-frame-to-buffer] Fit frame to buffer
-\\[sokoban-save] Save current state
-\\[sokoban-load] Restore saved state
-\\[sokoban-move-left] Move one square to the left
-\\[sokoban-move-right] Move one square to the right
-\\[sokoban-move-up] Move one square up
-\\[sokoban-move-down] Move one square down"
- (interactive)
-
- (switch-to-buffer sokoban-buffer-name)
- (gamegrid-kill-timer)
- (sokoban-mode)
- (setq sokoban-level 0)
- (if (file-exists-p sokoban-state-filename)
- (setq sokoban-level
- (with-temp-buffer
- (insert-file-contents sokoban-state-filename)
- (goto-char (point-min))
- (read (current-buffer)))))
- (sokoban-next-level))
-
-;;;###autoload
-(define-key-after ; install a menu entry
- (lookup-key global-map [menu-bar tools games])
- [sokoban]
- '(menu-item "Sokoban" sokoban)
- 'snake)
-
-(provide 'sokoban)
-
-;;; sokoban.el ends here
diff --git a/packages/sokoban/sokoban.levels b/packages/sokoban/sokoban.levels
deleted file mode 100644
index 383146a..0000000
--- a/packages/sokoban/sokoban.levels
+++ /dev/null
@@ -1,1290 +0,0 @@
-;WALLS
- 12 f f ff 0 standard floor
-. 13 f f ff 4 target field
-# 0 0 0 0 0 walls
-
-;OBJECTS
-@ 0 f 0 101 201 1 0 player
-$ 1 f 0 100 0 2 1000 heavy box
-
-;MAXLEVEL 88
-;ATOP *$.
-;LEVEL 1
- #####
- # #
- #$ #
- ### $##
- # $ $ #
-### # ## # ######
-# # ## ##### ..#
-# $ $ ..#
-##### ### #@## ..#
- # #########
- #######
-;LEVEL 2
-############
-#.. # ###
-#.. # $ $ #
-#.. #$#### #
-#.. @ ## #
-#.. # # $ ##
-###### ##$ $ #
- # $ $ $ $ #
- # # #
- ############
-;LEVEL 3
- ########
- # @#
- # $#$ ##
- # $ $#
- ##$ $ #
-######### $ # ###
-#.... ## $ $ #
-##... $ $ #
-#.... ##########
-########
-;LEVEL 4
- ########
- # ....#
-############ ....#
-# # $ $ ....#
-# $$$#$ $ # ....#
-# $ $ # ....#
-# $$ #$ $ $########
-# $ # #
-## #########
-# # ##
-# $ ##
-# $$#$$ @#
-# # ##
-###########
-;LEVEL 5
- #####
- # #####
- # #$## #
- # $ #
-######### ### #
-#.... ## $ $###
-#.... $ $$ ##
-#.... ##$ $ @#
-######### $ ##
- # $ $ #
- ### ## #
- # #
- ######
-;LEVEL 6
-###### ###
-#.. # ##@##
-#.. ### #
-#.. $$ #
-#.. # # $ #
-#..### # $ #
-#### $ #$ #
- # $# $ #
- # $ $ #
- # ## #
- #########
-;LEVEL 7
- #####
- ####### ##
-## # @## $$ #
-# $ #
-# $ ### #
-### #####$###
-# $ ### ..#
-# $ $ $ ...#
-# ###...#
-# $$ # #...#
-# ### #####
-####
-;LEVEL 8
- ####
- # ###########
- # $ $ $ #
- # $# $ # $ #
- # $ $ # #
-### $# # #### #
-#@#$ $ $ ## #
-# $ #$# # #
-# $ $ $ $ #
-##### #########
- # #
- # #
- #......#
- #......#
- #......#
- ########
-;LEVEL 9
- #######
- # ...#
- ##### ...#
- # . .#
- # ## ...#
- ## ## ...#
- ### ########
- # $$$ ##
- ##### $ $ #####
-## #$ $ # #
-#@ $ $ $ $ #
-###### $$ $ #####
- # #
- ########
-;LEVEL 10
- ### #############
-##@#### # #
-# $$ $$ $ $ ...#
-# $$$# $ #...#
-# $ # $$ $$ #...#
-### # $ #...#
-# # $ $ $ #...#
-# ###### ###...#
-## # # $ $ #...#
-# ## # $$ $ $##..#
-# ..# # $ #.#
-# ..# # $$$ $$$ #.#
-##### # # #.#
- # ######### #.#
- # #.#
- ###############
-;LEVEL 11
- ####
- #### # #
- ### @###$ #
- ## $ #
- ## $ $$## ##
- # #$## #
- # # $ $$ # ###
- # $ # # $ #####
-#### # $$ # #
-#### ## $ #
-#. ### ########
-#.. ..# ####
-#...#.#
-#.....#
-#######
-;LEVEL 12
-################
-# #
-# # ###### #
-# # $ $ $ $# #
-# # $@$ ## ##
-# # $ $ $###...#
-# # $ $ ##...#
-# ###$$$ $ ##...#
-# # ## ##...#
-##### ## ##...#
- ##### ###
- # #
- #######
-;LEVEL 13
- #########
- ## ## #####
-### # # ###
-# $ #$ # # ... #
-# # $#@$## # #.#. #
-# # #$ # . . #
-# $ $ # # #.#. #
-# ## ##$ $ . . #
-# $ # # #$#.#. #
-## $ $ $ $... #
- #$ ###### ## #
- # # ##########
- ####
-;LEVEL 14
- #######
- ####### #
- # # $@$ #
- #$$ # #########
- # ###......## #
- # $......## # #
- # ###...... #
-## #### ### #$##
-# #$ # $ # #
-# $ $$$ # $## #
-# $ $ ###$$ # #
-##### $ # #
- ### ### # #
- # # #
- ######## #
- ####
-;LEVEL 15
- ########
- # # #
- # $ #
- ### #$ ####
- # $ ##$ #
- # # @ $ # $#
- # # $ ####
- ## ####$## #
- # $#.....# # #
- # $..**. $# ###
-## #.....# #
-# ### #######
-# $$ # #
-# # #
-###### #
- #####
-;LEVEL 16
-#####
-# ##
-# # ####
-# $ #### #
-# $$ $ $#
-###@ #$ ##
- # ## $ $ ##
- # $ ## ## .#
- # #$##$ #.#
- ### $..##.#
- # #.*...#
- # $$ #.....#
- # #########
- # #
- ####
-;LEVEL 17
- ##########
- #.. # #
- #.. #
- #.. # ####
- ####### # ##
- # #
- # # ## # #
-#### ## #### ##
-# $ ##### # #
-# # $ $ # $ #
-# @$ $ # ##
-#### ## #######
- # #
- ######
-;LEVEL 18
- ###########
- # . # #
- # #. @ #
- ##### ##..# ####
-## # ..### ###
-# $ #... $ # $ #
-# .. ## ## ## #
-####$##$# $ # # #
- ## # #$ $$ # #
- # $ # # # $## #
- # #
- # ########### #
- #### ####
-;LEVEL 19
- ######
- # @####
-##### $ #
-# ## ####
-# $ # ## #
-# $ # ##### #
-## $ $ # #
-## $ $ ### # #
-## # $ # # #
-## # #$# # #
-## ### # # ######
-# $ #### # #....#
-# $ $ ..#.#
-####$ $# $ ....#
-# # ## ....#
-###################
-;LEVEL 20
- ##########
-##### ####
-# # $ #@ #
-# #######$#### ###
-# # ## # #$ ..#
-# # $ # # #.#
-# # $ # #$ ..#
-# # ### ## #.#
-# ### # # #$ ..#
-# # # #### #.#
-# #$ $ $ #$ ..#
-# $ # $ $ # #.#
-#### $### #$ ..#
- # $$ ###....#
- # ## ######
- ########
-;LEVEL 21
-#########
-# #
-# ####
-## #### # #
-## #@## #
-# $$$ $ $$#
-# # ## $ #
-# # ## $ ####
-#### $$$ $# #
- # ## ....#
- # # # #.. .#
- # # # ##...#
- ##### $ #...#
- ## #####
- #####
-;LEVEL 22
-###### ####
-# ####### #####
-# $# # $ # #
-# $ $ $ # $ $ #
-##$ $ # @# $ #
-# $ ########### ##
-# # #.......# $#
-# ## # ......# #
-# # $........$ #
-# # $ #.... ..# #
-# $ $####$#### $#
-# $ ### $ $ ##
-# $ $ $ $ #
-## ###### $ ##### #
-# # #
-###################
-;LEVEL 23
- #######
- # # ####
-##### $#$ # ##
-#.. # # # #
-#.. # $#$ # $####
-#. # #$ # #
-#.. $# # $ #
-#..@# #$ #$ # #
-#.. # $# $# #
-#.. # #$$#$ # ##
-#.. # $# # $#$ #
-#.. # # # # #
-##. #### ##### #
- #### #### #####
-;LEVEL 24
-###############
-#.......... .####
-#..........$$.# #
-###########$ # ##
-# $ $ $ #
-## #### # $ # #
-# # ## # ##
-# $# # ## ### ##
-# $ #$### ### ##
-### $ # # ### ##
-### $ ## # # ##
- # $ # $ $ $ #
- # $ $#$$$ # #
- # # $ #####
- # @## # # #
- ##############
-;LEVEL 25
-####
-# ##############
-# # ..#......#
-# # # ##### ...#
-##$# ........#
-# ##$###### ####
-# $ # ######@ #
-##$ # $ ###### #
-# $ #$$$## #
-# # #$#$###
-# #### #$$$$$ #
-# # $ # #
-# # ## ###
-# ######$###### $ #
-# # # #
-########## #####
-;LEVEL 26
- #######
- # # #####
-## # #...###
-# $# #... #
-# $ #$$ ... #
-# $# #... .#
-# # $########
-##$ $ $ #
-## # $$ # #
- ###### ##$$@#
- # ##
- ########
-;LEVEL 27
- #################
- #... # # ##
-##..... $## # #$ #
-#......# $ # #
-#......# # # # #
-######### $ $ $ #
- # #$##$ ##$##
- ## $ # $ #
- # ## ### # ##$ #
- # $ $$ $ $ #
- # $ $##$ ######
- ####### @ ##
- ######
-;LEVEL 28
- #####
- ##### #
- ## $ $ ####
-##### $ $ $ ##.#
-# $$ ##..#
-# ###### ###.. #
-## # # #... #
-# $ # #... #
-#@ #$ ## ####...#
-#### $ $$ ##..#
- ## $ $ $...#
- # $$ $ # .#
- # $ $ ####
- ###### #
- #####
-;LEVEL 29
-#####
-# ##
-# $ #########
-## # # ######
-## # $#$#@ # #
-# # $ # $ #
-# ### ######### ##
-# ## ..*..... # ##
-## ## *.*..*.* # ##
-# $########## ##$ #
-# $ $ $ $ #
-# # # # # #
-###################
-;LEVEL 30
- ###########
- # # #
-##### # $ $ #
-# ##### $## # ##
-# $ ## # ## $ #
-# $ @$$ # ##$$$ #
-## ### # ## #
-## # ### #####$#
-## # $ #....#
-# ### ## $ #....##
-# $ $ # #..$. #
-# ## $ # ##.... #
-##### ######...##
- ##### #####
-;LEVEL 31
- ####
- # #########
- ## ## # #
- # $# $@$ ####
- #$ $ # $ $# ##
-## $## #$ $ #
-# # # # $$$ #
-# $ $ $## ####
-# $ $ #$# # #
-## ### ###$ #
- # #.... #
- ####......####
- #....####
- #...##
- #...#
- #####
-;LEVEL 32
- ####
- ##### #
- ## $#
-## $ ## ###
-#@$ $ # $ #
-#### ## $#
- #....#$ $ #
- #....# $#
- #.... $$ ##
- #... # $ #
- ######$ $ #
- # ###
- #$ ###
- # #
- ####
-;LEVEL 33
-############
-## ## #
-## $ $ #
-#### ## $$ #
-# $ # #
-# $$$ # ####
-# # # $ ##
-# # # $ #
-# $# $# #
-# ..# ####
-####.. $ #@#
-#.....# $# #
-##....# $ #
-###..## #
-############
-;LEVEL 34
- #########
- #.... ##
- #.#.# $ ##
-##....# # @##
-# ....# # ##
-# #$ ##$ #
-## ### $ #
- #$ $ $ $# #
- # # $ $ ## #
- # ### ## #
- # ## ## ##
- # $ # $ #
- ###$ $ ###
- # #####
- ####
-;LEVEL 35
-############ ######
-# # # ###....#
-# $$# @ .....#
-# # ### # ....#
-## ## ### # ....#
- # $ $ # # ####
- # $ $## # #
-#### # #### # ## #
-# # #$ ## # #
-# $ $ # ## # ##
-# # $ $ # # #
-# $ ## ## # #####
-# $$ $$ #
-## ## ### $ #
- # # # #
- ###### ######
-;LEVEL 36
- #####
-##### ###### #
-# #### $ $ $ #
-# $ ## ## ## ##
-# $ $ $ $ #
-### $ ## ## ##
- # ##### #####$$ #
- ##$##### @## #
- # $ ###$### $ ##
- # $ # ### ###
- # $$ $ # $$ #
- # # ## #
- #######.. .###
- #.........#
- #.........#
- ###########
-;LEVEL 37
-###########
-#...... #########
-#...... # ## #
-#..### $ $ #
-#... $ $ # ## #
-#...#$##### # #
-### # #$ #$ #
- # $$ $ $ $## #
- # $ #$#$ ##$ #
- ### ## # ## #
- # $ $ ## ######
- # $ $ #
- ## # # #
- #####@#####
- ###
-;LEVEL 38
- ####
-####### @#
-# $ #
-# $## $#
-##$#...# #
- # $... #
- # #. .# ##
- # # #$ #
- #$ $ #
- # #######
- ####
-;LEVEL 39
- ######
- #############....#
-## ## ##....#
-# $$## $ @##....#
-# $$ $# ....#
-# $ ## $$ # # ...#
-# $ ## $ # ....#
-## ##### ### ##.###
-## $ $ ## . #
-# $### # ##### ###
-# $ # #
-# $ #$ $ $### #
-# $$$# $ # ####
-# # $$ #
-###### ###
- #####
-;LEVEL 40
- ############
- # ##
- # # #$$ $ #
- #$ #$# ## @#
- ## ## # $ # ##
- # $ #$ # #
- # # $ # #
- ## $ $ ## #
- # # ## $ #
- # ## $$# #
-######$$ # #
-#....# ########
-#.#... ##
-#.... #
-#.... #
-#########
-;LEVEL 41
- #####
- ## ##
- ## #
- ## $$ #
- ## $$ $ #
- # $ $ #
-#### # $$ #####
-# ######## ## #
-#. $$$@#
-#.# ####### ## ##
-#.# #######. #$ $##
-#........... # #
-############## $ #
- ## ##
- ####
-;LEVEL 42
- ########
- #### ######
- # ## $ $ @#
- # ## ##$#$ $ $##
-### ......# $$ ##
-# ......# # #
-# # ......#$ $ #
-# #$...... $$# $ #
-# ### ###$ $ ##
-### $ $ $ $ #
- # $ $ $ $ #
- ###### ######
- #####
-;LEVEL 43
- #######
- ##### # ####
- # # $ #
- #### #$$ ## ## #
-## # # ## ###
-# ### $#$ $ $ #
-#... # ## # #
-#...# @ # ### ##
-#...# ### $ $ #
-######## ## # #
- #########
-;LEVEL 44
- #####
- # #
- # # #######
- # $@######
- # $ ##$ ### #
- # #### $ $ #
- # ##### # #$ ####
-## #### ##$ #
-# $# $ # ## ## #
-# # #...# #
-###### ### ... #
- #### # #...# #
- # ### # #
- # #
- #########
-;LEVEL 45
-##### ####
-#...# # ####
-#...### $ #
-#....## $ $###
-##....## $ #
-###... ## $ $ #
-# ## # $ #
-# ## # ### ####
-# $ # #$ $ #
-# $ @ $ $ #
-# # $ $$ $ ###
-# ###### ###
-# ## ####
-###
-;LEVEL 46
-##########
-# ####
-# ###### # ##
-# # $ $ $ $ #
-# #$ #
-###$ $$# ###
- # ## # $##
- ##$# $ @#
- # $ $ ###
- # # $ #
- # ## # #
- ## ##### #
- # #
- #.......###
- #.......#
- #########
-;LEVEL 47
- ####
- ######### ##
-## $ $ #####
-# ## ## ##...#
-# #$$ $ $$#$##...#
-# # @ # ...#
-# $# ###$$ ...#
-# $ $$ $ ##....#
-###$ #######
- # #######
- ####
-;LEVEL 48
- #########
- #*.*#*.*#
- #.*.*.*.#
- #*.*.*.*#
- #.*.*.*.#
- #*.*.*.*#
- ### ###
- # #
-###### ######
-# #
-# $ $ $ $ $ #
-## $ $ $ $ ##
- #$ $ $ $ $#
- # $@$ #
- # ##### #
- #### ####
-;LEVEL 49
- ####
- # ##
- # ##
- # $$ ##
- ###$ $ ##
- #### $ #
-### # ##### #
-# # #....$ #
-# # $ ....# #
-# $ # #.*..# #
-### #### ### #
- #### @$ ##$##
- ### $ #
- # ## #
- #########
-;LEVEL 50
- ############
- ##.. # #
- ##..* $ $ #
- ##..*.# # # $##
- #..*.# # # $ #
-####...# # # #
-# ## # #
-# @$ $ ### # ##
-# $ $ # # #
-###$$ # # # # #
- # $ # # #####
- # $# ##### #
- #$ # # # #
- # ### ## #
- # # # ##
- #### ######
-;LEVEL 51
-#########
-# #
-# $ $#
-#### #
- # $ ##
-#### $ #
-#.. $ ## ####
-#.. $## #
-#.. $ #
-#.###$### #@#
-#.# # ###
-### #######
-;LEVEL 52
-####################
-# ########## @#
-# $# # ######
-# #### # ###
-##### # ###
-# $ # ###
-# $#### # # #
-# # # #..#$### # #
-# # #$ #..# $ $$ #
-# #..# # # #
-# # #..# # # #
-####################
-;LEVEL 53
-####################
-# ###
-# $# $ ## $ ##
-# $### # $$ ##
-#.### $ $ ## ##
-#...# # # #$ #
-#..##$$#### $ # #
-#...# $ ## ###
-#...$ ### # # #
-##.. $# ## ##@ #
-###.# #
-####################
-;LEVEL 54
-####################
-# # # # #@#
-# $ $ $ # #
-## ###..## ### #
-# #....#$# $### #
-# $ #....# $ $ $ #
-# #....# # # $ $ #
-# ##..## #$# #
-##$## ## # #$##
-# $ $ # # #
-# # # # #
-####################
-;LEVEL 55
-####################
-# @## # ##
-# ## $ $ ##
-# ###....# # # ###
-# #....# # # $ #
-### #...# # #
-## ##.# $ $ #
-## $ $ ### # # ###
-## $ # # $ #
-#### $ $# # # # $ #
-#### # # ##
-####################
-;LEVEL 56
-####################
-# # ## # @###
-## $ # $### #
-##$# $ ##$# $ $ #
-# $# $ ###
-# ## $ ### #....#
-# # $# # # # #....##
-# $ $ # #....###
-##$ ### $ #....####
-# # $ ######
-# # # ######
-####################
-;LEVEL 57
-####################
-#@ ### # # #
-# # # # $ $ #
-##### # $ $#$# #
-#.#..# ##$ $ #
-#..... $ # ##
-#..... ###$##$###
-#.#..# $ # #
-##### # #$ $ #
-##### # $ $ $ #
-##### # # # # #
-####################
-;LEVEL 58
-####################
-##... ## # # #
-#.... $ ## #
-#....# # #$###$ #
-#...# # # #
-##.# #$ # $## #
-# # # $ $ ### $ #
-# $ $ # # ## #
-## # ## #$$# $# # #
-# # $ $ # ##
-# # # # @#
-####################
-;LEVEL 59
-####################
-# # #@# ## #####
-# # # $ $ #####
-# # ###### $ ###
-# # #....# $$ #
-##$##$##....# #
-# #....##$##$##
-# $$ #....# #
-# $ $ # # ### #
-##### $ $ $ #
-##### # # # ##
-####################
-;LEVEL 60
-####################
-# # # #
-# $ ## ### ##
-##### ## $ $ #
-##..## # # $ # # #
-#.... $ ##$# ##
-#.... $##### #$##
-##..# # # # $ #
-###.# # $ $ # @#
-## $ $ # # ####
-## ###########
-####################
-;LEVEL 61
-####################
-# ###..### #
-# $$ ###..### $@ #
-# # ##......# $ #
-# #......# $ #
-#### ###..######$ #
-# $$$ #..# # #
-# $# $ $ $$ #$ #
-# # ## $ ## # #
-# $ $ ## $ $ #
-# # ## ## # #
-####################
-;LEVEL 62
-####################
-# # # # # # #
-# @# # ## $ $ ##
-#### # # # $ #
-# # ## #$ ## ## #
-# $ $ $ #
-#..###$$## $##$ ## #
-#..#.# # $ $ # #
-#....# $$ ##$ ####
-#....# ##### #
-#...### ## #
-####################
-;LEVEL 63
-####################
-#....# # # #
-#....# # $ $ #
-#.... ## $# # $#$ #
-#...# $ $# $ #
-#..#### # $ $$ #
-# #### #### ###
-# # # #
-# ## # $ # $ $ #
-# ## $ ## $ $ #
-# @# # # #
-####################
-;LEVEL 64
-####################
-#....### #
-#....##### # #$# ##
-#....### #$ $ #
-#....### $ #$$##
-## #### $# #$ $ #
-## #### $ $ # #
-#@ ####$###$## $ #
-## # # $ #
-## ### # $ ####
-######## # # #
-####################
-;LEVEL 65
-####################
-# # @#...###
-# # ##...##
-# # # ##$## ## ....#
-# $ # $$$ ....#
-###$### $$ ### ##.#
-# $ # # ####
-# $ # ### # # #
-## #$## $ $$ #
-# $ ## # # # #
-# # # # #
-####################
-;LEVEL 66
-####################
-# # #...#@ #
-# # ....# #
-# $ # #....# #
-# ##$#### ##....# #
-# $ $ # #...# #
-# $$ # # # $$ #
-### $$$# $$ $ #
-# $ # # # $# #
-# $# # $ #
-# # # # # #
-####################
-;LEVEL 67
-####################
-#####@###.##...## #
-#####$ ..#...# #
-#### ......# $ #
-### $ #.....## # ##
-## $$# ##### $ $ #
-## $# $ ## $$ #
-## # # # $ $ #
-## $$ ### #$## #
-## $# $ $ $ ##
-### # # ###
-####################
-;LEVEL 68
-####################
-#@ # # #
-## ### ## #### # ##
-# # # $$ #
-# # # # $ # $ ## ##
-# $ # #$$ # #
-# ### # ## ##
-#..#.# $ # $ # #
-#..#.# $ # ## $$ #
-#....## $$ $ # #
-#.....## # #
-####################
-;LEVEL 69
-####################
-# # # # ##
-# $# $ $ ##...$ $ #
-# $ # ##....# $ #
-# ## $ ##....# $ #
-# $ #....## $ #
-# $## #...# #
-# $$$##$## ### ##
-# # # # # # #
-# $ # $ ## #
-# # #@ #
-####################
-;LEVEL 70
-####################
-# # # # # # #
-# $ $ $ #
-## # #$###$## ## #
-# $ $ # $ #
-# ###$##$# # $ #
-# # $ $ ###### $#
-# $ $$ $ #@#.#...#
-# # # # #.#...#
-# ########## #.....#
-# #.....#
-####################
-;LEVEL 71
-####################
-# # # ## ##
-# $# $ # ## #
-# $ $ #..# $ #
-# $ $ #....# # ##
-# $# #......### $ #
-# # #....# #$ #
-# $ ####..# # #
-## $ ## # # $ $##
-### $ $#@$ $# #
-#### # # #
-####################
-;LEVEL 72
-####################
-# ....# ####
-# .... #
-# # ########## #
-# #$ # ###..#
-# $ #$$### #..#
-# $ ### $ $ #..#
-# $ # $ $ # ##..#
-# # $$ # $ ## ##
-#@## $# $ $ ##
-## ## # ###
-####################
-;LEVEL 73
-####################
-# # #@ # #
-# $$ #$$# # # ## #
-# # $ $ #$$ # #
-## # # # # # # #
-# ## # #
-# # $ # # # #
-# $ #$ # # $ #..#
-##$ # #### #...#
-# $ #....#
-# # # #.....#
-####################
-;LEVEL 74
-####################
-# # ##### #
-## $ # #### $ #
-#### $$ #..# # #
-# $ $ ##..#### ##
-# $ ###.... $$ #
-# #$# ....# # $ #
-# # # $ ..###$# #
-# # $ #..# ## #
-# $# #### # $##
-# # # @# ##
-####################
-;LEVEL 75
-####################
-# # # # #@#
-# $ $ # $ # #
-##$# $### # $$# #
-# # #.### #$ $ #
-# #$#....# # ### #
-# $ #.....## # #
-##$ #.#....#$$ $ #
-# ######..## # # #
-# $ $ ### #
-# # # # #
-####################
-;LEVEL 76
-####################
-# # # # #@## # #
-# $ #
-# ##$# ##### $ # ##
-## ##.....# # #
-##$##$#.....###$#$ #
-# # ##.....# # ##
-# $ ##..## # #
-# $ # $ $ $$$ #
-## $ $# # # $ #
-# ## # # #
-####################
-;LEVEL 77
-###### #####
-# # # #
-# $ #### $ #
-# $ $ #
-# ###@###$ #
-########## ###
-#.. ## #
-#.. ##$ #
-#.. ## $ #
-#.. ## $ #
-#.. $ $ #
-### #########
- ####
-;LEVEL 78
- ###########
- # #
- # $ $ #
-###### # $ ##### #
-# ##### $ ##$#
-# $ $ #
-# ## ## #
-# ##@##### ## #
-# #### # ## ##
-#....# # $ #
-#....# # #
-###### #######
-;LEVEL 79
-#############
-# #
-# ### $$ #
-# # $ $ #
-# $####$######
-# $ ## #####
-# $$ $ ...#
-### ## $$# ...#
- # ## # ...#
- # # ...#
- ###@#############
- ###
-;LEVEL 80
- #################
-###@## ...#
-# # ...#
-# $ # ...#
-# $$ # ...#
-## $ ###$##########
- # ### $ #
-## $ $ #
-# $ # $ #
-# $ # #
-# $ # #
-# # #
-###########
-;LEVEL 81
- #####
- ########## #
- # # #
- # $ $ $$ #
- # ##### ## $ #
- #$$ #$## $ #
- # ### # ##$ #
-###### ### $ $ #
-#.... ## #
-#.... ######
-#.... #
-###########@##
- ###
-;LEVEL 82
- ######
- #### #
- # ## #
- # $ #
-### #### ########
-# $ $ ## ...#
-# $$ $$ ...#
-# $ $## ...#
-##@## ## ## ...#
- ### $ ########
- # $$ #
- # # #
- #########
-;LEVEL 83
-####### #########
-# # # ## #
-# ### # # $ #
-# # $ ### $ #
-# $$ ##$ #
-# #### ## #
-#@############ ##
-###.. #####$ #
- #.. #### #
- #.. $$ #
- #.. #### $ #
- #.. # # #
- ######## #####
-;LEVEL 84
-#######
-# ##########
-# # # ##
-# $ # $ $ #
-# $ # $ ## #
-# $$ ##$ $ #
-## # ## #######
-## # ## ...#
-# #$ ...#
-# $$ ...#
-# ##@# ...#
-################
-;LEVEL 85
-############
-# # ##
-# $ $ # ######
-#### ##### #
- #.. # #### #
- #.#### #### #
- #.... # $ ####
- # ...# # $$$# ##
-###.#### ## $@$ #
-# ##### $ # #
-# #.# $ $###$ #
-# #.######## # $ #
-# #.. ## $ #
-# # ####### $ # # #
-# # # ##
-##### ##########
-;LEVEL 86
-;COMMENT Level 18, with one more box.
-;AUTHOR Michael Bischoff (mbi@flawless.ts.rz.tu-bs.de)
- ###########
- # . # #
- # #. @ #
- ##### ##..# ####
-## #...### ###
-# $ #... $ # $ #
-# .. ## ## ## #
-####$##$# $ # # #
- ## # #$ $$ # #
- # $ #$# # $## #
- # #
- # ########### #
- #### ####
-;LEVEL 87
-;COMMENT ... and two more for level 22.
-;AUTHOR Michael Bischoff (mbi@flawless.ts.rz.tu-bs.de)
-###### ####
-# ####### #####
-# $# # $ # #
-# $ $ $ # $ $ #
-##$ $ # @# $ #
-# $ ########### ##
-# # #.......# $#
-# ## #.......# #
-# # *........$ #
-# # $ #.... ..# #
-# $ $####$#### $#
-# $ $ ### $ $ ##
-# $ $ $ $ $ #
-## ###### $ ##### #
-# # #
-###################
-;LEVEL 88
-;COMMENT One more for 35.
-;AUTHOR Michael Bischoff (mbi@flawless.ts.rz.tu-bs.de)
-############ ######
-# # # ###....#
-# $$# @ .....#
-# # ### # ....#
-## ## ### # ....#
- # $ $ # #.####
- # $ $## # #
-#### # #### # ## #
-# # #$ ## # #
-# $ $ # ## # ##
-# # $ $ # # #
-# $ ## ## # #####
-# $$ $$ # #
-## ## ### $ $ #
- # # # #####
- ###### ######
diff --git a/packages/sql-beeline/sql-beeline.el
b/packages/sql-beeline/sql-beeline.el
deleted file mode 100644
index 4b6fbf9..0000000
--- a/packages/sql-beeline/sql-beeline.el
+++ /dev/null
@@ -1,93 +0,0 @@
-;;; sql-beeline.el --- Beeline support for sql.el -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2020-2020 Free Software Foundation, Inc.
-
-;; Author: Filipp Gunbin <fgunbin@fastmail.fm>
-;; Maintainer: Filipp Gunbin <fgunbin@fastmail.fm>
-;; Version: 0.1
-;; Keywords: sql, hive, beeline, hiveserver2
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;; TODO
-;;
-;; - Recognize prompt for a user when !connect is given only url
-;; - Turn off echo
-;;
-
-;;; Code:
-
-(require 'sql)
-
-
-(defcustom sql-beeline-program "beeline"
- "Command to start the Beeline (HiveServer2 client)."
- :type 'file
- :group 'SQL)
-
-(defcustom sql-beeline-options
- '("--silent" "--incremental=false" "--headerInterval=10000")
- "List of additional options for `sql-beeline-program'."
- :type '(repeat string)
- :group 'SQL)
-
-(defcustom sql-beeline-login-params
- `((user :default ,(user-login-name))
- (database :default "default")
- (server :default "localhost")
- (port :default 10000))
- "List of login parameters needed to connect to HiveServer2."
- :type 'sql-login-params
- :group 'SQL)
-
-
-(defun sql-comint-beeline (product options &optional buf-name)
- "Create comint buffer and connect to HiveServer2."
- (let ((params (append
- (list "-u" (format "jdbc:hive2://%s:%d/%s"
- sql-server sql-port sql-database))
- (unless (string-empty-p sql-user)
- (list "-n" sql-user))
- (unless (string-empty-p sql-password)
- (list "-p" sql-password))
- options))
- ;; TERM=dumb makes jline library (version 2.12 used in Hive
- ;; 1.1.0, for example) to fallback to "unsupported" terminal,
- ;; and in that mode its ConsoleReader emulates password char
- ;; hiding by emitting prompt together with carriage returns
- ;; every few milliseconds - we don't want it because it
- ;; just makes garbage.
- (comint-terminfo-terminal ""))
- (sql-comint product params buf-name)))
-
-;;;###autoload
-(defun sql-beeline (&optional buffer)
- "Run beeline as an inferior process."
- (interactive "P")
- (sql-product-interactive 'beeline buffer))
-
-(sql-add-product
- 'beeline "Beeline"
- :font-lock 'sql-mode-ansi-font-lock-keywords
- :sqli-program 'sql-beeline-program
- :sqli-options 'sql-beeline-options
- :sqli-login 'sql-beeline-login-params
- :sqli-comint-func #'sql-comint-beeline
- :list-all '("show tables;" . "!tables")
- :list-table '("describe %s;" . "!describe %s")
- :prompt-regexp "^[^ .][^>\n]*> "
- :prompt-cont-regexp "^[ .]*> ")
-
-(provide 'sql-beeline)
-;;; sql-beeline.el ends here
diff --git a/packages/stream/stream-x.el b/packages/stream/stream-x.el
deleted file mode 100644
index b4d7dee..0000000
--- a/packages/stream/stream-x.el
+++ /dev/null
@@ -1,150 +0,0 @@
-;;; stream-x.el --- Additional functions for working with streams -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2017 - 2020 Free Software Foundation, Inc
-
-;; Author: Michael Heerdegen <michael_heerdegen@web.de>
-;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
-;; Created: 2017_03_22
-;; Keywords: stream, laziness, sequences
-
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; This file contains additional functions for working with streams.
-
-
-;;; Code:
-
-(require 'stream)
-
-
-(defun stream-substream-before (stream rest)
- "Return a stream of the elements of STREAM before REST.
-
-REST is a rest of STREAM: it must either be `eq' to STREAM or to
-one of the subsequent calls of `stream-rest' on STREAM. The
-return value is a newly created stream containing the first
-elements of STREAM with REST cut off.
-
-When REST appears multiple times as a rest of STREAM, a stream
-with the minimal number of elements is returned."
- (stream-make
- (if (eq stream rest)
- nil
- (cons (stream-first stream)
- (stream-substream-before (stream-rest stream) rest)))))
-
-(defun stream-divide-with-get-rest-fun (stream get-rest-fun)
- "Divide STREAM into two parts according to GET-REST-FUN.
-
-The return value is a list (S R) where R is the result of
-(funcall get-rest-fun STREAM) and S a stream of minimal length so
-that (stream-append S R) is equivalent to STREAM.
-
-Calling GET-REST-FUN on STREAM must be `eq' to one of
-STREAM, (stream-rest STREAM), (stream-rest (stream-rest STREAM)),
-..."
- (let ((rest (funcall get-rest-fun stream)))
- (list (stream-substream-before stream rest) rest)))
-
-(defun stream-divide (stream predicate)
- "Divide STREAM between the first pair of elements for that PREDICATE fails.
-
-When STREAM generates the elements S_1, S_2, ..., call
-(PREDICATE S_i, S_i+1) for i=1,2,... until the first index i=k is
-found so that (funcall PREDICATE S_k S_k+1) returns nil.
-
-The return value is a list of two streams (HEAD REST) where
-HEAD generates the elements S_1, ... S_k and REST is the rest of STREAM
-generating the remaining elements S_k+1, ...
-
-Example:
-
- (mapcar #'seq-into-sequence
- (stream-divide
- (stream (list 1 2 3 5 6 7 9 10 11 23))
- (lambda (this next) (< (- next this) 2))))
-==> ((1 2 3)
- (5 6 7 9 10 11 23))
-
-
-If STREAM is finite and no index k with (funcall PREDICATE S_k S_k+1) ==>
-nil is found, return (STREAM E) where E is an empty stream. When
-STREAM is infinite and no such index is found, this function will not
-terminate.
-
-See `stream-divide-with-get-rest-fun' for a generalization of this function."
- (stream-divide-with-get-rest-fun stream (stream-divide--get-rest-fun
predicate)))
-
-(defun stream-divide--get-rest-fun (pred)
- (lambda (s)
- (unless (stream-empty-p s)
- (while (let ((this (stream-pop s)))
- (unless (stream-empty-p s)
- (funcall pred this (stream-first s))))))
- s))
-
-(defun stream-partition (stream predicate)
- "Partition STREAM into bunches where PREDICATE returns non-nil for
subsequent elements.
-
-The return value is a stream S: S_1, S_2, ... of streams S_i of
-maximal length so that (stream-concatenate S) is equivalent to STREAM
-and for any pair of subsequent elements E, F in any S_i
-(PREDICATE E F) evals to a non-nil value.
-
-Often, but not necessarily, PREDICATE is an equivalence predicate.
-
-Example:
-
- (seq-into-sequence
- (seq-map #'seq-into-sequence
- (stream-partition
- (stream (list 1 2 3 5 6 7 9 10 15 23))
- (lambda (x y) (< (- y x) 2)))))
- ==> ((1 2 3)
- (5 6 7)
- (9 10)
- (15)
- (23))
-
-See `stream-partition-with-get-rest-fun' for a generalization of this
function."
- (stream-partition-with-get-rest-fun stream (stream-divide--get-rest-fun
predicate)))
-
-(defun stream-partition-with-get-rest-fun (stream get-rest-fun)
- "Call `stream-divide-with-get-rest-fun' on stream ad finitum.
-The return value is a (not necessarily finite) stream S of
-streams S_i where (stream-concatenate S) is equivalent to STREAM,
-
- (S_1 R_1) := (stream-divide-with-get-rest-fun STREAM get-rest-fun)
-
-and
-
- (S_i+1 R_i+1) := (stream-divide-with-get-rest-fun R_i get-rest-fun)
-
-as long as R_i is not empty."
- (stream-make
- (if (stream-empty-p stream) nil
- (let ((divided (stream-divide-with-get-rest-fun stream get-rest-fun)))
- (cons (car divided)
- (stream-partition-with-get-rest-fun (cadr divided)
get-rest-fun))))))
-
-
-(provide 'stream-x)
-
-;;; stream-x.el ends here
diff --git a/packages/stream/stream.el b/packages/stream/stream.el
deleted file mode 100644
index eb81b14..0000000
--- a/packages/stream/stream.el
+++ /dev/null
@@ -1,504 +0,0 @@
-;;; stream.el --- Implementation of streams -*- lexical-binding: t -*-
-
-;; Copyright (C) 2016-2020 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Keywords: stream, laziness, sequences
-;; Version: 2.2.5
-;; Package-Requires: ((emacs "25"))
-;; Package: stream
-
-;; Maintainer: nicolas@petton.fr
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library provides an implementation of streams. Streams are
-;; implemented as delayed evaluation of cons cells.
-;;
-;; Functions defined in `seq.el' can also take a stream as input.
-;;
-;; streams could be created from any sequential input data:
-;; - sequences, making operation on them lazy
-;; - a set of 2 forms (first and rest), making it easy to represent infinite
sequences
-;; - buffers (by character)
-;; - buffers (by line)
-;; - buffers (by page)
-;; - IO streams
-;; - orgmode table cells
-;; - ...
-;;
-;; All functions are prefixed with "stream-".
-;; All functions are tested in tests/stream-tests.el
-;;
-;; Here is an example implementation of the Fibonacci numbers
-;; implemented as in infinite stream:
-;;
-;; (defun fib (a b)
-;; (stream-cons a (fib b (+ a b))))
-;; (fib 0 1)
-;;
-;; A note for developers: Please make sure to implement functions that
-;; process streams (build new streams out of given streams) in a way
-;; that no new elements in any argument stream are generated. This is
-;; most likely an error since it changes the argument stream. For
-;; example, a common error is to call `stream-empty-p' on an input
-;; stream and build the stream to return depending on the result.
-;; Instead, delay such tests until elements are requested from the
-;; resulting stream. A way to achieve this is to wrap such tests into
-;; `stream-make' or `stream-delay'. See the implementations of
-;; `stream-append' or `seq-drop-while' for example.
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-(require 'seq)
-
-(eval-and-compile
- (defconst stream--fresh-identifier '--stream-fresh--
- "Symbol internally used to streams whose head was not evaluated.")
- (defconst stream--evald-identifier '--stream-evald--
- "Symbol internally used to streams whose head was evaluated."))
-
-(defmacro stream-make (&rest body)
- "Return a stream built from BODY.
-BODY must return nil or a cons cell whose cdr is itself a
-stream."
- (declare (debug t))
- `(cons ',stream--fresh-identifier (lambda () ,@body)))
-
-(defun stream--force (stream)
- "Evaluate and return the first cons cell of STREAM.
-That value is the one passed to `stream-make'."
- (cond
- ((eq (car-safe stream) stream--evald-identifier)
- (cdr stream))
- ((eq (car-safe stream) stream--fresh-identifier)
- (prog1 (setf (cdr stream) (funcall (cdr stream)))
- ;; identifier is only updated when forcing didn't exit nonlocally
- (setf (car stream) stream--evald-identifier)))
- (t (signal 'wrong-type-argument (list 'streamp stream)))))
-
-(defmacro stream-cons (first rest)
- "Return a stream built from the cons of FIRST and REST.
-FIRST and REST are forms and REST must return a stream."
- (declare (debug t))
- `(stream-make (cons ,first ,rest)))
-
-
-;;; Convenient functions for creating streams
-
-(cl-defgeneric stream (src)
- "Return a new stream from SRC.")
-
-(cl-defmethod stream ((seq sequence))
- "Return a stream built from the sequence SEQ.
-SEQ can be a list, vector or string."
- (if (seq-empty-p seq)
- (stream-empty)
- (stream-cons
- (seq-elt seq 0)
- (stream (seq-subseq seq 1)))))
-
-(cl-defmethod stream ((list list))
- "Return a stream built from the list LIST."
- (if (null list)
- (stream-empty)
- (stream-cons
- (car list)
- (stream (cdr list)))))
-
-(cl-defmethod stream ((buffer buffer) &optional pos)
- "Return a stream of the characters of the buffer BUFFER.
-BUFFER may be a buffer or a string (buffer name).
-The sequence starts at POS if non-nil, `point-min' otherwise."
- (with-current-buffer buffer
- (unless pos (setq pos (point-min)))
- (if (>= pos (point-max))
- (stream-empty))
- (stream-cons
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char pos)
- (char-after (point)))))
- (stream buffer (1+ pos)))))
-
-(declare-function iter-next "generator")
-
-(defun stream-from-iterator (iterator)
- "Return a stream generating new elements through ITERATOR.
-ITERATOR is an iterator object in terms of the \"generator\"
-package."
- (stream-make
- (condition-case nil
- (cons (iter-next iterator) (stream-from-iterator iterator))
- (iter-end-of-sequence nil))))
-
-(defun stream-regexp (buffer regexp)
- (stream-make
- (let (match)
- (with-current-buffer buffer
- (setq match (re-search-forward regexp nil t)))
- (when match
- (cons (match-data) (stream-regexp buffer regexp))))))
-
-(defun stream-range (&optional start end step)
- "Return a stream of the integers from START to END, stepping by STEP.
-If START is nil, it defaults to 0. If STEP is nil, it defaults to
-1. START is inclusive and END is exclusive. If END is nil, the
-range is infinite."
- (unless start (setq start 0))
- (unless step (setq step 1))
- (if (equal start end)
- (stream-empty)
- (stream-cons
- start
- (stream-range (+ start step) end step))))
-
-
-(defun streamp (stream)
- "Return non-nil if STREAM is a stream, nil otherwise."
- (let ((car (car-safe stream)))
- (or (eq car stream--fresh-identifier)
- (eq car stream--evald-identifier))))
-
-(defconst stream-empty (cons stream--evald-identifier nil)
- "The empty stream.")
-
-(defun stream-empty ()
- "Return the empty stream."
- stream-empty)
-
-(defun stream-empty-p (stream)
- "Return non-nil if STREAM is empty, nil otherwise."
- (null (cdr (stream--force stream))))
-
-(defun stream-first (stream)
- "Return the first element of STREAM.
-Return nil if STREAM is empty."
- (car (stream--force stream)))
-
-(defun stream-rest (stream)
- "Return a stream of all but the first element of STREAM."
- (or (cdr (stream--force stream))
- (stream-empty)))
-
-(defun stream-append (&rest streams)
- "Concatenate the STREAMS.
-Requesting elements from the resulting stream will request the
-elements in the STREAMS in order."
- (if (null streams)
- (stream-empty)
- (stream-make
- (let ((first (pop streams)))
- (while (and (stream-empty-p first) streams)
- (setq first (pop streams)))
- (if (stream-empty-p first)
- nil
- (cons (stream-first first)
- (if streams (apply #'stream-append (stream-rest first) streams)
- (stream-rest first))))))))
-
-(defmacro stream-pop (stream)
- "Return the first element of STREAM and set the value of STREAM to its rest."
- (unless (symbolp stream)
- (error "STREAM must be a symbol"))
- `(prog1
- (stream-first ,stream)
- (setq ,stream (stream-rest ,stream))))
-
-
-;;; cl-generic support for streams
-
-(cl-generic-define-generalizer stream--generalizer
- 11
- (lambda (name &rest _)
- `(when (streamp ,name)
- 'stream))
- (lambda (tag &rest _)
- (when (eq tag 'stream)
- '(stream))))
-
-(cl-defmethod cl-generic-generalizers ((_specializer (eql stream)))
- "Support for `stream' specializers."
- (list stream--generalizer))
-
-
-;;; Implementation of seq.el generic functions
-
-(cl-defmethod seqp ((_stream stream))
- t)
-
-(cl-defmethod seq-empty-p ((stream stream))
- (stream-empty-p stream))
-
-(cl-defmethod seq-elt ((stream stream) n)
- "Return the element of STREAM at index N."
- (while (> n 0)
- (setq stream (stream-rest stream))
- (setq n (1- n)))
- (stream-first stream))
-
-(cl-defmethod seq-length ((stream stream))
- "Return the length of STREAM.
-This function will eagerly consume the entire stream."
- (let ((len 0))
- (while (not (stream-empty-p stream))
- (setq len (1+ len))
- (setq stream (stream-rest stream)))
- len))
-
-(cl-defmethod seq-subseq ((stream stream) start &optional end)
- "Return a stream of elements of STREAM from START to END.
-
-END is exclusive. If END is omitted, include all elements from
-START on. Both START and END must be non-negative. Since
-streams are a delayed type of sequences, don't signal an error if
-START or END are larger than the number of elements (the returned
-stream will simply be accordingly shorter, or even empty)."
- (when (or (< start 0) (and end (< end 0)))
- (error "seq-subseq: only non-negative indexes allowed for streams"))
- (let ((stream-from-start (seq-drop stream start)))
- (if end (seq-take stream-from-start (- end start))
- stream-from-start)))
-
-(cl-defmethod seq-into-sequence ((stream stream))
- "Convert STREAM into a sequence."
- (let ((list))
- (seq-doseq (elt stream)
- (push elt list))
- (nreverse list)))
-
-(cl-defmethod seq-into ((stream stream) type)
- "Convert STREAM into a sequence of type TYPE."
- (seq-into (seq-into-sequence stream) type))
-
-(cl-defmethod seq-into ((stream stream) (_type (eql stream)))
- stream)
-
-(cl-defmethod seq-into ((seq sequence) (_type (eql stream)))
- (stream seq))
-
-(cl-defmethod seq-take ((stream stream) n)
- "Return a stream of the first N elements of STREAM."
- (stream-make
- (if (or (zerop n)
- (stream-empty-p stream))
- nil
- (cons
- (stream-first stream)
- (seq-take (stream-rest stream) (1- n))))))
-
-(cl-defmethod seq-drop ((stream stream) n)
- "Return a stream of STREAM without its first N elements."
- (stream-make
- (while (not (or (stream-empty-p stream) (zerop n)))
- (setq n (1- n))
- (setq stream (stream-rest stream)))
- (unless (stream-empty-p stream)
- (cons (stream-first stream)
- (stream-rest stream)))))
-
-(cl-defmethod seq-take-while (pred (stream stream))
- "Return a stream of the successive elements for which (PRED elt) is non-nil
in STREAM."
- (stream-make
- (when (funcall pred (stream-first stream))
- (cons (stream-first stream)
- (seq-take-while pred (stream-rest stream))))))
-
-(cl-defmethod seq-drop-while (pred (stream stream))
- "Return a stream from the first element for which (PRED elt) is nil in
STREAM."
- (stream-make
- (while (not (or (stream-empty-p stream)
- (funcall pred (stream-first stream))))
- (setq stream (stream-rest stream)))
- (unless (stream-empty-p stream)
- (cons (stream-first stream)
- (stream-rest stream)))))
-
-(cl-defmethod seq-map (function (stream stream))
- "Return a stream representing the mapping of FUNCTION over STREAM.
-The elements of the produced stream are the results of the
-applications of FUNCTION on each element of STREAM in succession."
- (stream-make
- (when (not (stream-empty-p stream))
- (cons (funcall function (stream-first stream))
- (seq-map function (stream-rest stream))))))
-
-(cl-defmethod seq-mapn (function (stream stream) &rest streams)
- "Map FUNCTION over the STREAMS.
-
-Example: this prints the first ten Fibonacci numbers:
-
- (letrec ((fibs (stream-cons
- 1
- (stream-cons
- 1
- (seq-mapn #'+ fibs (stream-rest fibs))))))
- (seq-do #'print (seq-take fibs 10)))
-
-\(fn FUNCTION STREAMS...)"
- (if (not (seq-every-p #'streamp streams))
- (cl-call-next-method)
- (cl-labels ((do-mapn (f streams)
- (stream-make
- (unless (seq-some #'stream-empty-p streams)
- (cons (apply f (mapcar #'stream-first streams))
- (do-mapn f (mapcar #'stream-rest
streams)))))))
- (do-mapn function (cons stream streams)))))
-
-(cl-defmethod seq-do (function (stream stream))
- "Evaluate FUNCTION for each element of STREAM eagerly, and return nil.
-
-`seq-do' should never be used on infinite streams without some
-kind of nonlocal exit."
- (while (not (stream-empty-p stream))
- (funcall function (stream-first stream))
- (setq stream (stream-rest stream))))
-
-(cl-defmethod seq-filter (pred (stream stream))
- "Return a stream of the elements for which (PRED element) is non-nil in
STREAM."
- (stream-make
- (while (not (or (stream-empty-p stream)
- (funcall pred (stream-first stream))))
- (setq stream (stream-rest stream)))
- (if (stream-empty-p stream)
- nil
- (cons (stream-first stream)
- (seq-filter pred (stream-rest stream))))))
-
-(defmacro stream-delay (expr)
- "Return a new stream to be obtained by evaluating EXPR.
-EXPR will be evaluated once when an element of the resulting
-stream is requested for the first time, and must return a stream.
-EXPR will be evaluated in the lexical environment present when
-calling this function."
- (let ((stream (make-symbol "stream")))
- `(stream-make (let ((,stream ,expr))
- (if (stream-empty-p ,stream)
- nil
- (cons (stream-first ,stream)
- (stream-rest ,stream)))))))
-
-(cl-defmethod seq-copy ((stream stream))
- "Return a shallow copy of STREAM."
- (stream-delay stream))
-
-
-;;; More stream operations
-
-(defun stream-scan (function init stream)
- "Return a stream of successive reduced values for STREAM.
-
-If the elements of a stream s are s_1, s_2, ..., the elements
-S_1, S_2, ... of the stream returned by \(stream-scan f init s\)
-are defined recursively by
-
- S_1 = init
- S_(n+1) = (funcall f S_n s_n)
-
-as long as s_n exists.
-
-Example:
-
- (stream-scan #\\='* 1 (stream-range 1))
-
-returns a stream of the factorials."
- (let ((res init))
- (stream-cons
- res
- (seq-map (lambda (el) (setq res (funcall function res el)))
- stream))))
-
-(defun stream-flush (stream)
- "Request all elements from STREAM in order for side effects only."
- (while (not (stream-empty-p stream))
- (cl-callf stream-rest stream)))
-
-(defun stream-iterate-function (function value)
- "Return a stream of repeated applications of FUNCTION to VALUE.
-The returned stream starts with VALUE. Any successive element
-will be found by calling FUNCTION on the preceding element."
- (stream-cons
- value
- (stream-iterate-function function (funcall function value))))
-
-(defun stream-concatenate (stream-of-streams)
- "Concatenate all streams in STREAM-OF-STREAMS and return the result.
-All elements in STREAM-OF-STREAMS must be streams. The result is
-a stream."
- (stream-make
- (while (and (not (stream-empty-p stream-of-streams))
- (stream-empty-p (stream-first stream-of-streams)))
- (cl-callf stream-rest stream-of-streams))
- (if (stream-empty-p stream-of-streams)
- nil
- (cons
- (stream-first (stream-first stream-of-streams))
- (stream-concatenate
- (stream-cons (stream-rest (stream-first stream-of-streams))
- (stream-rest stream-of-streams)))))))
-
-(defun stream-of-directory-files-1 (directory &optional nosort recurse
follow-links)
- "Helper for `stream-of-directory-files'."
- (stream-delay
- (if (file-accessible-directory-p directory)
- (let (files dirs (reverse-fun (if nosort #'identity #'nreverse)))
- (dolist (file (directory-files directory t nil nosort))
- (let ((is-dir (file-directory-p file)))
- (unless (and is-dir
- (member (file-name-nondirectory (directory-file-name
file))
- '("." "..")))
- (push file files)
- (when (and is-dir
- (or follow-links (not (file-symlink-p file)))
- (if (functionp recurse) (funcall recurse file)
recurse))
- (push file dirs)))))
- (apply #'stream-append
- (stream (funcall reverse-fun files))
- (mapcar
- (lambda (dir) (stream-of-directory-files-1 dir nosort recurse
follow-links))
- (funcall reverse-fun dirs))))
- (stream-empty))))
-
-(defun stream-of-directory-files (directory &optional full nosort recurse
follow-links filter)
- "Return a stream of names of files in DIRECTORY.
-Call `directory-files' to list file names in DIRECTORY and make
-the result a stream. Don't include files named \".\" or \"..\".
-The arguments FULL and NOSORT are directly passed to
-`directory-files'.
-
-Third optional argument RECURSE non-nil means recurse on
-subdirectories. If RECURSE is a function, it should be a
-predicate accepting one argument, an absolute file name of a
-directory, and return non-nil when the returned stream should
-recurse into that directory. Any other non-nil value means
-recurse into every readable subdirectory.
-
-Even with recurse non-nil, don't descent into directories by
-following symlinks unless FOLLOW-LINKS is non-nil.
-
-If FILTER is non-nil, it should be a predicate accepting one
-argument, an absolute file name. It is used to limit the
-resulting stream to the files fulfilling this predicate."
- (let* ((stream (stream-of-directory-files-1 directory nosort recurse
follow-links))
- (filtered-stream (if filter (seq-filter filter stream) stream)))
- (if full filtered-stream
- (seq-map (lambda (file) (file-relative-name file directory))
filtered-stream))))
-
-(provide 'stream)
-;;; stream.el ends here
diff --git a/packages/stream/tests/stream-tests.el
b/packages/stream/tests/stream-tests.el
deleted file mode 100644
index f2772f2..0000000
--- a/packages/stream/tests/stream-tests.el
+++ /dev/null
@@ -1,312 +0,0 @@
-;;; stream-tests.el --- Unit tests for stream.el -*- lexical-binding: t -*-
-
-;; Copyright (C) 2015, 2017-2020 Free Software Foundation, Inc.
-
-;; Author: Nicolas Petton <nicolas@petton.fr>
-
-;; Maintainer: emacs-devel@gnu.org
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;; Code:
-
-(require 'ert)
-(require 'stream)
-(require 'generator)
-(require 'cl-lib)
-
-(ert-deftest stream-empty-test ()
- (should (streamp (stream-empty)))
- (should (stream-empty-p (stream-empty))))
-
-(ert-deftest stream-seq-empty-test ()
- (should (seq-empty-p (stream-empty)))
- (should-not (seq-empty-p (stream-range))))
-
-(ert-deftest stream-make-test ()
- (should (streamp (stream-range)))
- (should (not (stream-empty-p (stream-range))))) ;; Should use stream-list or
something
-
-(ert-deftest stream-first-test ()
- (should (= 3 (stream-first (stream-range 3))))
- (should (null (stream-first (stream-empty)))))
-
-(ert-deftest stream-rest-test ()
- (should (= 4 (stream-first (stream-rest (stream-range 3)))))
- (should (= 5 (stream-first (stream-rest (stream-rest (stream-range 3)))))))
-
-(ert-deftest stream-from-iterator-test ()
- (skip-unless (require 'generator nil t))
- (should (equal '(1 2)
- (seq-into-sequence
- (stream-from-iterator
- (funcall (iter-lambda ()
- (iter-yield 1)
- (iter-yield 2))))))))
-
-(ert-deftest stream-append-test ()
- (should (stream-empty-p (stream-append)))
- (should (let ((list '(1 2)))
- (equal list (seq-into-sequence (stream-append (stream list))))))
- (should (= (seq-elt (stream-append
- (stream (list 0 1))
- (stream-range 2))
- 4)
- 4))
- (should (let ((stream (stream (list 0))))
- (and (= (seq-elt (stream-append stream (stream-range 1)) 10)
- 10)
- (stream-empty-p (stream-rest stream)))))
- (should (equal (seq-into-sequence
- (stream-append
- (stream '(1))
- (stream '())
- (stream '(2 3))))
- '(1 2 3))))
-
-(ert-deftest stream-seqp-test ()
- (should (seqp (stream-range))))
-
-(ert-deftest stream-seq-elt-test ()
- (should (null (seq-elt (stream-empty) 0)))
- (should (= 0 (seq-elt (stream-range) 0)))
- (should (= 1 (seq-elt (stream-range) 1)))
- (should (= 10 (seq-elt (stream-range) 10))))
-
-(ert-deftest stream-seq-length-test ()
- (should (zerop (seq-length (stream-empty))))
- (should (= 10 (seq-length (stream-range 0 10)))))
-
-(ert-deftest stream-seq-doseq-test ()
- (let ((stream (stream '(a b c d)))
- (lst '()))
- (seq-doseq (elt stream)
- (push elt lst))
- (should (equal '(d c b a) lst))))
-
-(ert-deftest stream-seq-let-test ()
- (seq-let (first _ third &rest rest) (stream-range 2 7)
- (should (= first 2))
- (should (= third 4))
- ;; The rest of the stream shouldn't be consumed
- (should (streamp rest))
- (should (= 5 (stream-first rest)))
- (should (= 6 (stream-first (stream-rest rest))))
- (should (stream-empty-p (stream-rest (stream-rest rest))))))
-
-(ert-deftest stream-seq-subseq-test ()
- (should (equal (seq-into (seq-subseq (stream (list 0 1 2 3 4)) 1 3) 'list)
- (seq-subseq (list 0 1 2 3 4) 1 3)))
- (should (= (stream-first (seq-subseq (stream-range 0) 5))
- 5))
- (should (= (stream-first (seq-subseq (seq-subseq (stream-range 0) 5) 5))
- 10))
-
- (should-error (seq-subseq (stream-range 0) -1)))
-
-(ert-deftest stream-seq-into-test ()
- (should (streamp (seq-into (stream-empty) 'stream)))
- (should (streamp (seq-into '(2 4 5) 'stream)))
- (should (= 2 (stream-first (seq-into '(2 4 5) 'stream))))
- (should (null (seq-into (stream-empty) 'list)))
- (should (equal '(0 1 2 3 4 5 6 7 8 9) (seq-into (stream-range 0 10) 'list))))
-
-(ert-deftest stream-seq-take-test ()
- (should (streamp (seq-take (stream-range) 2)))
- (should (= 0 (stream-first (seq-take (stream-range) 2))))
- (should (= 1 (stream-first (stream-rest (seq-take (stream-range) 2)))))
- (should (null (stream-first (stream-rest (stream-rest (seq-take
(stream-range) 2))))))
- (should (stream-empty-p (stream-rest (stream-rest (seq-take (stream-range)
2))))))
-
-(ert-deftest stream-seq-drop-test ()
- (should (streamp (seq-drop (stream-range) 2)))
- (should (= 2 (stream-first (seq-drop (stream-range) 2))))
- (should (= 3 (stream-first (stream-rest (seq-drop (stream-range) 2)))))
- (should (stream-empty-p (seq-drop (stream-empty) 2))))
-
-(ert-deftest stream-seq-take-while-test ()
- (let ((stream (stream '(1 3 2 5))))
- (should (stream-empty-p (seq-take-while #'identity (stream-empty))))
- (should (streamp (seq-take-while #'cl-oddp stream)))
- (should (= 1 (stream-first (seq-take-while #'cl-oddp stream))))
- (should (= 3 (stream-first (stream-rest (seq-take-while #'cl-oddp
stream)))))
- (should (stream-empty-p (stream-rest (stream-rest (seq-take-while
#'cl-oddp stream)))))))
-
-(ert-deftest stream-seq-drop-while-test ()
- (let ((stream (stream '(1 3 2 5))))
- (should (streamp (seq-drop-while #'cl-evenp stream)))
- (should (stream-empty-p (seq-drop-while #'identity (stream-empty))))
- (should (= 2 (stream-first (seq-drop-while #'cl-evenp stream))))
- (should (= 5 (stream-first (stream-rest (seq-drop-while #'cl-evenp
stream)))))
- (should (stream-empty-p (stream-rest (stream-rest (seq-drop-while
#'cl-evenp stream)))))))
-
-(ert-deftest stream-seq-map-test ()
- (should (stream-empty-p (seq-map #'- (stream-empty))))
- (should (= -1 (stream-first (seq-map #'- (stream-range 1)))))
- (should (= -2 (stream-first (stream-rest (seq-map #'- (stream-range 1)))))))
-
-(ert-deftest stream-seq-mapn-test ()
- (should (streamp (seq-mapn #'+ (stream (list 1 2 3)) (stream (list 4 5 6)))))
- (should (not (streamp (seq-mapn #'+ (stream (list 1 2 3)) (stream (list 4 5
6)) (list 7 8 9)))))
- (should (= 2 (seq-length (seq-mapn #'+ (stream (list 1 2 3)) (stream (list 4
5))))))
- (should (equal (letrec ((fibs (stream-cons
- 1
- (stream-cons
- 1
- (seq-mapn #'+ fibs (stream-rest fibs))))))
- (seq-into (seq-take fibs 10) 'list))
- '(1 1 2 3 5 8 13 21 34 55))))
-
-(ert-deftest stream-seq-do-test ()
- (let ((result '()))
- (seq-do
- (lambda (elt)
- (push elt result))
- (stream-range 0 5))
- (should (equal result '(4 3 2 1 0)))))
-
-(ert-deftest stream-seq-filter-test ()
- (should (stream-empty-p (seq-filter #'cl-oddp (stream-empty))))
- (should (stream-empty-p (seq-filter #'cl-oddp (stream-range 0 4 2))))
- (should (= 1 (stream-first (seq-filter #'cl-oddp (stream-range 0 4)))))
- (should (= 3 (stream-first (stream-rest (seq-filter #'cl-oddp (stream-range
0 4))))))
- (should (stream-empty-p (stream-rest (stream-rest (seq-filter #'cl-oddp
(stream-range 0 4)))))))
-
-(ert-deftest stream-delay-test ()
- (should (streamp (stream-delay (stream-range))))
- (should (= 0 (stream-first (stream-delay (stream-range)))))
- (should (= 1 (stream-first (stream-rest (stream-delay (stream-range))))))
- (should (let ((stream (stream-range 3 7)))
- (equal (seq-into (stream-delay stream) 'list)
- (seq-into stream 'list))))
- (should (null (seq-into (stream-delay (stream-empty)) 'list)))
- (should (let* ((evaluated nil)
- (one-plus (lambda (el)
- (setq evaluated t)
- (1+ el)))
- (stream (seq-map one-plus (stream '(1)))))
- (equal '(nil 2 t)
- (list evaluated (stream-first stream) evaluated))))
- (should (let* ((a 0)
- (set-a (lambda (x) (setq a x)))
- (s (stream-delay (stream (list a))))
- res1 res2)
- (funcall set-a 5)
- (setq res1 (stream-first s))
- (funcall set-a 11)
- (setq res2 (stream-first s))
- (and (equal res1 5)
- (equal res2 5)))))
-
-(ert-deftest stream-seq-copy-test ()
- (should (streamp (seq-copy (stream-range))))
- (should (= 0 (stream-first (seq-copy (stream-range)))))
- (should (= 1 (stream-first (stream-rest (seq-copy (stream-range))))))
- (should (let ((stream (stream-range 3 7)))
- (equal (seq-into (seq-copy stream) 'list)
- (seq-into stream 'list))))
- (should (null (seq-into (seq-copy (stream-empty)) 'list))))
-
-(ert-deftest stream-range-test ()
- (should (stream-empty-p (stream-range 0 0)))
- (should (stream-empty-p (stream-range 3 3)))
- (should (= 0 (stream-first (stream-range 0 6 2))))
- (should (= 2 (stream-first (stream-rest (stream-range 0 6 2)))))
- (should (= 4 (stream-first (stream-rest (stream-rest (stream-range 0 6
2))))))
- (should (stream-empty-p (stream-rest (stream-rest (stream-rest (stream-range
0 6 2))))))
- (should (= -4 (stream-first (stream-rest (stream-rest (stream-range 0 nil
-2)))))))
-
-(ert-deftest stream-list-test ()
- (dolist (list '(nil '(1 2 3) '(a . b)))
- (should (equal list (seq-into (stream list) 'list)))))
-
-(ert-deftest stream-seq-subseq-test ()
- (should (stream-empty-p (seq-subseq (stream-range 2 10) 0 0)))
- (should (= (stream-first (seq-subseq (stream-range 2 10) 0 3)) 2))
- (should (= (seq-length (seq-subseq (stream-range 2 10) 0 3)) 3))
- (should (= (seq-elt (seq-subseq (stream-range 2 10) 0 3) 2) 4))
- (should (= (stream-first (seq-subseq (stream-range 2 10) 1 3)) 3))
- (should (= (seq-length (seq-subseq (stream-range 2 10) 1 3)) 2))
- (should (= (seq-elt (seq-subseq (stream-range 2 10) 1 3) 1) 4)))
-
-(ert-deftest stream-pop-test ()
- (let* ((str (stream '(1 2 3)))
- (first (stream-pop str))
- (stream-empty (stream-empty)))
- (should (= 1 first))
- (should (= 2 (stream-first str)))
- (should (null (stream-pop stream-empty)))))
-
-(ert-deftest stream-scan-test ()
- (should (eq (seq-elt (stream-scan #'* 1 (stream-range 1)) 4) 24)))
-
-(ert-deftest stream-flush-test ()
- (should (let* ((times 0)
- (count (lambda () (cl-incf times))))
- (letrec ((make-test-stream (lambda () (stream-cons (progn (funcall
count) nil)
- (funcall
make-test-stream)))))
- (stream-flush (seq-take (funcall make-test-stream) 5))
- (eq times 5)))))
-
-(ert-deftest stream-iterate-function-test ()
- (should (equal (list 0 1 2) (seq-into-sequence (seq-take
(stream-iterate-function #'1+ 0) 3)))))
-
-(ert-deftest stream-concatenate-test ()
- (should (equal (seq-into-sequence
- (stream-concatenate
- (stream (list (stream (list 1 2 3))
- (stream (list))
- (stream (list 4))
- (stream (list 5 6 7 8 9))))))
- (list 1 2 3 4 5 6 7 8 9))))
-
-;; Tests whether calling stream processing functions ("transducers")
-;; doesn't generate elements from argument streams
-
-(defvar this-delayed-stream-function nil)
-
-(defun make-delayed-test-stream ()
- (stream-make
- (cons (prog1 1 (error "`%s' not completely delayed"
this-delayed-stream-function))
- (make-delayed-test-stream))))
-
-(defmacro deftest-for-delayed-evaluation (call)
- (let ((function (car call)))
- `(ert-deftest ,(intern (concat (symbol-name function) "-delayed-test")) ()
- (let ((this-delayed-stream-function ',function))
- (should (prog1 t ,call))))))
-
-(deftest-for-delayed-evaluation (streamp (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seqp (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (stream-append (make-delayed-test-stream)
(make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-take (make-delayed-test-stream) 2))
-(deftest-for-delayed-evaluation (seq-drop (make-delayed-test-stream) 2))
-(deftest-for-delayed-evaluation (seq-take-while #'numberp
(make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-map #'identity
(make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-mapn #'cons
- (make-delayed-test-stream)
- (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-filter #'cl-evenp
(make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (stream-delay (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-copy (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (seq-subseq (make-delayed-test-stream) 2))
-(deftest-for-delayed-evaluation (stream-scan #'* 1 (make-delayed-test-stream)))
-(deftest-for-delayed-evaluation (stream-concatenate (stream (list
(make-delayed-test-stream)
-
(make-delayed-test-stream)))))
-
-(provide 'stream-tests)
-;;; stream-tests.el ends here
diff --git a/packages/svg-clock/svg-clock.el b/packages/svg-clock/svg-clock.el
deleted file mode 100644
index 454c66b..0000000
--- a/packages/svg-clock/svg-clock.el
+++ /dev/null
@@ -1,320 +0,0 @@
-;;; svg-clock.el --- Analog clock using Scalable Vector Graphics -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2011, 2014 Free Software Foundation, Inc.
-
-;; Maintainer: Ulf Jasper <ulf.jasper@web.de>
-;; Author: Ulf Jasper <ulf.jasper@web.de>
-;; Created: 22. Sep. 2011
-;; Keywords: demo, svg, clock
-;; Version: 1.2
-;; Package-Requires: ((svg "1.0") (emacs "27.0"))
-
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; svg-clock provides a scalable analog clock. Rendering is done by
-;; means of svg (Scalable Vector Graphics). In order to use svg-clock
-;; you need to build Emacs with svg support. (To check whether your
-;; Emacs supports svg, do "M-: (image-type-available-p 'svg) RET"
-;; which must return t).
-
-;; Call `svg-clock' to start a clock. This will open a new buffer
-;; "*clock*" displaying a clock which fills the buffer's window. Use
-;; `svg-clock-insert' to insert a clock programmatically in any
-;; buffer, possibly specifying the clock's size, colours and offset to
-;; the current-time. Arbitrary many clocks can be displayed
-;; independently. Clock instances ared updated automatically. Their
-;; resources (timers etc.) are cleaned up automatically when the
-;; clocks are removed.
-
-;;; News:
-
-;; Version 1.0
-;; New function `svg-clock-insert'. Removed customization
-;; options.
-
-;; Version 0.5
-;; Fixes (image-mode issue etc.).
-
-;; Version 0.3
-;; Fixes (disable buffer undo).
-
-;; Version 0.2
-;; Automatic fitting of clock to window size.
-
-;; Version 0.1
-;; Initial version.
-
-;;; Code:
-(defconst svg-clock-version "1.1" "Version number of `svg-clock'.")
-
-(require 'dom)
-(require 'svg)
-(require 'cl-macs)
-(require 'time-date)
-
-(cl-defstruct svg-clock-handle
- marker ;; points to the clock's buffer and position
- overlay ;; holds the clock's image
- timer) ;; takes care of updating the clock
-
-(defun svg-clock--create-def-elements (foreground background no-face)
- "Return a list of SVG elements using the colors FOREGROUND and BACKGROUND.
-The elements are supposed to be added to an SVG object as `defs'.
-The SVG may then `use': `clock-face', `second-hand', `minute-hand'
-and `hour-hand'. The clock-face has a size of 1x1."
- (list (svg-clock-symbol 'tickshort
- (svg-clock-line .5 .02 .5 .04
- `(stroke . ,foreground)
- '(stroke-width . .01)))
- (svg-clock-symbol 'ticklong
- (svg-clock-line .5 .02 .5 .09
- `(stroke . ,foreground)
- '(stroke-width . .02)))
- (svg-clock-symbol 'hour-hand
- (svg-clock-line .5 .22 .5 .54
- `(stroke . ,foreground)
- '(stroke-width . .04)))
- (svg-clock-symbol 'minute-hand
- (svg-clock-line .5 .12 .5 .55
- `(stroke . ,foreground)
- '(stroke-width . .03)))
- (svg-clock-symbol 'second-hand
- (svg-clock-line .5 .1 .5 .56
- `(stroke . ,foreground)
- '(stroke-width . 0.005)))
- (svg-clock-symbol 'hand-cap
- (svg-clock-circle .5 .5 .03
- `(stroke . "none")
- `(fill . ,foreground)))
- (svg-clock-symbol 'background
- (svg-clock-circle .5 .5 .49
- `(stroke . "none")
- `(fill . ,background)))
- (apply 'svg-clock-group 'clock-face
- (nconc (list (svg-clock-use 'background)
- (svg-clock-use 'hand-cap))
- (and (not no-face)
- (mapcar (lambda (angle)
- (svg-clock-use (if (= 0 (% angle 30))
- 'ticklong
- 'tickshort)
- (svg-clock-transform
- 'rotate angle .5 .5)))
- (number-sequence 0 354 6)))))))
-
-(defun svg-clock--create-svg (time size foreground background
- no-seconds no-face)
- "Return an SVG element displaying an analog clock.
-The clock shows the given TIME, it has a diameter of SIZE, and
-its colors are FOREGROUND and BACKGROUND."
- (interactive)
- (let* ((defs (svg-clock--create-def-elements foreground background
- no-face))
- (svg (svg-create size size))
- (seconds (nth 0 time))
- (minutes (nth 1 time))
- (hours (nth 2 time))
- (clock (apply
- #'svg-clock-group
- 'clock
- `(,(svg-clock-use 'clock-face)
- ,@(unless no-seconds
- (list (svg-clock-use 'second-hand
- (svg-clock-transform
- 'rotate
- (* seconds 6) .5 .5))))
- ,(svg-clock-use 'minute-hand
- (svg-clock-transform
- 'rotate
- (+ (* minutes 6) (/ seconds 10.0)) .5 .5))
- ,(svg-clock-use 'hour-hand
- (svg-clock-transform
- 'rotate
- (+ (* hours 30) (/ minutes 2.0))
- .5 .5))))))
- (dolist (def defs) (svg-clock-def svg def))
- (svg-clock-def svg clock)
- (dom-append-child svg
- (svg-clock-use 'clock
- (svg-clock-transform 'scale size size)))
- svg))
-
-(defun svg-clock--window-size ()
- "Return maximal size for displaying the svg clock."
- (save-excursion
- (let ((clock-win (get-buffer-window "*clock*")))
- (if clock-win
- (let* ((coords (window-inside-pixel-edges clock-win))
- (width (- (nth 2 coords) (nth 0 coords)))
- (height (- (nth 3 coords) (nth 1 coords))))
- (min width height))
- ;; fallback
- 100))))
-
-(defvar svg-clock--prev-update (make-decoded-time))
-
-(defun svg-clock--do-create (size foreground background &optional offset
- no-seconds no-face)
- "Create an SVG element.
-See `svg-clock-insert' for meaning of arguments SIZE, FOREGROUND, BACKGROUND
-and OFFSET."
- (let ((time (decode-time (if offset
- (time-add (current-time)
- (seconds-to-time offset))
- (current-time)))))
- ;; If we're not using seconds, then don't update the display until
- ;; the minute changes.
- (when (or (not no-seconds)
- (not (equal (decoded-time-minute svg-clock--prev-update)
- (decoded-time-minute time))))
- (setq svg-clock--prev-update time)
- (let* ((size (or size (svg-clock--window-size)))
- (svg (svg-clock--create-svg time size foreground background
- no-seconds no-face)))
- svg))))
-
-(defun svg-clock--update (clock-handle &optional size foreground background
- offset no-seconds no-face)
- "Update the clock referenced as CLOCK-HANDLE.
-See `svg-clock-insert' for meaning of optional arguments SIZE, FOREGROUND,
-BACKGROUND and OFFSET."
- (when clock-handle
- (let* ((marker (svg-clock-handle-marker clock-handle))
- (buf (marker-buffer marker))
- (win (get-buffer-window buf))
- (ovl (svg-clock-handle-overlay clock-handle)))
- (if (and (buffer-live-p buf)
- (not (eq (overlay-start ovl)
- (overlay-end ovl))))
- (when (pos-visible-in-window-p marker win t)
- (with-current-buffer buf
- (when-let ((svg (svg-clock--do-create
- size foreground background offset
- no-seconds no-face)))
- (overlay-put ovl 'display (create-image
- (with-temp-buffer
- (svg-print svg)
- (buffer-string))
- 'svg t
- :ascent 'center
- :scale 1)))))
- ;; Buffer no longer exists.
- (message "Cancelling clock timer")
- (cancel-timer (svg-clock-handle-timer clock-handle))
- (delete-overlay ovl)))))
-
-;;;###autoload
-(defun svg-clock-insert (&optional size foreground background offset
- no-seconds no-face)
- "Insert a self-updating image displaying an analog clock at point.
-Optional argument SIZE the size of the clock in pixels.
-Optional argument FOREGROUND the foreground color.
-Optional argument BACKGROUND the background color.
-Optional argument OFFSET the offset in seconds between current and displayed
-time.
-Optional argument NO-SECONDS says whether to do a seconds hand.
-Optional argument NO-FACE says whether to decorate the face."
- (let* ((fg (or foreground (face-foreground 'default)))
- (bg (or background (face-background 'default)))
- (marker (point-marker))
- (ch (make-svg-clock-handle :marker marker))
- timer
- ovl)
- (setq svg-clock--prev-update (make-decoded-time))
- (insert "*")
- (setq ovl (make-overlay (marker-position marker)
- (1+ (marker-position marker))
- nil t))
- (setf (svg-clock-handle-overlay ch) ovl)
- (setq timer (run-at-time 0 1
- (lambda ()
- (svg-clock--update ch size fg bg offset
- no-seconds no-face))))
- (setf (svg-clock-handle-timer ch) timer)))
-
-(defvar svg-clock-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [?+] 'svg-clock-grow)
- (define-key map [?-] 'svg-clock-shrink)
- map))
-
-;;;###autoload
-(cl-defun svg-clock (&key size foreground background no-seconds no-face)
- "Start/stop the svg clock."
- (interactive)
- (switch-to-buffer (get-buffer-create "*clock*"))
- (let ((inhibit-read-only t))
- (buffer-disable-undo)
- (erase-buffer)
- (svg-clock-insert size foreground background nil no-seconds no-face)
- (view-mode)))
-
-;; Move to svg.el?
-(defun svg-clock-symbol (id value)
- "Create an SVG symbol element with given ID and VALUE."
- (dom-node 'symbol `((id . ,id)) value))
-
-(defun svg-clock-circle (x y radius &rest attributes)
- "Create an SVG circle element at position X Y with given RADIUS.
-Optional argument ATTRIBUTES contain conses with SVG attributes."
- (dom-node 'circle
- `((cx . ,x)
- (cy . ,y)
- (r . ,radius)
- ,@attributes)))
-
-(defun svg-clock-def (svg def)
- (dom-append-child (or (dom-by-tag svg 'defs)
- (let ((node (dom-node 'defs)))
- (dom-add-child-before svg node) node))
- def)
- svg)
-
-(defun svg-clock-line (x1 y1 x2 y2 &rest attributes)
- "Create an SVG line element starting at (X1, Y1), ending at (X2, Y2).
-Optional argument ATTRIBUTES contain conses with SVG attributes."
- (dom-node 'line `((x1 . ,x1)
- (y1 . ,y1)
- (x2 . ,x2)
- (y2 . ,y2)
- ,@attributes)))
-
-(defun svg-clock-group (id &rest children)
- "Create an SVG group element with given ID and CHILDREN."
- (apply 'dom-node 'g `((id . ,id)) children))
-
-(defun svg-clock-use (id &rest attributes)
- "Create an SVG use element with given ID.
-Optional argument ATTRIBUTES contain conses with SVG attributes."
- (dom-node 'use `((xlink:href . ,(format "#%s" id)) ,@attributes)))
-
-(defun svg-clock-transform (action &rest args)
- "Create an SVG transform attribute element for given ACTION.
-Argument ARGS contain the action's arguments."
- (cons 'transform
- (format "%s(%s)" action (mapconcat 'number-to-string args ", "))))
-
-(defun svg-clock-color-to-hex (color)
- "Return hex representation of COLOR."
- (let ((values (color-values color)))
- (format "#%02x%02x%02x" (nth 0 values) (nth 1 values) (nth 2 values))))
-
-
-(provide 'svg-clock)
-
-;;; svg-clock.el ends here
diff --git a/packages/systemd/systemctl.el b/packages/systemd/systemctl.el
deleted file mode 100644
index b4f21e5..0000000
--- a/packages/systemd/systemctl.el
+++ /dev/null
@@ -1,317 +0,0 @@
-;;; systemctl.el --- Emacs interface to Systemd -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Mario Lang <mlang@delysid.org>
-;; Keywords:
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library provides a front end to Systemd.
-;;
-;; Use `M-x systemctl-list-units RET' to see a list of all known
-;; Systemd units and their status on localhost. With a prefix
-;; argument (`C-u M-x systemctl-list-units RET') you will be prompted
-;; for a remote host to connect to.
-;;
-;; In systemctl-list-units-mode, `RET' will visit all relevant
-;; configuration fragments for the unit at point (the equivalent of
-;; "systemctl cat some.service"). With a `C-u' prefix argument, it
-;; will prompt for a new override.conf file to create (somewhat
-;; equivalent to "systemctl edit some.service"). Contrary to the
-;; command-line "systemctl" tool, systemctl.el allows viewing and
-;; editing of remote unit files thanks to TRAMP.
-;;
-;; Key bindings `s t a r t' and `s t o p' can be used to start and stop
-;; services. Similarily, `e n a b l e' and `d i s a b l e' can be used to
-;; permanently enable and disable unit files.
-
-;;; Granting access to non-root users:
-
-;; Some operations are obviously not allowed when executed from within a
-;; non-root Emacs session. If you want to explicitly grant access to certain
-;; users, you can create a polkit localauthority configuration file.
-;; Below is an example. You might want to change the group name, or use
-;; "unix-user" instead.
-;;
-;; /etc/polkit-1/localauthority/50-local.d/10-systemd.pkla:
-;;
-;; [Normal Staff Permissions]
-;; Identity=unix-group:sudo
-;; Action=org.freedesktop.systemd1.*
-;; ResultAny=no
-;; ResultInactive=no
-;; ResultActive=yes
-
-;;; Todo:
-
-;; * Have someone with window/frame-fu see if there is a better way to
-;; visit N files in a frame, each in a separate window. The current approach
-;; feels a bit crude, see `systemctl-edit-unit-files'.
-;; * Optionally automatically reload the Systemd daemon when a unit buffer is
-;; saved.
-;; * Detect if we are not root, and use the sudo method to edit
-;; system files on localhost.
-;; * Add support for local and remote systemd user sessions.
-;; * Figure out what's necessary to support local and remote containers.
-;; * Menu entries for `systemctl-list-units-mode'.
-
-;;; Code:
-
-(require 'systemd)
-(require 'tabulated-list)
-(require 'tramp)
-
-(defgroup systemctl nil
- "Interface to Systemd.")
-
-(defcustom systemctl-default-override-file-name "override.conf"
- "Default file name for new override.conf files."
- :group 'systemctl
- :type 'string)
-
-(defcustom systemctl-list-units-format
- (vector (list "Unit" 22 t)
- (list "Loaded" 9 t)
- (list "Active" 8 t)
- (list "State" 8 t)
- (list "Description" 50 nil))
- "Column format specification for the `systemctl-list-units' command."
- :group 'systemctl
- :type '(vector (list :tag "Unit"
- (string :tag "Title")
- (number :tag "Width")
- (boolean :tag "Sortable"))
- (list :tag "Loaded"
- (string :tag "Title")
- (number :tag "Width")
- (boolean :tag "Sortable"))
- (list :tag "Active"
- (string :tag "Title")
- (number :tag "Width")
- (boolean :tag "Sortable"))
- (list :tag "State"
- (string :tag "Title")
- (number :tag "Width")
- (boolean :tag "Sortable"))
- (list :tag "Description"
- (string :tag "Title")
- (number :tag "Width")
- (boolean :tag "Sortable"))))
-
-(defcustom systemctl-tramp-method "scpx"
- "The TRAMP method to use when remotely accessing Systemd Unit files."
- :group 'systemctl
- :type (cons 'choice
- (mapcar (lambda (method)
- (list 'const (car method)))
- tramp-methods)))
-
-(defvar-local systemctl-bus :system
- "Default D-Bus bus to use when accessing Systemd.
-You should use the function `systemctl-bus' to retrieve the value of this
-variable to make sure the bus is properly initialized in case it is pointing
-to a remote machine.")
-
-(defvar systemctl-list-units-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-m" #'systemctl-edit-unit-files)
- (define-key map "f" #'systemctl-find-fragment)
- (define-key map "start" #'systemctl-start)
- (define-key map "stop" #'systemctl-stop)
- (define-key map "enable" #'systemctl-enable)
- (define-key map "disable" #'systemctl-disable)
- map)
- "Keymap for `systemctl-list-units-mode'.")
-
-(defun systemctl-bus ()
- (when (stringp systemctl-bus)
- (dbus-init-bus systemctl-bus))
- systemctl-bus)
-
-(defun systemctl-list-units-entries ()
- "Retrieve a list of units known to Systemd.
-See `systemctl-list-units-format' and `tabulated-list-entries'."
- (mapcar (lambda (desc)
- (list (nth 6 desc)
- (vector (nth 0 desc)
- (nth 2 desc)
- (nth 3 desc)
- (nth 4 desc)
- (nth 1 desc))))
- (systemd-ListUnits (systemctl-bus))))
-
-(defun systemctl-unescape-unit-name (string)
- (while (string-match "\\\\x\\([0-9a-f]\\{2\\}\\)" string)
- (setq string
- (replace-match (string (string-to-number (match-string 1 string) 16))
- t t string)))
- string)
-
-(defun systemctl-list-units-print-entry (id cols)
- "Insert a Systemd Units List entry at point.
-See `tabulated-list-printer'."
- (let ((beg (point))
- (x (max tabulated-list-padding 0))
- (inhibit-read-only t))
- (when (> x 0) (insert (make-string x ?\s)))
- (dotimes (n (length tabulated-list-format))
- (let ((desc (aref cols n)))
- (when (= n 0)
- (setq desc (systemctl-unescape-unit-name desc)))
- (setq x (tabulated-list-print-col n desc x))))
- (insert ?\n)
- (put-text-property beg (point) 'tabulated-list-id id)
- (put-text-property beg (point) 'tabulated-list-entry cols)))
-
-(define-derived-mode systemctl-list-units-mode tabulated-list-mode
- "Systemd-Units"
- "Major mode for displaying a list of Systemd Units."
- (setq tabulated-list-entries #'systemctl-list-units-entries
- tabulated-list-format systemctl-list-units-format
- tabulated-list-printer #'systemctl-list-units-print-entry)
- (tabulated-list-init-header))
-
-;;;###autoload
-(defun systemctl-list-units (&optional host)
- "Display a list of all Systemd Units."
- (interactive
- (list (when (equal current-prefix-arg '(4))
- (read-string "Remote host: "))))
-
- (with-current-buffer (let ((buffer-name (if host
- (format "*Systemd Units (%s)*"
- host)
- "*Systemd Units*")))
- (get-buffer-create buffer-name))
- (systemctl-list-units-mode)
- (when host
- (setq systemctl-bus (systemd-remote-bus host)
- default-directory (systemctl-file-name "/etc/systemd/")))
- (tabulated-list-print)
- (pop-to-buffer (current-buffer))))
-
-(defun systemctl-list-units-get-unit ()
- (when (eq major-mode 'systemctl-list-units-mode)
- (let ((entry (tabulated-list-get-entry)))
- (when entry
- (aref entry 0)))))
-
-(defun systemctl-start (unit)
- "Start Systemd UNIT."
- (interactive (list (or (systemctl-list-units-get-unit)
- (read-string "Unit: "))))
- (systemd-StartUnit (systemctl-bus) unit "replace")
- (when (eq major-mode 'systemctl-list-units-mode)
- (tabulated-list-revert)))
-
-(defun systemctl-stop (unit)
- (interactive (list (or (systemctl-list-units-get-unit)
- (read-string "Unit: "))))
- (systemd-StopUnit (systemctl-bus) unit "replace")
- (when (eq major-mode 'systemctl-list-units-mode)
- (tabulated-list-revert)))
-
-(defun systemctl-enable (unit)
- "Enable Systemd UNIT."
- (interactive (list (or (systemctl-list-units-get-unit)
- (read-string "Unit: "))))
- (pcase (systemd-EnableUnitFiles (systemctl-bus) (list unit) nil nil)
- (`(,carries-install-info ,changes)
- (if changes
- (pcase-dolist (`(,type ,from ,to) changes)
- (message "%s %s -> %s" type from to))
- (message "No changes")))))
-
-(defun systemctl-disable (unit)
- "Disable Systemd UNIT."
- (interactive (list (or (systemctl-list-units-get-unit)
- (read-string "Unit: "))))
- (let ((changes (systemd-DisableUnitFiles (systemctl-bus) (list unit) nil)))
- (if changes
- (pcase-dolist (`(,type ,from ,to) changes)
- (message "%s %s -> %s" type from to))
- (message "No changes"))))
-
-(defun systemctl-reload ()
- "Reload all unit files."
- (interactive)
- (systemd-Reload (systemctl-bus)))
-
-(defun systemctl-file-name (file-name)
- (if (and (stringp systemctl-bus)
- (string-match "unixexec:path=ssh,.*argv2=\\([^,]*\\),"
- systemctl-bus))
- (let ((host (systemd-unescape-dbus-address
- (match-string 1 systemctl-bus))))
- (concat "/" systemctl-tramp-method ":" host ":" file-name))
- file-name))
-
-(defun systemctl-find-fragment (unit)
- (interactive
- (list (or (and (eq major-mode 'systemctl-list-units-mode)
- (tabulated-list-get-id))
- (systemd-GetUnit (systemctl-bus) (read-string "Unit: ")))))
- (let ((fragment-path (systemd-unit-FragmentPath (systemctl-bus) unit)))
- (when fragment-path
- (find-file (systemctl-file-name fragment-path)))))
-
-(defun systemctl-edit-unit-files (unit &optional override-file)
- "Visit all configuration files related to UNIT simultaneously.
-If optional OVERRIDE-FILE is specified, or if a prefix argument has been
-given interactively, open a (new) override file."
- (interactive
- (let* ((unit (if (tabulated-list-get-entry)
- (systemctl-unescape-unit-name (aref
(tabulated-list-get-entry) 0))
- (read-string "Unit: ")))
- (unit-path (or (tabulated-list-get-id)
- (systemd-GetUnit (systemctl-bus) unit)))
- (override-file
- (when (equal current-prefix-arg '(4))
- (read-file-name "Override file: "
- (systemctl-file-name
- (concat "/etc/systemd/system/" unit ".d/"))
- nil nil
- systemctl-default-override-file-name))))
- (list unit-path override-file)))
- (let ((files (mapcar #'systemctl-file-name
- (systemd-unit-DropInPaths (systemctl-bus) unit))))
- (when override-file
- (push override-file files))
- (let ((path (systemd-unit-FragmentPath (systemctl-bus) unit)))
- (when (not (string= path ""))
- (setq files (nconc files
- (list (systemctl-file-name path))))))
- (let ((path (systemd-unit-SourcePath (systemctl-bus) unit)))
- (when (not (string= path ""))
- (setq files (nconc files
- (list (systemctl-file-name path))))))
- (if files
- (let ((buffers (mapcar #'find-file-noselect files)))
- (pop-to-buffer (pop buffers))
- (when buffers
- (delete-other-windows)
- (dolist (buffer buffers)
- (let ((window (split-window (car (last (window-list))))))
- (shrink-window-if-larger-than-buffer)
- (set-window-buffer window buffer)))
- (dolist (window (window-list))
- (shrink-window-if-larger-than-buffer window))))
- (when (called-interactively-p 'interactive)
- (message "No configuration files associated with `%s'." unit)))))
-
-(provide 'systemctl)
-;;; systemctl.el ends here
diff --git a/packages/systemd/systemd-codegen.el
b/packages/systemd/systemd-codegen.el
deleted file mode 100644
index 2fe1160..0000000
--- a/packages/systemd/systemd-codegen.el
+++ /dev/null
@@ -1,258 +0,0 @@
-;;; systemd-codegen.el --- D-Bus Introspection -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Mario Lang <mlang@delysid.org>
-;; Keywords:
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library is used to automatically generate D-Bus bindings for systemd
-;; and related components via introspection.
-;;
-;; The macro `systemd-codegen-define' can be used to generate Lisp code
according
-;; to the currently available introspection data. This can be useful for
-;; development.
-;;
-;; To avoid a dependency on systemd at compile time,
`systemd-codegen-to-string'
-;; is provided to statically generate all the Lisp code for the currently
running
-;; version of systemd.
-;;
-;; `systemd-codegen-to-string' is used to generate the bulk of the content of
-;; systemd.el.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'dbus)
-
-(defvar systemd-codegen-interfaces
- '(("org.freedesktop.systemd1.Manager"
- :prefix "systemd"
- :interface systemd-dbus-interface-manager)
- ("org.freedesktop.systemd1.Automount"
- :prefix "systemd-automount"
- :interface systemd-dbus-interface-automount)
- ("org.freedesktop.systemd1.BusName"
- :prefix "systemd-bus-name"
- :interface systemd-dbus-interface-bus-name)
- ("org.freedesktop.systemd1.Device"
- :prefix "systemd-device"
- :interface systemd-dbus-interface-device)
- ("org.freedesktop.systemd1.Mount"
- :prefix "systemd-mount"
- :interface systemd-dbus-interface-mount)
- ("org.freedesktop.systemd1.Path"
- :prefix "systemd-path"
- :interface systemd-dbus-interface-path)
- ("org.freedesktop.systemd1.Service"
- :prefix "systemd-service"
- :interface systemd-dbus-interface-service)
- ("org.freedesktop.systemd1.Scope"
- :prefix "systemd-scope"
- :interface systemd-dbus-interface-scope)
- ("org.freedesktop.systemd1.Slice"
- :prefix "systemd-slice"
- :interface systemd-dbus-interface-slice)
- ("org.freedesktop.systemd1.Socket"
- :prefix "systemd-socket"
- :interface systemd-dbus-interface-socket)
- ("org.freedesktop.systemd1.Swap"
- :prefix "systemd-swap"
- :interface systemd-dbus-interface-swap)
- ("org.freedesktop.systemd1.Target"
- :prefix "systemd-target"
- :interface systemd-dbus-interface-target)
- ("org.freedesktop.systemd1.Timer"
- :prefix "systemd-timer"
- :interface systemd-dbus-interface-timer)
- ("org.freedesktop.systemd1.Unit"
- :prefix "systemd-unit"
- :interface systemd-dbus-interface-unit)
- ("org.freedesktop.login1.Manager"
- :prefix "systemd-logind"
- :interface systemd-dbus-interface-logind-mamanger)
- ("org.freedesktop.login1.Seat"
- :prefix "systemd-logind-seat"
- :interface systemd-dbus-interface-logind-seat)
- ("org.freedesktop.login1.Session"
- :prefix "systemd-logind-session"
- :interface systemd-dbus-interface-logind-session)
- ("org.freedesktop.login1.User"
- :prefix "systemd-logind-user"
- :interface systemd-dbus-interface-logind-user)
- ("org.freedesktop.network1.Manager"
- :prefix "systemd-networkd"
- :interface systemd-dbus-interface-networkd-manager)
- ("org.freedesktop.network1.Link"
- :prefix "systemd-networkd-link"
- :interface systemd-dbus-interface-networkd-link)
- ("org.freedesktop.network1.Network"
- :prefix "systemd-networkd-network"
- :interface systemd-dbus-interface-networkd-network)
- ("org.freedesktop.resolve1.Manager"
- :prefix "systemd-resolved"
- :interface systemd-dbus-interface-resolved-manager)
- ("org.freedesktop.resolve1.Link"
- :prefix "systemd-resolved-link"
- :interface systemd-dbus-interface-resolved-link)
- ("org.freedesktop.hostname1"
- :prefix "systemd-hostnamed"
- :interface systemd-dbus-interface-hostnamed)
- ("org.freedesktop.locale1"
- :prefix "systemd-localed"
- :interface systemd-dbus-interface-localed)
- ("org.freedesktop.timedate1"
- :prefix "systemd-timedated"
- :interface systemd-dbus-interface-timedated)
- ("org.freedesktop.machine1.Manager"
- :prefix "systemd-machined"
- :interface systemd-dbus-interface-machined-mananger)
- ("org.freedesktop.machine1.Image"
- :prefix "systemd-machined-image"
- :interface systemd-dbus-interface-machined-image)
- ("org.freedesktop.machine1.Machine"
- :prefix "systemd-machined-machine"
- :interface systemd-dbus-interface-machined-machine)))
-
-(defun systemd-codegen-introspect (service path &optional interfaces)
- (let ((xml (dbus-introspect-xml :system service path)))
- (dolist (item
- (and (eq (car-safe xml) 'node)
- (xml-node-children xml))
- (sort interfaces (lambda (a b) (string-lessp (car a) (car b)))))
- (cond
- ((and (listp item) (eq 'interface (car-safe item)))
- (let* ((interface (xml-get-attribute-or-nil item 'name))
- (interface-info (cdr (assoc interface
systemd-codegen-interfaces)))
- (prefix (plist-get interface-info :prefix))
- (object-interface (not (string-match "\\(\\.Manager\\|1\\)$"
interface)))
- (service (pcase service
- ("org.freedesktop.systemd1" 'systemd-dbus-service)
- (_ service)))
- (path (pcase path
- ("/org/freedesktop/systemd1" 'systemd-dbus-path)
- (_ path)))
- forms)
- (when (and prefix (not (assoc interface interfaces)))
- (push `(defconst ,(plist-get interface-info :interface) ,interface)
forms)
- (setq
- interfaces
- (append
- interfaces
- (list
- (cons
- interface
- (let ((interface (plist-get interface-info :interface)))
- (dolist (interface-item (cddr item) (nreverse forms))
- (cond
- ((eq 'property (car-safe interface-item))
- (let* ((property (xml-get-attribute interface-item 'name))
- (name (intern (concat prefix "-" property)))
- (readwrite
- (string-equal
- "readwrite"
- (xml-get-attribute interface-item 'access)))
- (arglist `(bus
- ,@(when object-interface
- '(path)))))
- (push `(defun ,name ,arglist
- ,(if readwrite
- "Use `setf' to set the value of this
property."
- "Read only property.")
- (dbus-get-property
- bus ,service
- ,(if object-interface 'path path)
- ,interface ,property))
- forms)
- (when readwrite
- (push (list 'gv-define-setter name (cons 'value
arglist)
- (list '\`
- (list 'dbus-set-property
- '(\, bus)
- service
- (if object-interface
- '(\, path)
- path)
- interface property
- '(\, value))))
- forms))))
-
- ((eq 'method (car-safe interface-item))
- (let* ((method (xml-get-attribute interface-item 'name))
- (name (intern (concat prefix "-" method)))
- (args (cl-remove-if-not
- (lambda (arg)
- (string= "in"
- (xml-get-attribute
- arg 'direction)))
- (xml-get-children interface-item 'arg)))
- (arglist `(bus ,@(when object-interface '(path))
- ,@(when args '(&rest args)))))
- (push `(defun ,name ,arglist
- (,@(if args
- '(apply #'dbus-call-method)
- '(dbus-call-method))
- bus ,service
- ,(if object-interface 'path path)
- ,interface ,method
- ,@(when args '(args))))
- forms)))))))))))))
- ((and (listp item) (eq 'node (xml-node-name item)))
- (let ((name (xml-get-attribute-or-nil item 'name)))
- (setq interfaces (systemd-codegen-introspect
- service (concat path "/" name) interfaces))))))))
-
-(defmacro systemd-codegen-define (suffix)
- (cons 'progn (cl-mapcan #'cdr (systemd-codegen-introspect
- (concat "org.freedesktop." suffix)
- (concat "/org/freedesktop/" suffix)))))
-
-(defun systemd-codegen-to-string (suffix)
- (with-temp-buffer
- (pcase-dolist (`(,interface . ,forms)
- (systemd-codegen-introspect
- (concat "org.freedesktop." suffix)
- (concat "/org/freedesktop/" suffix)))
- (insert ";;; " interface "\n\n")
- (dolist (form forms)
- (pp form (current-buffer))
- (insert "\n")))
- (delete-char -1)
- (emacs-lisp-mode)
- (goto-char (point-min))
- (while (re-search-forward "^(\\(defun\\|gv-define-setter\\)" nil t)
- (goto-char (match-beginning 0))
- (down-list 1) (forward-sexp 2) (delete-char 4) (up-list 1))
- (goto-char (point-min))
- (while (re-search-forward "(dbus-\\(get\\|set\\)-property" nil t)
- (goto-char (match-beginning 0))
- (down-list 1) (forward-sexp 4) (insert "\n") (up-list -1) (indent-sexp)
- (up-list 1))
- (goto-char (point-min))
- (while (re-search-forward "(apply #'dbus-call-method" nil t)
- (goto-char (match-beginning 0))
- (down-list 1) (forward-sexp 5) (insert "\n") (up-list -1) (indent-sexp)
- (up-list 1))
- (goto-char (point-min))
- (while (re-search-forward "(dbus-call-method" nil t)
- (goto-char (match-beginning 0))
- (down-list 1) (forward-sexp 4) (insert "\n") (up-list -1) (indent-sexp)
- (up-list 1))
- (buffer-string)))
-
-(provide 'systemd-codegen)
-;;; systemd-codegen.el ends here
diff --git a/packages/systemd/systemd-mode.el b/packages/systemd/systemd-mode.el
deleted file mode 100644
index f799661..0000000
--- a/packages/systemd/systemd-mode.el
+++ /dev/null
@@ -1,200 +0,0 @@
-;;; systemd-mode.el --- Major modes for systemd unit files -*-
lexical-binding: t; -*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Mario Lang <mlang@delysid.org>
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Todo:
-
-;; * Add support for systemd-networkd .link and .network files.
-
-;;; Code:
-
-(require 'conf-mode)
-
-(defvar systemd-unit-font-lock-keywords
- '(;; [section]
- ("^[ \t]*\\[\\(Unit\\|Service\\)\\]"
- 1 'font-lock-type-face)
- ;; var=val
- ("^[ \t]*\\(.+?\\)[ \t]*="
- 1 'font-lock-variable-name-face))
- "Keywords to highlight in Conf mode.")
-
-(defvar-local systemd-unit-mode-sections '("Unit" "Install"))
-
-(defvar systemd-unit-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\t" #'completion-at-point)
- map))
-
-(define-derived-mode systemd-unit-mode conf-unix-mode "Systemd-Unit"
- (conf-mode-initialize "#" systemd-unit-font-lock-keywords)
- (add-hook 'completion-at-point-functions #'systemd-mode-completion-at-point
- nil t)
- (setq-local completion-ignore-case t))
-
-;;;###autoload
-(define-derived-mode systemd-automount-mode systemd-unit-mode
"Systemd-AutoMount"
- "Major mode for editing systemd .automount unit files"
- (add-to-list 'systemd-unit-mode-sections "AutoMount"))
-
-;;;###autoload
-(define-derived-mode systemd-mount-mode systemd-unit-mode "Systemd-Mount"
- "Major mode for editing systemd .mount unit files"
- (add-to-list 'systemd-unit-mode-sections "Mount"))
-
-;;;###autoload
-(define-derived-mode systemd-path-mode systemd-unit-mode "Systemd-Path"
- "Major mode for editing systemd .path unit files"
- (add-to-list 'systemd-unit-mode-sections "Path"))
-
-;;;###autoload
-(define-derived-mode systemd-service-mode systemd-unit-mode "Systemd-Service"
- "Major mode for editing systemd .service unit files."
- (add-to-list 'systemd-unit-mode-sections "Service"))
-
-;;;###autoload
-(define-derived-mode systemd-socket-mode systemd-unit-mode "Systemd-Socket"
- "Major mode for editing systemd .socket unit files."
- (add-to-list 'systemd-unit-mode-sections "Socket"))
-
-;;;###autoload
-(define-derived-mode systemd-swap-mode systemd-unit-mode "Systemd-Swap"
- "Major mode for editing systemd .swap unit files."
- (add-to-list 'systemd-unit-mode-sections "Swap"))
-
-;;;###autoload
-(define-derived-mode systemd-timer-mode systemd-unit-mode "Systemd-Timer"
- "Major mode for editing systemd .timer unit files."
- (add-to-list 'systemd-unit-mode-sections "Timer"))
-
-(defvar systemd-mode-section-keywords-alist
- '(("AutoMount"
- "Where" "DirectoryMode" "TimeoutIdleSec")
- ("Device")
- ("Mount"
- "What" "Where" "Type" "Options" "SloppyOptions" "DirectoryMode"
- "TimeoutSec")
- ("Path"
- "PathExists" "PathExistsGlob" "PathChanged" "PathModified"
- "DirectoryNotEmpty" "Unit" "MakeDirectory" "DirectoryMode")
- ("Service"
- "Type" "RemainAfterExit" "GuessMainPID" "PIDFile" "BusName"
- "ExecStart" "ExecStartPre" "ExecStartPost" "ExecReload"
- "ExecStop" "ExecStopPost" "RestartSec" "TimeoutStartSec"
- "TimeoutStopSec" "TimeoutSec" "RuntimeMaxSec" "WatchdogSec"
- "Restart" "SuccessExitStatus" "RestartPreventExitStatus"
- "RestartForceExitStatus" "PermissionsStartOnly"
- "RootDirectoryStartOnly" "NonBlocking" "NotifyAccess" "Sockets"
- "FailureAction" "FileDescriptorStoreMax" "USBFunctionDescriptors"
- "USBFunctionStrings")
- ("Slice")
- ("Socket"
- "ListenStream" "ListenDatagram" "ListenSequentialPacket"
- "ListenFIFO" "ListenSpecial" "ListenNetlink" "ListenMessageQueue"
- "ListenUSBFunction" "SocketProtocol" "BindIPv6Only"
- "Backlog" "BindToDevice" "SocketUser" "SocketGroup"
- "SocketMode" "DirectoryMode" "Accept" "Writable" "MaxConnections"
- "KeepAlive" "KeepAliveTimeSec" "KeepAliveIntervalSec"
- "KeepAliveProbes" "NoDelay" "Priority" "DeferAcceptSec"
- "ReceiveBuffer" "SendBuffer" "IPTOS" "IPTTL" "Mark" "ReusePort"
- "SmackLabel" "SmackLabelIPIn" "SmackLabelIPOut"
- "SELinuxContextFromNet" "PipeSize" "MessageQueueMaxMessages"
- "MessageQueueMessageSize" "FreeBind" "Transparent" "Broadcast"
- "PassCredentials" "PassSecurity" "TCPCongestion" "ExecStartPre"
- "ExecStartPost" "ExecStopPre" "ExecStopPost" "TimeoutSec"
- "Service" "RemoveOnStop" "Symlinks" "FileDescriptorName"
- "TriggerLimitIntervalSec" "TriggerLimitBurst")
- ("Swap"
- "What" "Priority" "Options" "TimeoutSec")
- ("Target")
- ("Timer"
- "OnActiveSec" "OnBootSec" "OnStartupSec" "OnUnitActiveSec"
- "OnUnitInactiveSec" "OnCalendar" "AccuracySec" "RandomizedDelaySec"
- "Unit" "Persistent" "WakeSystem" "RemainAfterElapse")
- ("Unit"
- "Description" "Documentation" "Requires" "Requisite" "Wants" "BindsTo"
- "PartOf" "Conflicts" "Before" "After" "OnFailure" "PropagatesReloadTo"
- "ReloadPropagatedFrom" "JoinsNamespaceOf" "RequiresMountsFor"
- "OnFailureJobMode" "IgnoreOnIsolate" "StopWhenUnneeded"
"RefuseManualStart"
- "RefuseManualStop" "AllowIsolate" "DefaultDependencies"
- "JobTimeoutSec" "JobTimeoutAction" "JobTimeoutRebootArgument"
- "StartLimitIntervalSec" "StartLimitBurst"
- "StartLimitAction" "RebootArgument"
- "ConditionArchitecture" "ConditionVirtualization" "ConditionHost"
- "ConditionKernelCommandLine" "ConditionSecurity" "ConditionCapability"
- "ConditionACPower" "ConditionNeedsUpdate" "ConditionFirstBoot"
- "ConditionPathExists" "ConditionPathExistsGlob" "ConditionPathIsDirectory"
- "ConditionPathIsSymbolicLink" "ConditionPathIsMountPoint"
- "ConditionPathIsReadWrite" "ConditionDirectoryNotEmpty"
- "ConditionFileNotEmpty" "ConditionFileIsExecutable"
- "AssertArchitecture" "AssertVirtualization" "AssertHost"
- "AssertKernelCommandLine" "AssertSecurity" "AssertCapability"
- "AssertACPower" "AssertNeedsUpdate" "AssertFirstBoot" "AssertPathExists"
- "AssertPathExistsGlob" "AssertPathIsDirectory" "AssertPathIsSymbolicLink"
- "AssertPathIsMountPoint" "AssertPathIsReadWrite" "AssertDirectoryNotEmpty"
- "AssertFileNotEmpty" "AssertFileIsExecutable"
- "SourcePath")
- ("Install"
- "Alias" "WantedBy" "RequiredBy" "Also" "DefaultInstance")))
-
-(defvar systemd-mode-section-regexp "^[ \t]*\\[\\([[:alpha:]]+\\)]")
-
-(defun systemd-mode-completion-at-point ()
- (if (save-excursion (re-search-backward systemd-mode-section-regexp nil t))
- (let ((section (match-string-no-properties 1)))
- (if (member-ignore-case section systemd-unit-mode-sections)
- (let ((keywords (cdr (assoc-string
- section systemd-mode-section-keywords-alist
t))))
- (when keywords
- (let ((end (point)))
- (save-excursion
- (skip-chars-backward "[:alpha:]")
- (let ((start (point)))
- (skip-chars-backward " \t")
- (when (eq (line-beginning-position) (point))
- (list start end (mapcar (lambda (str) (concat str "="))
- keywords))))))))
- (display-warning major-mode
- (format "Unexpected section [%s]." section)
- :warning)
- nil))))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.automount\\'" . systemd-automount-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.mount\\'" . systemd-mount-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.path\\'" . systemd-path-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.service\\'" . systemd-service-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.socket\\'" . systemd-socket-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.swap\\'" . systemd-swap-mode))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.timer\\'" . systemd-timer-mode))
-
-(provide 'systemd-mode)
-;;; systemd-mode.el ends here
diff --git a/packages/systemd/systemd.el b/packages/systemd/systemd.el
deleted file mode 100644
index ac940b1..0000000
--- a/packages/systemd/systemd.el
+++ /dev/null
@@ -1,4802 +0,0 @@
-;;; systemd.el --- Interface to Systemd -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Mario Lang <mlang@delysid.org>
-;; Keywords: comm
-;; Version: 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package provides D-Bus bindings, major modes and interactive commands
-;; for working with systemd from within Emacs.
-;;
-;; systemd-mode.el provides major modes for all systemd unit file types.
-;;
-;; systemctl.el provides interactive commands for managing units and
-;; their status. Similar to the command-line "systemctl" tool,
-;; working with remote hosts is supported. TRAMP is used to visit
-;; configuration files of remote instances of systemd.
-;;
-;; Last, but not least, this library, systemd.el, provides
-;; semi-autogenerated functions and generalized setters for the
-;; systemd D-Bus API. They have been generated using tools from
-;; systemd-codegen.el.
-
-;;; Code:
-
-(require 'dbus)
-(require 'gv)
-
-(defun systemd-escape-dbus-address (string)
- (apply #'concat (mapcar (lambda (c)
- (if (or (and (>= c ?a) (<= c ?z))
- (and (>= c ?A) (<= c ?Z))
- (and (>= c ?0) (<= c ?9))
- (= c ?-) (= c ?_)
- (= c ?/) (= c ?\\)
- (= c ?.))
- (string c)
- (format "%%%02x" c)))
- string)))
-
-(defun systemd-unescape-dbus-address (string)
- (while (string-match "%\\([0-9a-f]\\{2\\}\\)" string)
- (setq string
- (replace-match
- (string (string-to-number (match-string 1 string) 16)) t t string)))
- string)
-
-(defun systemd-remote-bus (host &optional bus)
- "Construct a D-Bus bus address suitable for connecting to a remote D-Bus
-instance (via ssh) running on HOST. Optional argument BUS specifies
-the D-Bus instance to connect to on the remote host. The keywords
-:system and :session indicate to connect to the remote system or session
-bus, respectively. If a string is given, that particular D-Bus address is used
-on the remote host. When not specified, the remote system bus is used."
- (setq bus
- (pcase bus
- ((or `nil `:system)
- "unix:path=/run/dbus/system_bus_socket")
- (`:session
- (with-temp-buffer
- (let ((default-directory (concat "/scpx:" host ":")))
- (process-file "/bin/sh" nil t nil "-c" "[ -e
$XDG_RUNTIME_DIR/bus ] && echo -n $XDG_RUNTIME_DIR/bus")
- (when (not (zerop (buffer-size)))
- (buffer-string)))))
- (_ bus)))
- (unless bus
- (error "Unable to determine remote session bus address."))
- (concat "unixexec:"
- "path=ssh"
- ",argv1=-xT"
- ",argv2=" (systemd-escape-dbus-address host)
- ",argv3=systemd-stdio-bridge"
- ",argv4=" (systemd-escape-dbus-address (concat "--bus-path=" bus))))
-
-(defconst systemd-dbus-service "org.freedesktop.systemd1")
-(defconst systemd-dbus-path "/org/freedesktop/systemd1")
-
-;;; org.freedesktop.systemd1.Automount
-
-(defconst systemd-dbus-interface-automount
"org.freedesktop.systemd1.Automount")
-
-(defun systemd-automount-Where (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-automount "Where"))
-
-(defun systemd-automount-DirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-automount "DirectoryMode"))
-
-(defun systemd-automount-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-automount "Result"))
-
-(defun systemd-automount-TimeoutIdleUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-automount "TimeoutIdleUSec"))
-
-;;; org.freedesktop.systemd1.BusName
-
-(defconst systemd-dbus-interface-bus-name "org.freedesktop.systemd1.BusName")
-
-(defun systemd-bus-name-Name (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "Name"))
-
-(defun systemd-bus-name-TimeoutUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "TimeoutUSec"))
-
-(defun systemd-bus-name-ControlPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "ControlPID"))
-
-(defun systemd-bus-name-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "Result"))
-
-(defun systemd-bus-name-Activating (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "Activating"))
-
-(defun systemd-bus-name-AcceptFileDescriptors (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-bus-name "AcceptFileDescriptors"))
-
-;;; org.freedesktop.systemd1.Device
-
-(defconst systemd-dbus-interface-device "org.freedesktop.systemd1.Device")
-
-(defun systemd-device-SysFSPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-device "SysFSPath"))
-
-;;; org.freedesktop.systemd1.Manager
-
-(defconst systemd-dbus-interface-manager "org.freedesktop.systemd1.Manager")
-
-(defun systemd-Version (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Version"))
-
-(defun systemd-Features (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Features"))
-
-(defun systemd-Virtualization (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Virtualization"))
-
-(defun systemd-Architecture (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Architecture"))
-
-(defun systemd-Tainted (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Tainted"))
-
-(defun systemd-FirmwareTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "FirmwareTimestamp"))
-
-(defun systemd-FirmwareTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"FirmwareTimestampMonotonic"))
-
-(defun systemd-LoaderTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LoaderTimestamp"))
-
-(defun systemd-LoaderTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LoaderTimestampMonotonic"))
-
-(defun systemd-KernelTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "KernelTimestamp"))
-
-(defun systemd-KernelTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "KernelTimestampMonotonic"))
-
-(defun systemd-InitRDTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "InitRDTimestamp"))
-
-(defun systemd-InitRDTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "InitRDTimestampMonotonic"))
-
-(defun systemd-UserspaceTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UserspaceTimestamp"))
-
-(defun systemd-UserspaceTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"UserspaceTimestampMonotonic"))
-
-(defun systemd-FinishTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "FinishTimestamp"))
-
-(defun systemd-FinishTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "FinishTimestampMonotonic"))
-
-(defun systemd-SecurityStartTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SecurityStartTimestamp"))
-
-(defun systemd-SecurityStartTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"SecurityStartTimestampMonotonic"))
-
-(defun systemd-SecurityFinishTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SecurityFinishTimestamp"))
-
-(defun systemd-SecurityFinishTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"SecurityFinishTimestampMonotonic"))
-
-(defun systemd-GeneratorsStartTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GeneratorsStartTimestamp"))
-
-(defun systemd-GeneratorsStartTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"GeneratorsStartTimestampMonotonic"))
-
-(defun systemd-GeneratorsFinishTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"GeneratorsFinishTimestamp"))
-
-(defun systemd-GeneratorsFinishTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"GeneratorsFinishTimestampMonotonic"))
-
-(defun systemd-UnitsLoadStartTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnitsLoadStartTimestamp"))
-
-(defun systemd-UnitsLoadStartTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"UnitsLoadStartTimestampMonotonic"))
-
-(defun systemd-UnitsLoadFinishTimestamp (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnitsLoadFinishTimestamp"))
-
-(defun systemd-UnitsLoadFinishTimestampMonotonic (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"UnitsLoadFinishTimestampMonotonic"))
-
-(defun systemd-LogLevel (bus)
- "Use `setf' to set the value of this property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LogLevel"))
-
-(gv-define-setter systemd-LogLevel (value bus)
- `(dbus-set-property ,bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LogLevel" ,value))
-
-(defun systemd-LogTarget (bus)
- "Use `setf' to set the value of this property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LogTarget"))
-
-(gv-define-setter systemd-LogTarget (value bus)
- `(dbus-set-property ,bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LogTarget" ,value))
-
-(defun systemd-NNames (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "NNames"))
-
-(defun systemd-NFailedUnits (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "NFailedUnits"))
-
-(defun systemd-NJobs (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "NJobs"))
-
-(defun systemd-NInstalledJobs (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "NInstalledJobs"))
-
-(defun systemd-NFailedJobs (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "NFailedJobs"))
-
-(defun systemd-Progress (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Progress"))
-
-(defun systemd-Environment (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Environment"))
-
-(defun systemd-ConfirmSpawn (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ConfirmSpawn"))
-
-(defun systemd-ShowStatus (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ShowStatus"))
-
-(defun systemd-UnitPath (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnitPath"))
-
-(defun systemd-DefaultStandardOutput (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultStandardOutput"))
-
-(defun systemd-DefaultStandardError (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultStandardError"))
-
-(defun systemd-RuntimeWatchdogUSec (bus)
- "Use `setf' to set the value of this property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "RuntimeWatchdogUSec"))
-
-(gv-define-setter systemd-RuntimeWatchdogUSec (value bus)
- `(dbus-set-property ,bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "RuntimeWatchdogUSec"
,value))
-
-(defun systemd-ShutdownWatchdogUSec (bus)
- "Use `setf' to set the value of this property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ShutdownWatchdogUSec"))
-
-(gv-define-setter systemd-ShutdownWatchdogUSec (value bus)
- `(dbus-set-property ,bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ShutdownWatchdogUSec"
,value))
-
-(defun systemd-ControlGroup (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ControlGroup"))
-
-(defun systemd-SystemState (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SystemState"))
-
-(defun systemd-ExitCode (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ExitCode"))
-
-(defun systemd-DefaultTimerAccuracyUSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultTimerAccuracyUSec"))
-
-(defun systemd-DefaultTimeoutStartUSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultTimeoutStartUSec"))
-
-(defun systemd-DefaultTimeoutStopUSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultTimeoutStopUSec"))
-
-(defun systemd-DefaultRestartUSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultRestartUSec"))
-
-(defun systemd-DefaultStartLimitIntervalSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"DefaultStartLimitIntervalSec"))
-
-(defun systemd-DefaultStartLimitBurst (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultStartLimitBurst"))
-
-(defun systemd-DefaultCPUAccounting (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultCPUAccounting"))
-
-(defun systemd-DefaultBlockIOAccounting (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultBlockIOAccounting"))
-
-(defun systemd-DefaultMemoryAccounting (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultMemoryAccounting"))
-
-(defun systemd-DefaultTasksAccounting (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultTasksAccounting"))
-
-(defun systemd-DefaultLimitCPU (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitCPU"))
-
-(defun systemd-DefaultLimitCPUSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitCPUSoft"))
-
-(defun systemd-DefaultLimitFSIZE (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitFSIZE"))
-
-(defun systemd-DefaultLimitFSIZESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitFSIZESoft"))
-
-(defun systemd-DefaultLimitDATA (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitDATA"))
-
-(defun systemd-DefaultLimitDATASoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitDATASoft"))
-
-(defun systemd-DefaultLimitSTACK (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitSTACK"))
-
-(defun systemd-DefaultLimitSTACKSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitSTACKSoft"))
-
-(defun systemd-DefaultLimitCORE (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitCORE"))
-
-(defun systemd-DefaultLimitCORESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitCORESoft"))
-
-(defun systemd-DefaultLimitRSS (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRSS"))
-
-(defun systemd-DefaultLimitRSSSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRSSSoft"))
-
-(defun systemd-DefaultLimitNOFILE (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNOFILE"))
-
-(defun systemd-DefaultLimitNOFILESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNOFILESoft"))
-
-(defun systemd-DefaultLimitAS (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitAS"))
-
-(defun systemd-DefaultLimitASSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitASSoft"))
-
-(defun systemd-DefaultLimitNPROC (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNPROC"))
-
-(defun systemd-DefaultLimitNPROCSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNPROCSoft"))
-
-(defun systemd-DefaultLimitMEMLOCK (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitMEMLOCK"))
-
-(defun systemd-DefaultLimitMEMLOCKSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitMEMLOCKSoft"))
-
-(defun systemd-DefaultLimitLOCKS (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitLOCKS"))
-
-(defun systemd-DefaultLimitLOCKSSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitLOCKSSoft"))
-
-(defun systemd-DefaultLimitSIGPENDING (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitSIGPENDING"))
-
-(defun systemd-DefaultLimitSIGPENDINGSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager
"DefaultLimitSIGPENDINGSoft"))
-
-(defun systemd-DefaultLimitMSGQUEUE (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitMSGQUEUE"))
-
-(defun systemd-DefaultLimitMSGQUEUESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitMSGQUEUESoft"))
-
-(defun systemd-DefaultLimitNICE (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNICE"))
-
-(defun systemd-DefaultLimitNICESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitNICESoft"))
-
-(defun systemd-DefaultLimitRTPRIO (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRTPRIO"))
-
-(defun systemd-DefaultLimitRTPRIOSoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRTPRIOSoft"))
-
-(defun systemd-DefaultLimitRTTIME (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRTTIME"))
-
-(defun systemd-DefaultLimitRTTIMESoft (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultLimitRTTIMESoft"))
-
-(defun systemd-DefaultTasksMax (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DefaultTasksMax"))
-
-(defun systemd-TimerSlackNSec (bus)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "TimerSlackNSec"))
-
-(defun systemd-GetUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetUnit" args))
-
-(defun systemd-GetUnitByPID (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetUnitByPID" args))
-
-(defun systemd-LoadUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LoadUnit" args))
-
-(defun systemd-StartUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "StartUnit" args))
-
-(defun systemd-StartUnitReplace (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "StartUnitReplace" args))
-
-(defun systemd-StopUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "StopUnit" args))
-
-(defun systemd-ReloadUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ReloadUnit" args))
-
-(defun systemd-RestartUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "RestartUnit" args))
-
-(defun systemd-TryRestartUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "TryRestartUnit" args))
-
-(defun systemd-ReloadOrRestartUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ReloadOrRestartUnit" args))
-
-(defun systemd-ReloadOrTryRestartUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ReloadOrTryRestartUnit" args))
-
-(defun systemd-KillUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "KillUnit" args))
-
-(defun systemd-ResetFailedUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ResetFailedUnit" args))
-
-(defun systemd-SetUnitProperties (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SetUnitProperties" args))
-
-(defun systemd-StartTransientUnit (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "StartTransientUnit" args))
-
-(defun systemd-GetUnitProcesses (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetUnitProcesses" args))
-
-(defun systemd-GetJob (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetJob" args))
-
-(defun systemd-CancelJob (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "CancelJob" args))
-
-(defun systemd-ClearJobs (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ClearJobs"))
-
-(defun systemd-ResetFailed (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ResetFailed"))
-
-(defun systemd-ListUnits (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnits"))
-
-(defun systemd-ListUnitsFiltered (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnitsFiltered" args))
-
-(defun systemd-ListUnitsByPatterns (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnitsByPatterns" args))
-
-(defun systemd-ListUnitsByNames (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnitsByNames" args))
-
-(defun systemd-ListJobs (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListJobs"))
-
-(defun systemd-Subscribe (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Subscribe"))
-
-(defun systemd-Unsubscribe (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Unsubscribe"))
-
-(defun systemd-Dump (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Dump"))
-
-(defun systemd-CreateSnapshot (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "CreateSnapshot" args))
-
-(defun systemd-RemoveSnapshot (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "RemoveSnapshot" args))
-
-(defun systemd-Reload (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Reload"))
-
-(defun systemd-Reexecute (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Reexecute"))
-
-(defun systemd-Exit (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Exit"))
-
-(defun systemd-Reboot (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Reboot"))
-
-(defun systemd-PowerOff (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "PowerOff"))
-
-(defun systemd-Halt (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "Halt"))
-
-(defun systemd-KExec (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "KExec"))
-
-(defun systemd-SwitchRoot (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SwitchRoot" args))
-
-(defun systemd-SetEnvironment (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SetEnvironment" args))
-
-(defun systemd-UnsetEnvironment (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnsetEnvironment" args))
-
-(defun systemd-UnsetAndSetEnvironment (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnsetAndSetEnvironment" args))
-
-(defun systemd-ListUnitFiles (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnitFiles"))
-
-(defun systemd-ListUnitFilesByPatterns (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ListUnitFilesByPatterns" args))
-
-(defun systemd-GetUnitFileState (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetUnitFileState" args))
-
-(defun systemd-EnableUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "EnableUnitFiles" args))
-
-(defun systemd-DisableUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "DisableUnitFiles" args))
-
-(defun systemd-ReenableUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "ReenableUnitFiles" args))
-
-(defun systemd-LinkUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "LinkUnitFiles" args))
-
-(defun systemd-PresetUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "PresetUnitFiles" args))
-
-(defun systemd-PresetUnitFilesWithMode (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "PresetUnitFilesWithMode" args))
-
-(defun systemd-MaskUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "MaskUnitFiles" args))
-
-(defun systemd-UnmaskUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "UnmaskUnitFiles" args))
-
-(defun systemd-RevertUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "RevertUnitFiles" args))
-
-(defun systemd-SetDefaultTarget (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SetDefaultTarget" args))
-
-(defun systemd-GetDefaultTarget (bus)
- (dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "GetDefaultTarget"))
-
-(defun systemd-PresetAllUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "PresetAllUnitFiles" args))
-
-(defun systemd-AddDependencyUnitFiles (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "AddDependencyUnitFiles" args))
-
-(defun systemd-SetExitCode (bus &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service systemd-dbus-path
- systemd-dbus-interface-manager "SetExitCode" args))
-
-;;; org.freedesktop.systemd1.Mount
-
-(defconst systemd-dbus-interface-mount "org.freedesktop.systemd1.Mount")
-
-(defun systemd-mount-Where (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Where"))
-
-(defun systemd-mount-What (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "What"))
-
-(defun systemd-mount-Options (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Options"))
-
-(defun systemd-mount-Type (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Type"))
-
-(defun systemd-mount-TimeoutUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TimeoutUSec"))
-
-(defun systemd-mount-ControlPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ControlPID"))
-
-(defun systemd-mount-DirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "DirectoryMode"))
-
-(defun systemd-mount-SloppyOptions (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SloppyOptions"))
-
-(defun systemd-mount-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Result"))
-
-(defun systemd-mount-ExecMount (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ExecMount"))
-
-(defun systemd-mount-ExecUnmount (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ExecUnmount"))
-
-(defun systemd-mount-ExecRemount (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ExecRemount"))
-
-(defun systemd-mount-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Slice"))
-
-(defun systemd-mount-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ControlGroup"))
-
-(defun systemd-mount-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "MemoryCurrent"))
-
-(defun systemd-mount-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUUsageNSec"))
-
-(defun systemd-mount-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TasksCurrent"))
-
-(defun systemd-mount-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-mount "GetProcesses"))
-
-(defun systemd-mount-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Delegate"))
-
-(defun systemd-mount-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUAccounting"))
-
-(defun systemd-mount-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUShares"))
-
-(defun systemd-mount-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StartupCPUShares"))
-
-(defun systemd-mount-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUQuotaPerSecUSec"))
-
-(defun systemd-mount-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOAccounting"))
-
-(defun systemd-mount-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOWeight"))
-
-(defun systemd-mount-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StartupIOWeight"))
-
-(defun systemd-mount-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IODeviceWeight"))
-
-(defun systemd-mount-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOReadBandwidthMax"))
-
-(defun systemd-mount-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOWriteBandwidthMax"))
-
-(defun systemd-mount-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOReadIOPSMax"))
-
-(defun systemd-mount-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOWriteIOPSMax"))
-
-(defun systemd-mount-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "BlockIOAccounting"))
-
-(defun systemd-mount-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "BlockIOWeight"))
-
-(defun systemd-mount-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StartupBlockIOWeight"))
-
-(defun systemd-mount-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "BlockIODeviceWeight"))
-
-(defun systemd-mount-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "BlockIOReadBandwidth"))
-
-(defun systemd-mount-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "BlockIOWriteBandwidth"))
-
-(defun systemd-mount-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "MemoryAccounting"))
-
-(defun systemd-mount-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "MemoryLimit"))
-
-(defun systemd-mount-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "DevicePolicy"))
-
-(defun systemd-mount-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "DeviceAllow"))
-
-(defun systemd-mount-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TasksAccounting"))
-
-(defun systemd-mount-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TasksMax"))
-
-(defun systemd-mount-Environment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Environment"))
-
-(defun systemd-mount-EnvironmentFiles (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "EnvironmentFiles"))
-
-(defun systemd-mount-PassEnvironment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "PassEnvironment"))
-
-(defun systemd-mount-UMask (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "UMask"))
-
-(defun systemd-mount-LimitCPU (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitCPU"))
-
-(defun systemd-mount-LimitCPUSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitCPUSoft"))
-
-(defun systemd-mount-LimitFSIZE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitFSIZE"))
-
-(defun systemd-mount-LimitFSIZESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitFSIZESoft"))
-
-(defun systemd-mount-LimitDATA (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitDATA"))
-
-(defun systemd-mount-LimitDATASoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitDATASoft"))
-
-(defun systemd-mount-LimitSTACK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitSTACK"))
-
-(defun systemd-mount-LimitSTACKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitSTACKSoft"))
-
-(defun systemd-mount-LimitCORE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitCORE"))
-
-(defun systemd-mount-LimitCORESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitCORESoft"))
-
-(defun systemd-mount-LimitRSS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRSS"))
-
-(defun systemd-mount-LimitRSSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRSSSoft"))
-
-(defun systemd-mount-LimitNOFILE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNOFILE"))
-
-(defun systemd-mount-LimitNOFILESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNOFILESoft"))
-
-(defun systemd-mount-LimitAS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitAS"))
-
-(defun systemd-mount-LimitASSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitASSoft"))
-
-(defun systemd-mount-LimitNPROC (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNPROC"))
-
-(defun systemd-mount-LimitNPROCSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNPROCSoft"))
-
-(defun systemd-mount-LimitMEMLOCK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitMEMLOCK"))
-
-(defun systemd-mount-LimitMEMLOCKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitMEMLOCKSoft"))
-
-(defun systemd-mount-LimitLOCKS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitLOCKS"))
-
-(defun systemd-mount-LimitLOCKSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitLOCKSSoft"))
-
-(defun systemd-mount-LimitSIGPENDING (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitSIGPENDING"))
-
-(defun systemd-mount-LimitSIGPENDINGSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitSIGPENDINGSoft"))
-
-(defun systemd-mount-LimitMSGQUEUE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitMSGQUEUE"))
-
-(defun systemd-mount-LimitMSGQUEUESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitMSGQUEUESoft"))
-
-(defun systemd-mount-LimitNICE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNICE"))
-
-(defun systemd-mount-LimitNICESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitNICESoft"))
-
-(defun systemd-mount-LimitRTPRIO (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRTPRIO"))
-
-(defun systemd-mount-LimitRTPRIOSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRTPRIOSoft"))
-
-(defun systemd-mount-LimitRTTIME (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRTTIME"))
-
-(defun systemd-mount-LimitRTTIMESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "LimitRTTIMESoft"))
-
-(defun systemd-mount-WorkingDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "WorkingDirectory"))
-
-(defun systemd-mount-RootDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "RootDirectory"))
-
-(defun systemd-mount-OOMScoreAdjust (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "OOMScoreAdjust"))
-
-(defun systemd-mount-Nice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Nice"))
-
-(defun systemd-mount-IOScheduling (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IOScheduling"))
-
-(defun systemd-mount-CPUSchedulingPolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUSchedulingPolicy"))
-
-(defun systemd-mount-CPUSchedulingPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUSchedulingPriority"))
-
-(defun systemd-mount-CPUAffinity (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUAffinity"))
-
-(defun systemd-mount-TimerSlackNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TimerSlackNSec"))
-
-(defun systemd-mount-CPUSchedulingResetOnFork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CPUSchedulingResetOnFork"))
-
-(defun systemd-mount-NonBlocking (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "NonBlocking"))
-
-(defun systemd-mount-StandardInput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StandardInput"))
-
-(defun systemd-mount-StandardOutput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StandardOutput"))
-
-(defun systemd-mount-StandardError (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "StandardError"))
-
-(defun systemd-mount-TTYPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TTYPath"))
-
-(defun systemd-mount-TTYReset (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TTYReset"))
-
-(defun systemd-mount-TTYVHangup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TTYVHangup"))
-
-(defun systemd-mount-TTYVTDisallocate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "TTYVTDisallocate"))
-
-(defun systemd-mount-SyslogPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SyslogPriority"))
-
-(defun systemd-mount-SyslogIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SyslogIdentifier"))
-
-(defun systemd-mount-SyslogLevelPrefix (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SyslogLevelPrefix"))
-
-(defun systemd-mount-SyslogLevel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SyslogLevel"))
-
-(defun systemd-mount-SyslogFacility (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SyslogFacility"))
-
-(defun systemd-mount-SecureBits (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SecureBits"))
-
-(defun systemd-mount-CapabilityBoundingSet (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "CapabilityBoundingSet"))
-
-(defun systemd-mount-AmbientCapabilities (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "AmbientCapabilities"))
-
-(defun systemd-mount-User (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "User"))
-
-(defun systemd-mount-Group (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Group"))
-
-(defun systemd-mount-SupplementaryGroups (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SupplementaryGroups"))
-
-(defun systemd-mount-PAMName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "PAMName"))
-
-(defun systemd-mount-ReadWriteDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ReadWriteDirectories"))
-
-(defun systemd-mount-ReadOnlyDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ReadOnlyDirectories"))
-
-(defun systemd-mount-InaccessibleDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "InaccessibleDirectories"))
-
-(defun systemd-mount-MountFlags (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "MountFlags"))
-
-(defun systemd-mount-PrivateTmp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "PrivateTmp"))
-
-(defun systemd-mount-PrivateNetwork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "PrivateNetwork"))
-
-(defun systemd-mount-PrivateDevices (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "PrivateDevices"))
-
-(defun systemd-mount-ProtectHome (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ProtectHome"))
-
-(defun systemd-mount-ProtectSystem (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "ProtectSystem"))
-
-(defun systemd-mount-SameProcessGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SameProcessGroup"))
-
-(defun systemd-mount-UtmpIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "UtmpIdentifier"))
-
-(defun systemd-mount-UtmpMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "UtmpMode"))
-
-(defun systemd-mount-SELinuxContext (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SELinuxContext"))
-
-(defun systemd-mount-AppArmorProfile (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "AppArmorProfile"))
-
-(defun systemd-mount-SmackProcessLabel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SmackProcessLabel"))
-
-(defun systemd-mount-IgnoreSIGPIPE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "IgnoreSIGPIPE"))
-
-(defun systemd-mount-NoNewPrivileges (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "NoNewPrivileges"))
-
-(defun systemd-mount-SystemCallFilter (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SystemCallFilter"))
-
-(defun systemd-mount-SystemCallArchitectures (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SystemCallArchitectures"))
-
-(defun systemd-mount-SystemCallErrorNumber (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SystemCallErrorNumber"))
-
-(defun systemd-mount-Personality (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "Personality"))
-
-(defun systemd-mount-RestrictAddressFamilies (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "RestrictAddressFamilies"))
-
-(defun systemd-mount-RuntimeDirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "RuntimeDirectoryMode"))
-
-(defun systemd-mount-RuntimeDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "RuntimeDirectory"))
-
-(defun systemd-mount-KillMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "KillMode"))
-
-(defun systemd-mount-KillSignal (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "KillSignal"))
-
-(defun systemd-mount-SendSIGKILL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SendSIGKILL"))
-
-(defun systemd-mount-SendSIGHUP (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-mount "SendSIGHUP"))
-
-;;; org.freedesktop.systemd1.Path
-
-(defconst systemd-dbus-interface-path "org.freedesktop.systemd1.Path")
-
-(defun systemd-path-Unit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-path "Unit"))
-
-(defun systemd-path-Paths (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-path "Paths"))
-
-(defun systemd-path-MakeDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-path "MakeDirectory"))
-
-(defun systemd-path-DirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-path "DirectoryMode"))
-
-(defun systemd-path-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-path "Result"))
-
-;;; org.freedesktop.systemd1.Scope
-
-(defconst systemd-dbus-interface-scope "org.freedesktop.systemd1.Scope")
-
-(defun systemd-scope-Controller (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "Controller"))
-
-(defun systemd-scope-TimeoutStopUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "TimeoutStopUSec"))
-
-(defun systemd-scope-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "Result"))
-
-(defun systemd-scope-Abandon (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-scope "Abandon"))
-
-(defun systemd-scope-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "Slice"))
-
-(defun systemd-scope-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "ControlGroup"))
-
-(defun systemd-scope-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "MemoryCurrent"))
-
-(defun systemd-scope-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "CPUUsageNSec"))
-
-(defun systemd-scope-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "TasksCurrent"))
-
-(defun systemd-scope-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-scope "GetProcesses"))
-
-(defun systemd-scope-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "Delegate"))
-
-(defun systemd-scope-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "CPUAccounting"))
-
-(defun systemd-scope-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "CPUShares"))
-
-(defun systemd-scope-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "StartupCPUShares"))
-
-(defun systemd-scope-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "CPUQuotaPerSecUSec"))
-
-(defun systemd-scope-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOAccounting"))
-
-(defun systemd-scope-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOWeight"))
-
-(defun systemd-scope-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "StartupIOWeight"))
-
-(defun systemd-scope-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IODeviceWeight"))
-
-(defun systemd-scope-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOReadBandwidthMax"))
-
-(defun systemd-scope-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOWriteBandwidthMax"))
-
-(defun systemd-scope-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOReadIOPSMax"))
-
-(defun systemd-scope-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "IOWriteIOPSMax"))
-
-(defun systemd-scope-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "BlockIOAccounting"))
-
-(defun systemd-scope-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "BlockIOWeight"))
-
-(defun systemd-scope-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "StartupBlockIOWeight"))
-
-(defun systemd-scope-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "BlockIODeviceWeight"))
-
-(defun systemd-scope-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "BlockIOReadBandwidth"))
-
-(defun systemd-scope-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "BlockIOWriteBandwidth"))
-
-(defun systemd-scope-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "MemoryAccounting"))
-
-(defun systemd-scope-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "MemoryLimit"))
-
-(defun systemd-scope-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "DevicePolicy"))
-
-(defun systemd-scope-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "DeviceAllow"))
-
-(defun systemd-scope-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "TasksAccounting"))
-
-(defun systemd-scope-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "TasksMax"))
-
-(defun systemd-scope-KillMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "KillMode"))
-
-(defun systemd-scope-KillSignal (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "KillSignal"))
-
-(defun systemd-scope-SendSIGKILL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "SendSIGKILL"))
-
-(defun systemd-scope-SendSIGHUP (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-scope "SendSIGHUP"))
-
-;;; org.freedesktop.systemd1.Service
-
-(defconst systemd-dbus-interface-service "org.freedesktop.systemd1.Service")
-
-(defun systemd-service-Type (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Type"))
-
-(defun systemd-service-Restart (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Restart"))
-
-(defun systemd-service-PIDFile (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PIDFile"))
-
-(defun systemd-service-NotifyAccess (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "NotifyAccess"))
-
-(defun systemd-service-RestartUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RestartUSec"))
-
-(defun systemd-service-TimeoutStartUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TimeoutStartUSec"))
-
-(defun systemd-service-TimeoutStopUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TimeoutStopUSec"))
-
-(defun systemd-service-RuntimeMaxUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RuntimeMaxUSec"))
-
-(defun systemd-service-WatchdogUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "WatchdogUSec"))
-
-(defun systemd-service-WatchdogTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "WatchdogTimestamp"))
-
-(defun systemd-service-WatchdogTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service
"WatchdogTimestampMonotonic"))
-
-(defun systemd-service-FailureAction (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "FailureAction"))
-
-(defun systemd-service-PermissionsStartOnly (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PermissionsStartOnly"))
-
-(defun systemd-service-RootDirectoryStartOnly (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RootDirectoryStartOnly"))
-
-(defun systemd-service-RemainAfterExit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RemainAfterExit"))
-
-(defun systemd-service-GuessMainPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "GuessMainPID"))
-
-(defun systemd-service-MainPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "MainPID"))
-
-(defun systemd-service-ControlPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ControlPID"))
-
-(defun systemd-service-BusName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BusName"))
-
-(defun systemd-service-FileDescriptorStoreMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "FileDescriptorStoreMax"))
-
-(defun systemd-service-NFileDescriptorStore (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "NFileDescriptorStore"))
-
-(defun systemd-service-StatusText (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StatusText"))
-
-(defun systemd-service-StatusErrno (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StatusErrno"))
-
-(defun systemd-service-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Result"))
-
-(defun systemd-service-USBFunctionDescriptors (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "USBFunctionDescriptors"))
-
-(defun systemd-service-USBFunctionStrings (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "USBFunctionStrings"))
-
-(defun systemd-service-ExecMainStartTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecMainStartTimestamp"))
-
-(defun systemd-service-ExecMainStartTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service
"ExecMainStartTimestampMonotonic"))
-
-(defun systemd-service-ExecMainExitTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecMainExitTimestamp"))
-
-(defun systemd-service-ExecMainExitTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service
"ExecMainExitTimestampMonotonic"))
-
-(defun systemd-service-ExecMainPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecMainPID"))
-
-(defun systemd-service-ExecMainCode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecMainCode"))
-
-(defun systemd-service-ExecMainStatus (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecMainStatus"))
-
-(defun systemd-service-ExecStartPre (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecStartPre"))
-
-(defun systemd-service-ExecStart (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecStart"))
-
-(defun systemd-service-ExecStartPost (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecStartPost"))
-
-(defun systemd-service-ExecReload (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecReload"))
-
-(defun systemd-service-ExecStop (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecStop"))
-
-(defun systemd-service-ExecStopPost (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ExecStopPost"))
-
-(defun systemd-service-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Slice"))
-
-(defun systemd-service-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ControlGroup"))
-
-(defun systemd-service-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "MemoryCurrent"))
-
-(defun systemd-service-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUUsageNSec"))
-
-(defun systemd-service-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TasksCurrent"))
-
-(defun systemd-service-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-service "GetProcesses"))
-
-(defun systemd-service-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Delegate"))
-
-(defun systemd-service-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUAccounting"))
-
-(defun systemd-service-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUShares"))
-
-(defun systemd-service-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StartupCPUShares"))
-
-(defun systemd-service-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUQuotaPerSecUSec"))
-
-(defun systemd-service-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOAccounting"))
-
-(defun systemd-service-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOWeight"))
-
-(defun systemd-service-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StartupIOWeight"))
-
-(defun systemd-service-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IODeviceWeight"))
-
-(defun systemd-service-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOReadBandwidthMax"))
-
-(defun systemd-service-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOWriteBandwidthMax"))
-
-(defun systemd-service-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOReadIOPSMax"))
-
-(defun systemd-service-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOWriteIOPSMax"))
-
-(defun systemd-service-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BlockIOAccounting"))
-
-(defun systemd-service-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BlockIOWeight"))
-
-(defun systemd-service-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StartupBlockIOWeight"))
-
-(defun systemd-service-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BlockIODeviceWeight"))
-
-(defun systemd-service-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BlockIOReadBandwidth"))
-
-(defun systemd-service-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "BlockIOWriteBandwidth"))
-
-(defun systemd-service-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "MemoryAccounting"))
-
-(defun systemd-service-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "MemoryLimit"))
-
-(defun systemd-service-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "DevicePolicy"))
-
-(defun systemd-service-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "DeviceAllow"))
-
-(defun systemd-service-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TasksAccounting"))
-
-(defun systemd-service-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TasksMax"))
-
-(defun systemd-service-Environment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Environment"))
-
-(defun systemd-service-EnvironmentFiles (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "EnvironmentFiles"))
-
-(defun systemd-service-PassEnvironment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PassEnvironment"))
-
-(defun systemd-service-UMask (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "UMask"))
-
-(defun systemd-service-LimitCPU (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitCPU"))
-
-(defun systemd-service-LimitCPUSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitCPUSoft"))
-
-(defun systemd-service-LimitFSIZE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitFSIZE"))
-
-(defun systemd-service-LimitFSIZESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitFSIZESoft"))
-
-(defun systemd-service-LimitDATA (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitDATA"))
-
-(defun systemd-service-LimitDATASoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitDATASoft"))
-
-(defun systemd-service-LimitSTACK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitSTACK"))
-
-(defun systemd-service-LimitSTACKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitSTACKSoft"))
-
-(defun systemd-service-LimitCORE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitCORE"))
-
-(defun systemd-service-LimitCORESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitCORESoft"))
-
-(defun systemd-service-LimitRSS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRSS"))
-
-(defun systemd-service-LimitRSSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRSSSoft"))
-
-(defun systemd-service-LimitNOFILE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNOFILE"))
-
-(defun systemd-service-LimitNOFILESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNOFILESoft"))
-
-(defun systemd-service-LimitAS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitAS"))
-
-(defun systemd-service-LimitASSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitASSoft"))
-
-(defun systemd-service-LimitNPROC (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNPROC"))
-
-(defun systemd-service-LimitNPROCSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNPROCSoft"))
-
-(defun systemd-service-LimitMEMLOCK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitMEMLOCK"))
-
-(defun systemd-service-LimitMEMLOCKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitMEMLOCKSoft"))
-
-(defun systemd-service-LimitLOCKS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitLOCKS"))
-
-(defun systemd-service-LimitLOCKSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitLOCKSSoft"))
-
-(defun systemd-service-LimitSIGPENDING (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitSIGPENDING"))
-
-(defun systemd-service-LimitSIGPENDINGSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitSIGPENDINGSoft"))
-
-(defun systemd-service-LimitMSGQUEUE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitMSGQUEUE"))
-
-(defun systemd-service-LimitMSGQUEUESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitMSGQUEUESoft"))
-
-(defun systemd-service-LimitNICE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNICE"))
-
-(defun systemd-service-LimitNICESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitNICESoft"))
-
-(defun systemd-service-LimitRTPRIO (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRTPRIO"))
-
-(defun systemd-service-LimitRTPRIOSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRTPRIOSoft"))
-
-(defun systemd-service-LimitRTTIME (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRTTIME"))
-
-(defun systemd-service-LimitRTTIMESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "LimitRTTIMESoft"))
-
-(defun systemd-service-WorkingDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "WorkingDirectory"))
-
-(defun systemd-service-RootDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RootDirectory"))
-
-(defun systemd-service-OOMScoreAdjust (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "OOMScoreAdjust"))
-
-(defun systemd-service-Nice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Nice"))
-
-(defun systemd-service-IOScheduling (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IOScheduling"))
-
-(defun systemd-service-CPUSchedulingPolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUSchedulingPolicy"))
-
-(defun systemd-service-CPUSchedulingPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUSchedulingPriority"))
-
-(defun systemd-service-CPUAffinity (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUAffinity"))
-
-(defun systemd-service-TimerSlackNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TimerSlackNSec"))
-
-(defun systemd-service-CPUSchedulingResetOnFork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CPUSchedulingResetOnFork"))
-
-(defun systemd-service-NonBlocking (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "NonBlocking"))
-
-(defun systemd-service-StandardInput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StandardInput"))
-
-(defun systemd-service-StandardOutput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StandardOutput"))
-
-(defun systemd-service-StandardError (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "StandardError"))
-
-(defun systemd-service-TTYPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TTYPath"))
-
-(defun systemd-service-TTYReset (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TTYReset"))
-
-(defun systemd-service-TTYVHangup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TTYVHangup"))
-
-(defun systemd-service-TTYVTDisallocate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "TTYVTDisallocate"))
-
-(defun systemd-service-SyslogPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SyslogPriority"))
-
-(defun systemd-service-SyslogIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SyslogIdentifier"))
-
-(defun systemd-service-SyslogLevelPrefix (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SyslogLevelPrefix"))
-
-(defun systemd-service-SyslogLevel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SyslogLevel"))
-
-(defun systemd-service-SyslogFacility (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SyslogFacility"))
-
-(defun systemd-service-SecureBits (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SecureBits"))
-
-(defun systemd-service-CapabilityBoundingSet (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "CapabilityBoundingSet"))
-
-(defun systemd-service-AmbientCapabilities (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "AmbientCapabilities"))
-
-(defun systemd-service-User (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "User"))
-
-(defun systemd-service-Group (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Group"))
-
-(defun systemd-service-SupplementaryGroups (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SupplementaryGroups"))
-
-(defun systemd-service-PAMName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PAMName"))
-
-(defun systemd-service-ReadWriteDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ReadWriteDirectories"))
-
-(defun systemd-service-ReadOnlyDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ReadOnlyDirectories"))
-
-(defun systemd-service-InaccessibleDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "InaccessibleDirectories"))
-
-(defun systemd-service-MountFlags (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "MountFlags"))
-
-(defun systemd-service-PrivateTmp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PrivateTmp"))
-
-(defun systemd-service-PrivateNetwork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PrivateNetwork"))
-
-(defun systemd-service-PrivateDevices (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "PrivateDevices"))
-
-(defun systemd-service-ProtectHome (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ProtectHome"))
-
-(defun systemd-service-ProtectSystem (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "ProtectSystem"))
-
-(defun systemd-service-SameProcessGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SameProcessGroup"))
-
-(defun systemd-service-UtmpIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "UtmpIdentifier"))
-
-(defun systemd-service-UtmpMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "UtmpMode"))
-
-(defun systemd-service-SELinuxContext (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SELinuxContext"))
-
-(defun systemd-service-AppArmorProfile (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "AppArmorProfile"))
-
-(defun systemd-service-SmackProcessLabel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SmackProcessLabel"))
-
-(defun systemd-service-IgnoreSIGPIPE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "IgnoreSIGPIPE"))
-
-(defun systemd-service-NoNewPrivileges (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "NoNewPrivileges"))
-
-(defun systemd-service-SystemCallFilter (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SystemCallFilter"))
-
-(defun systemd-service-SystemCallArchitectures (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SystemCallArchitectures"))
-
-(defun systemd-service-SystemCallErrorNumber (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SystemCallErrorNumber"))
-
-(defun systemd-service-Personality (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "Personality"))
-
-(defun systemd-service-RestrictAddressFamilies (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RestrictAddressFamilies"))
-
-(defun systemd-service-RuntimeDirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RuntimeDirectoryMode"))
-
-(defun systemd-service-RuntimeDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "RuntimeDirectory"))
-
-(defun systemd-service-KillMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "KillMode"))
-
-(defun systemd-service-KillSignal (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "KillSignal"))
-
-(defun systemd-service-SendSIGKILL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SendSIGKILL"))
-
-(defun systemd-service-SendSIGHUP (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-service "SendSIGHUP"))
-
-;;; org.freedesktop.systemd1.Slice
-
-(defconst systemd-dbus-interface-slice "org.freedesktop.systemd1.Slice")
-
-(defun systemd-slice-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "Slice"))
-
-(defun systemd-slice-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "ControlGroup"))
-
-(defun systemd-slice-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "MemoryCurrent"))
-
-(defun systemd-slice-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "CPUUsageNSec"))
-
-(defun systemd-slice-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "TasksCurrent"))
-
-(defun systemd-slice-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-slice "GetProcesses"))
-
-(defun systemd-slice-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "Delegate"))
-
-(defun systemd-slice-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "CPUAccounting"))
-
-(defun systemd-slice-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "CPUShares"))
-
-(defun systemd-slice-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "StartupCPUShares"))
-
-(defun systemd-slice-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "CPUQuotaPerSecUSec"))
-
-(defun systemd-slice-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOAccounting"))
-
-(defun systemd-slice-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOWeight"))
-
-(defun systemd-slice-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "StartupIOWeight"))
-
-(defun systemd-slice-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IODeviceWeight"))
-
-(defun systemd-slice-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOReadBandwidthMax"))
-
-(defun systemd-slice-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOWriteBandwidthMax"))
-
-(defun systemd-slice-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOReadIOPSMax"))
-
-(defun systemd-slice-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "IOWriteIOPSMax"))
-
-(defun systemd-slice-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "BlockIOAccounting"))
-
-(defun systemd-slice-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "BlockIOWeight"))
-
-(defun systemd-slice-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "StartupBlockIOWeight"))
-
-(defun systemd-slice-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "BlockIODeviceWeight"))
-
-(defun systemd-slice-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "BlockIOReadBandwidth"))
-
-(defun systemd-slice-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "BlockIOWriteBandwidth"))
-
-(defun systemd-slice-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "MemoryAccounting"))
-
-(defun systemd-slice-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "MemoryLimit"))
-
-(defun systemd-slice-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "DevicePolicy"))
-
-(defun systemd-slice-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "DeviceAllow"))
-
-(defun systemd-slice-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "TasksAccounting"))
-
-(defun systemd-slice-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-slice "TasksMax"))
-
-;;; org.freedesktop.systemd1.Socket
-
-(defconst systemd-dbus-interface-socket "org.freedesktop.systemd1.Socket")
-
-(defun systemd-socket-BindIPv6Only (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BindIPv6Only"))
-
-(defun systemd-socket-Backlog (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Backlog"))
-
-(defun systemd-socket-TimeoutUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TimeoutUSec"))
-
-(defun systemd-socket-BindToDevice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BindToDevice"))
-
-(defun systemd-socket-SocketUser (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SocketUser"))
-
-(defun systemd-socket-SocketGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SocketGroup"))
-
-(defun systemd-socket-SocketMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SocketMode"))
-
-(defun systemd-socket-DirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "DirectoryMode"))
-
-(defun systemd-socket-Accept (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Accept"))
-
-(defun systemd-socket-Writable (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Writable"))
-
-(defun systemd-socket-KeepAlive (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KeepAlive"))
-
-(defun systemd-socket-KeepAliveTimeUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KeepAliveTimeUSec"))
-
-(defun systemd-socket-KeepAliveIntervalUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KeepAliveIntervalUSec"))
-
-(defun systemd-socket-KeepAliveProbes (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KeepAliveProbes"))
-
-(defun systemd-socket-DeferAcceptUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "DeferAcceptUSec"))
-
-(defun systemd-socket-NoDelay (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "NoDelay"))
-
-(defun systemd-socket-Priority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Priority"))
-
-(defun systemd-socket-ReceiveBuffer (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ReceiveBuffer"))
-
-(defun systemd-socket-SendBuffer (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SendBuffer"))
-
-(defun systemd-socket-IPTOS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IPTOS"))
-
-(defun systemd-socket-IPTTL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IPTTL"))
-
-(defun systemd-socket-PipeSize (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PipeSize"))
-
-(defun systemd-socket-FreeBind (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "FreeBind"))
-
-(defun systemd-socket-Transparent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Transparent"))
-
-(defun systemd-socket-Broadcast (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Broadcast"))
-
-(defun systemd-socket-PassCredentials (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PassCredentials"))
-
-(defun systemd-socket-PassSecurity (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PassSecurity"))
-
-(defun systemd-socket-RemoveOnStop (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "RemoveOnStop"))
-
-(defun systemd-socket-Listen (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Listen"))
-
-(defun systemd-socket-Symlinks (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Symlinks"))
-
-(defun systemd-socket-Mark (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Mark"))
-
-(defun systemd-socket-MaxConnections (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MaxConnections"))
-
-(defun systemd-socket-MessageQueueMaxMessages (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MessageQueueMaxMessages"))
-
-(defun systemd-socket-MessageQueueMessageSize (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MessageQueueMessageSize"))
-
-(defun systemd-socket-ReusePort (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ReusePort"))
-
-(defun systemd-socket-SmackLabel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SmackLabel"))
-
-(defun systemd-socket-SmackLabelIPIn (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SmackLabelIPIn"))
-
-(defun systemd-socket-SmackLabelIPOut (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SmackLabelIPOut"))
-
-(defun systemd-socket-ControlPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ControlPID"))
-
-(defun systemd-socket-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Result"))
-
-(defun systemd-socket-NConnections (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "NConnections"))
-
-(defun systemd-socket-NAccepted (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "NAccepted"))
-
-(defun systemd-socket-FileDescriptorName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "FileDescriptorName"))
-
-(defun systemd-socket-SocketProtocol (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SocketProtocol"))
-
-(defun systemd-socket-TriggerLimitIntervalUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TriggerLimitIntervalUSec"))
-
-(defun systemd-socket-TriggerLimitBurst (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TriggerLimitBurst"))
-
-(defun systemd-socket-ExecStartPre (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ExecStartPre"))
-
-(defun systemd-socket-ExecStartPost (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ExecStartPost"))
-
-(defun systemd-socket-ExecStopPre (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ExecStopPre"))
-
-(defun systemd-socket-ExecStopPost (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ExecStopPost"))
-
-(defun systemd-socket-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Slice"))
-
-(defun systemd-socket-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ControlGroup"))
-
-(defun systemd-socket-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MemoryCurrent"))
-
-(defun systemd-socket-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUUsageNSec"))
-
-(defun systemd-socket-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TasksCurrent"))
-
-(defun systemd-socket-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-socket "GetProcesses"))
-
-(defun systemd-socket-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Delegate"))
-
-(defun systemd-socket-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUAccounting"))
-
-(defun systemd-socket-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUShares"))
-
-(defun systemd-socket-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StartupCPUShares"))
-
-(defun systemd-socket-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUQuotaPerSecUSec"))
-
-(defun systemd-socket-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOAccounting"))
-
-(defun systemd-socket-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOWeight"))
-
-(defun systemd-socket-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StartupIOWeight"))
-
-(defun systemd-socket-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IODeviceWeight"))
-
-(defun systemd-socket-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOReadBandwidthMax"))
-
-(defun systemd-socket-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOWriteBandwidthMax"))
-
-(defun systemd-socket-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOReadIOPSMax"))
-
-(defun systemd-socket-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOWriteIOPSMax"))
-
-(defun systemd-socket-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BlockIOAccounting"))
-
-(defun systemd-socket-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BlockIOWeight"))
-
-(defun systemd-socket-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StartupBlockIOWeight"))
-
-(defun systemd-socket-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BlockIODeviceWeight"))
-
-(defun systemd-socket-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BlockIOReadBandwidth"))
-
-(defun systemd-socket-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "BlockIOWriteBandwidth"))
-
-(defun systemd-socket-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MemoryAccounting"))
-
-(defun systemd-socket-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MemoryLimit"))
-
-(defun systemd-socket-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "DevicePolicy"))
-
-(defun systemd-socket-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "DeviceAllow"))
-
-(defun systemd-socket-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TasksAccounting"))
-
-(defun systemd-socket-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TasksMax"))
-
-(defun systemd-socket-Environment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Environment"))
-
-(defun systemd-socket-EnvironmentFiles (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "EnvironmentFiles"))
-
-(defun systemd-socket-PassEnvironment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PassEnvironment"))
-
-(defun systemd-socket-UMask (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "UMask"))
-
-(defun systemd-socket-LimitCPU (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitCPU"))
-
-(defun systemd-socket-LimitCPUSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitCPUSoft"))
-
-(defun systemd-socket-LimitFSIZE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitFSIZE"))
-
-(defun systemd-socket-LimitFSIZESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitFSIZESoft"))
-
-(defun systemd-socket-LimitDATA (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitDATA"))
-
-(defun systemd-socket-LimitDATASoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitDATASoft"))
-
-(defun systemd-socket-LimitSTACK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitSTACK"))
-
-(defun systemd-socket-LimitSTACKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitSTACKSoft"))
-
-(defun systemd-socket-LimitCORE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitCORE"))
-
-(defun systemd-socket-LimitCORESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitCORESoft"))
-
-(defun systemd-socket-LimitRSS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRSS"))
-
-(defun systemd-socket-LimitRSSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRSSSoft"))
-
-(defun systemd-socket-LimitNOFILE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNOFILE"))
-
-(defun systemd-socket-LimitNOFILESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNOFILESoft"))
-
-(defun systemd-socket-LimitAS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitAS"))
-
-(defun systemd-socket-LimitASSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitASSoft"))
-
-(defun systemd-socket-LimitNPROC (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNPROC"))
-
-(defun systemd-socket-LimitNPROCSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNPROCSoft"))
-
-(defun systemd-socket-LimitMEMLOCK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitMEMLOCK"))
-
-(defun systemd-socket-LimitMEMLOCKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitMEMLOCKSoft"))
-
-(defun systemd-socket-LimitLOCKS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitLOCKS"))
-
-(defun systemd-socket-LimitLOCKSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitLOCKSSoft"))
-
-(defun systemd-socket-LimitSIGPENDING (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitSIGPENDING"))
-
-(defun systemd-socket-LimitSIGPENDINGSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitSIGPENDINGSoft"))
-
-(defun systemd-socket-LimitMSGQUEUE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitMSGQUEUE"))
-
-(defun systemd-socket-LimitMSGQUEUESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitMSGQUEUESoft"))
-
-(defun systemd-socket-LimitNICE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNICE"))
-
-(defun systemd-socket-LimitNICESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitNICESoft"))
-
-(defun systemd-socket-LimitRTPRIO (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRTPRIO"))
-
-(defun systemd-socket-LimitRTPRIOSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRTPRIOSoft"))
-
-(defun systemd-socket-LimitRTTIME (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRTTIME"))
-
-(defun systemd-socket-LimitRTTIMESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "LimitRTTIMESoft"))
-
-(defun systemd-socket-WorkingDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "WorkingDirectory"))
-
-(defun systemd-socket-RootDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "RootDirectory"))
-
-(defun systemd-socket-OOMScoreAdjust (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "OOMScoreAdjust"))
-
-(defun systemd-socket-Nice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Nice"))
-
-(defun systemd-socket-IOScheduling (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IOScheduling"))
-
-(defun systemd-socket-CPUSchedulingPolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUSchedulingPolicy"))
-
-(defun systemd-socket-CPUSchedulingPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUSchedulingPriority"))
-
-(defun systemd-socket-CPUAffinity (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUAffinity"))
-
-(defun systemd-socket-TimerSlackNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TimerSlackNSec"))
-
-(defun systemd-socket-CPUSchedulingResetOnFork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CPUSchedulingResetOnFork"))
-
-(defun systemd-socket-NonBlocking (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "NonBlocking"))
-
-(defun systemd-socket-StandardInput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StandardInput"))
-
-(defun systemd-socket-StandardOutput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StandardOutput"))
-
-(defun systemd-socket-StandardError (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "StandardError"))
-
-(defun systemd-socket-TTYPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TTYPath"))
-
-(defun systemd-socket-TTYReset (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TTYReset"))
-
-(defun systemd-socket-TTYVHangup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TTYVHangup"))
-
-(defun systemd-socket-TTYVTDisallocate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "TTYVTDisallocate"))
-
-(defun systemd-socket-SyslogPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SyslogPriority"))
-
-(defun systemd-socket-SyslogIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SyslogIdentifier"))
-
-(defun systemd-socket-SyslogLevelPrefix (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SyslogLevelPrefix"))
-
-(defun systemd-socket-SyslogLevel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SyslogLevel"))
-
-(defun systemd-socket-SyslogFacility (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SyslogFacility"))
-
-(defun systemd-socket-SecureBits (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SecureBits"))
-
-(defun systemd-socket-CapabilityBoundingSet (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "CapabilityBoundingSet"))
-
-(defun systemd-socket-AmbientCapabilities (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "AmbientCapabilities"))
-
-(defun systemd-socket-User (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "User"))
-
-(defun systemd-socket-Group (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Group"))
-
-(defun systemd-socket-SupplementaryGroups (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SupplementaryGroups"))
-
-(defun systemd-socket-PAMName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PAMName"))
-
-(defun systemd-socket-ReadWriteDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ReadWriteDirectories"))
-
-(defun systemd-socket-ReadOnlyDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ReadOnlyDirectories"))
-
-(defun systemd-socket-InaccessibleDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "InaccessibleDirectories"))
-
-(defun systemd-socket-MountFlags (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "MountFlags"))
-
-(defun systemd-socket-PrivateTmp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PrivateTmp"))
-
-(defun systemd-socket-PrivateNetwork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PrivateNetwork"))
-
-(defun systemd-socket-PrivateDevices (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "PrivateDevices"))
-
-(defun systemd-socket-ProtectHome (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ProtectHome"))
-
-(defun systemd-socket-ProtectSystem (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "ProtectSystem"))
-
-(defun systemd-socket-SameProcessGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SameProcessGroup"))
-
-(defun systemd-socket-UtmpIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "UtmpIdentifier"))
-
-(defun systemd-socket-UtmpMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "UtmpMode"))
-
-(defun systemd-socket-SELinuxContext (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SELinuxContext"))
-
-(defun systemd-socket-AppArmorProfile (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "AppArmorProfile"))
-
-(defun systemd-socket-SmackProcessLabel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SmackProcessLabel"))
-
-(defun systemd-socket-IgnoreSIGPIPE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "IgnoreSIGPIPE"))
-
-(defun systemd-socket-NoNewPrivileges (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "NoNewPrivileges"))
-
-(defun systemd-socket-SystemCallFilter (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SystemCallFilter"))
-
-(defun systemd-socket-SystemCallArchitectures (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SystemCallArchitectures"))
-
-(defun systemd-socket-SystemCallErrorNumber (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SystemCallErrorNumber"))
-
-(defun systemd-socket-Personality (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "Personality"))
-
-(defun systemd-socket-RestrictAddressFamilies (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "RestrictAddressFamilies"))
-
-(defun systemd-socket-RuntimeDirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "RuntimeDirectoryMode"))
-
-(defun systemd-socket-RuntimeDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "RuntimeDirectory"))
-
-(defun systemd-socket-KillMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KillMode"))
-
-(defun systemd-socket-KillSignal (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "KillSignal"))
-
-(defun systemd-socket-SendSIGKILL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SendSIGKILL"))
-
-(defun systemd-socket-SendSIGHUP (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-socket "SendSIGHUP"))
-
-;;; org.freedesktop.systemd1.Swap
-
-(defconst systemd-dbus-interface-swap "org.freedesktop.systemd1.Swap")
-
-(defun systemd-swap-What (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "What"))
-
-(defun systemd-swap-Priority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Priority"))
-
-(defun systemd-swap-Options (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Options"))
-
-(defun systemd-swap-TimeoutUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TimeoutUSec"))
-
-(defun systemd-swap-ControlPID (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ControlPID"))
-
-(defun systemd-swap-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Result"))
-
-(defun systemd-swap-ExecActivate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ExecActivate"))
-
-(defun systemd-swap-ExecDeactivate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ExecDeactivate"))
-
-(defun systemd-swap-Slice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Slice"))
-
-(defun systemd-swap-ControlGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ControlGroup"))
-
-(defun systemd-swap-MemoryCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "MemoryCurrent"))
-
-(defun systemd-swap-CPUUsageNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUUsageNSec"))
-
-(defun systemd-swap-TasksCurrent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TasksCurrent"))
-
-(defun systemd-swap-GetProcesses (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-swap "GetProcesses"))
-
-(defun systemd-swap-Delegate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Delegate"))
-
-(defun systemd-swap-CPUAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUAccounting"))
-
-(defun systemd-swap-CPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUShares"))
-
-(defun systemd-swap-StartupCPUShares (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StartupCPUShares"))
-
-(defun systemd-swap-CPUQuotaPerSecUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUQuotaPerSecUSec"))
-
-(defun systemd-swap-IOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOAccounting"))
-
-(defun systemd-swap-IOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOWeight"))
-
-(defun systemd-swap-StartupIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StartupIOWeight"))
-
-(defun systemd-swap-IODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IODeviceWeight"))
-
-(defun systemd-swap-IOReadBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOReadBandwidthMax"))
-
-(defun systemd-swap-IOWriteBandwidthMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOWriteBandwidthMax"))
-
-(defun systemd-swap-IOReadIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOReadIOPSMax"))
-
-(defun systemd-swap-IOWriteIOPSMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOWriteIOPSMax"))
-
-(defun systemd-swap-BlockIOAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "BlockIOAccounting"))
-
-(defun systemd-swap-BlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "BlockIOWeight"))
-
-(defun systemd-swap-StartupBlockIOWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StartupBlockIOWeight"))
-
-(defun systemd-swap-BlockIODeviceWeight (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "BlockIODeviceWeight"))
-
-(defun systemd-swap-BlockIOReadBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "BlockIOReadBandwidth"))
-
-(defun systemd-swap-BlockIOWriteBandwidth (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "BlockIOWriteBandwidth"))
-
-(defun systemd-swap-MemoryAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "MemoryAccounting"))
-
-(defun systemd-swap-MemoryLimit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "MemoryLimit"))
-
-(defun systemd-swap-DevicePolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "DevicePolicy"))
-
-(defun systemd-swap-DeviceAllow (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "DeviceAllow"))
-
-(defun systemd-swap-TasksAccounting (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TasksAccounting"))
-
-(defun systemd-swap-TasksMax (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TasksMax"))
-
-(defun systemd-swap-Environment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Environment"))
-
-(defun systemd-swap-EnvironmentFiles (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "EnvironmentFiles"))
-
-(defun systemd-swap-PassEnvironment (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "PassEnvironment"))
-
-(defun systemd-swap-UMask (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "UMask"))
-
-(defun systemd-swap-LimitCPU (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitCPU"))
-
-(defun systemd-swap-LimitCPUSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitCPUSoft"))
-
-(defun systemd-swap-LimitFSIZE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitFSIZE"))
-
-(defun systemd-swap-LimitFSIZESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitFSIZESoft"))
-
-(defun systemd-swap-LimitDATA (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitDATA"))
-
-(defun systemd-swap-LimitDATASoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitDATASoft"))
-
-(defun systemd-swap-LimitSTACK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitSTACK"))
-
-(defun systemd-swap-LimitSTACKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitSTACKSoft"))
-
-(defun systemd-swap-LimitCORE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitCORE"))
-
-(defun systemd-swap-LimitCORESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitCORESoft"))
-
-(defun systemd-swap-LimitRSS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRSS"))
-
-(defun systemd-swap-LimitRSSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRSSSoft"))
-
-(defun systemd-swap-LimitNOFILE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNOFILE"))
-
-(defun systemd-swap-LimitNOFILESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNOFILESoft"))
-
-(defun systemd-swap-LimitAS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitAS"))
-
-(defun systemd-swap-LimitASSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitASSoft"))
-
-(defun systemd-swap-LimitNPROC (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNPROC"))
-
-(defun systemd-swap-LimitNPROCSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNPROCSoft"))
-
-(defun systemd-swap-LimitMEMLOCK (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitMEMLOCK"))
-
-(defun systemd-swap-LimitMEMLOCKSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitMEMLOCKSoft"))
-
-(defun systemd-swap-LimitLOCKS (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitLOCKS"))
-
-(defun systemd-swap-LimitLOCKSSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitLOCKSSoft"))
-
-(defun systemd-swap-LimitSIGPENDING (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitSIGPENDING"))
-
-(defun systemd-swap-LimitSIGPENDINGSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitSIGPENDINGSoft"))
-
-(defun systemd-swap-LimitMSGQUEUE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitMSGQUEUE"))
-
-(defun systemd-swap-LimitMSGQUEUESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitMSGQUEUESoft"))
-
-(defun systemd-swap-LimitNICE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNICE"))
-
-(defun systemd-swap-LimitNICESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitNICESoft"))
-
-(defun systemd-swap-LimitRTPRIO (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRTPRIO"))
-
-(defun systemd-swap-LimitRTPRIOSoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRTPRIOSoft"))
-
-(defun systemd-swap-LimitRTTIME (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRTTIME"))
-
-(defun systemd-swap-LimitRTTIMESoft (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "LimitRTTIMESoft"))
-
-(defun systemd-swap-WorkingDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "WorkingDirectory"))
-
-(defun systemd-swap-RootDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "RootDirectory"))
-
-(defun systemd-swap-OOMScoreAdjust (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "OOMScoreAdjust"))
-
-(defun systemd-swap-Nice (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Nice"))
-
-(defun systemd-swap-IOScheduling (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IOScheduling"))
-
-(defun systemd-swap-CPUSchedulingPolicy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUSchedulingPolicy"))
-
-(defun systemd-swap-CPUSchedulingPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUSchedulingPriority"))
-
-(defun systemd-swap-CPUAffinity (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUAffinity"))
-
-(defun systemd-swap-TimerSlackNSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TimerSlackNSec"))
-
-(defun systemd-swap-CPUSchedulingResetOnFork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CPUSchedulingResetOnFork"))
-
-(defun systemd-swap-NonBlocking (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "NonBlocking"))
-
-(defun systemd-swap-StandardInput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StandardInput"))
-
-(defun systemd-swap-StandardOutput (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StandardOutput"))
-
-(defun systemd-swap-StandardError (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "StandardError"))
-
-(defun systemd-swap-TTYPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TTYPath"))
-
-(defun systemd-swap-TTYReset (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TTYReset"))
-
-(defun systemd-swap-TTYVHangup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TTYVHangup"))
-
-(defun systemd-swap-TTYVTDisallocate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "TTYVTDisallocate"))
-
-(defun systemd-swap-SyslogPriority (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SyslogPriority"))
-
-(defun systemd-swap-SyslogIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SyslogIdentifier"))
-
-(defun systemd-swap-SyslogLevelPrefix (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SyslogLevelPrefix"))
-
-(defun systemd-swap-SyslogLevel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SyslogLevel"))
-
-(defun systemd-swap-SyslogFacility (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SyslogFacility"))
-
-(defun systemd-swap-SecureBits (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SecureBits"))
-
-(defun systemd-swap-CapabilityBoundingSet (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "CapabilityBoundingSet"))
-
-(defun systemd-swap-AmbientCapabilities (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "AmbientCapabilities"))
-
-(defun systemd-swap-User (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "User"))
-
-(defun systemd-swap-Group (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Group"))
-
-(defun systemd-swap-SupplementaryGroups (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SupplementaryGroups"))
-
-(defun systemd-swap-PAMName (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "PAMName"))
-
-(defun systemd-swap-ReadWriteDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ReadWriteDirectories"))
-
-(defun systemd-swap-ReadOnlyDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ReadOnlyDirectories"))
-
-(defun systemd-swap-InaccessibleDirectories (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "InaccessibleDirectories"))
-
-(defun systemd-swap-MountFlags (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "MountFlags"))
-
-(defun systemd-swap-PrivateTmp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "PrivateTmp"))
-
-(defun systemd-swap-PrivateNetwork (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "PrivateNetwork"))
-
-(defun systemd-swap-PrivateDevices (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "PrivateDevices"))
-
-(defun systemd-swap-ProtectHome (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ProtectHome"))
-
-(defun systemd-swap-ProtectSystem (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "ProtectSystem"))
-
-(defun systemd-swap-SameProcessGroup (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SameProcessGroup"))
-
-(defun systemd-swap-UtmpIdentifier (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "UtmpIdentifier"))
-
-(defun systemd-swap-UtmpMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "UtmpMode"))
-
-(defun systemd-swap-SELinuxContext (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SELinuxContext"))
-
-(defun systemd-swap-AppArmorProfile (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "AppArmorProfile"))
-
-(defun systemd-swap-SmackProcessLabel (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SmackProcessLabel"))
-
-(defun systemd-swap-IgnoreSIGPIPE (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "IgnoreSIGPIPE"))
-
-(defun systemd-swap-NoNewPrivileges (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "NoNewPrivileges"))
-
-(defun systemd-swap-SystemCallFilter (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SystemCallFilter"))
-
-(defun systemd-swap-SystemCallArchitectures (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SystemCallArchitectures"))
-
-(defun systemd-swap-SystemCallErrorNumber (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SystemCallErrorNumber"))
-
-(defun systemd-swap-Personality (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "Personality"))
-
-(defun systemd-swap-RestrictAddressFamilies (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "RestrictAddressFamilies"))
-
-(defun systemd-swap-RuntimeDirectoryMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "RuntimeDirectoryMode"))
-
-(defun systemd-swap-RuntimeDirectory (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "RuntimeDirectory"))
-
-(defun systemd-swap-KillMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "KillMode"))
-
-(defun systemd-swap-KillSignal (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "KillSignal"))
-
-(defun systemd-swap-SendSIGKILL (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SendSIGKILL"))
-
-(defun systemd-swap-SendSIGHUP (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-swap "SendSIGHUP"))
-
-;;; org.freedesktop.systemd1.Target
-
-(defconst systemd-dbus-interface-target "org.freedesktop.systemd1.Target")
-
-;;; org.freedesktop.systemd1.Timer
-
-(defconst systemd-dbus-interface-timer "org.freedesktop.systemd1.Timer")
-
-(defun systemd-timer-Unit (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "Unit"))
-
-(defun systemd-timer-TimersMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "TimersMonotonic"))
-
-(defun systemd-timer-TimersCalendar (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "TimersCalendar"))
-
-(defun systemd-timer-NextElapseUSecRealtime (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "NextElapseUSecRealtime"))
-
-(defun systemd-timer-NextElapseUSecMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "NextElapseUSecMonotonic"))
-
-(defun systemd-timer-LastTriggerUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "LastTriggerUSec"))
-
-(defun systemd-timer-LastTriggerUSecMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "LastTriggerUSecMonotonic"))
-
-(defun systemd-timer-Result (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "Result"))
-
-(defun systemd-timer-AccuracyUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "AccuracyUSec"))
-
-(defun systemd-timer-RandomizedDelayUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "RandomizedDelayUSec"))
-
-(defun systemd-timer-Persistent (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "Persistent"))
-
-(defun systemd-timer-WakeSystem (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "WakeSystem"))
-
-(defun systemd-timer-RemainAfterElapse (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-timer "RemainAfterElapse"))
-
-;;; org.freedesktop.systemd1.Unit
-
-(defconst systemd-dbus-interface-unit "org.freedesktop.systemd1.Unit")
-
-(defun systemd-unit-Id (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Id"))
-
-(defun systemd-unit-Names (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Names"))
-
-(defun systemd-unit-Following (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Following"))
-
-(defun systemd-unit-Requires (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Requires"))
-
-(defun systemd-unit-Requisite (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Requisite"))
-
-(defun systemd-unit-Wants (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Wants"))
-
-(defun systemd-unit-BindsTo (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "BindsTo"))
-
-(defun systemd-unit-PartOf (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "PartOf"))
-
-(defun systemd-unit-RequiredBy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RequiredBy"))
-
-(defun systemd-unit-RequisiteOf (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RequisiteOf"))
-
-(defun systemd-unit-WantedBy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "WantedBy"))
-
-(defun systemd-unit-BoundBy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "BoundBy"))
-
-(defun systemd-unit-ConsistsOf (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ConsistsOf"))
-
-(defun systemd-unit-Conflicts (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Conflicts"))
-
-(defun systemd-unit-ConflictedBy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ConflictedBy"))
-
-(defun systemd-unit-Before (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Before"))
-
-(defun systemd-unit-After (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "After"))
-
-(defun systemd-unit-OnFailure (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "OnFailure"))
-
-(defun systemd-unit-Triggers (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Triggers"))
-
-(defun systemd-unit-TriggeredBy (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "TriggeredBy"))
-
-(defun systemd-unit-PropagatesReloadTo (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "PropagatesReloadTo"))
-
-(defun systemd-unit-ReloadPropagatedFrom (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ReloadPropagatedFrom"))
-
-(defun systemd-unit-JoinsNamespaceOf (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "JoinsNamespaceOf"))
-
-(defun systemd-unit-RequiresMountsFor (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RequiresMountsFor"))
-
-(defun systemd-unit-Documentation (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Documentation"))
-
-(defun systemd-unit-Description (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Description"))
-
-(defun systemd-unit-LoadState (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "LoadState"))
-
-(defun systemd-unit-ActiveState (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ActiveState"))
-
-(defun systemd-unit-SubState (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "SubState"))
-
-(defun systemd-unit-FragmentPath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "FragmentPath"))
-
-(defun systemd-unit-SourcePath (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "SourcePath"))
-
-(defun systemd-unit-DropInPaths (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "DropInPaths"))
-
-(defun systemd-unit-UnitFileState (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "UnitFileState"))
-
-(defun systemd-unit-UnitFilePreset (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "UnitFilePreset"))
-
-(defun systemd-unit-StateChangeTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "StateChangeTimestamp"))
-
-(defun systemd-unit-StateChangeTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit
"StateChangeTimestampMonotonic"))
-
-(defun systemd-unit-InactiveExitTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "InactiveExitTimestamp"))
-
-(defun systemd-unit-InactiveExitTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit
"InactiveExitTimestampMonotonic"))
-
-(defun systemd-unit-ActiveEnterTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ActiveEnterTimestamp"))
-
-(defun systemd-unit-ActiveEnterTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit
"ActiveEnterTimestampMonotonic"))
-
-(defun systemd-unit-ActiveExitTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ActiveExitTimestamp"))
-
-(defun systemd-unit-ActiveExitTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit
"ActiveExitTimestampMonotonic"))
-
-(defun systemd-unit-InactiveEnterTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "InactiveEnterTimestamp"))
-
-(defun systemd-unit-InactiveEnterTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit
"InactiveEnterTimestampMonotonic"))
-
-(defun systemd-unit-CanStart (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "CanStart"))
-
-(defun systemd-unit-CanStop (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "CanStop"))
-
-(defun systemd-unit-CanReload (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "CanReload"))
-
-(defun systemd-unit-CanIsolate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "CanIsolate"))
-
-(defun systemd-unit-Job (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Job"))
-
-(defun systemd-unit-StopWhenUnneeded (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "StopWhenUnneeded"))
-
-(defun systemd-unit-RefuseManualStart (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RefuseManualStart"))
-
-(defun systemd-unit-RefuseManualStop (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RefuseManualStop"))
-
-(defun systemd-unit-AllowIsolate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "AllowIsolate"))
-
-(defun systemd-unit-DefaultDependencies (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "DefaultDependencies"))
-
-(defun systemd-unit-OnFailureJobMode (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "OnFailureJobMode"))
-
-(defun systemd-unit-IgnoreOnIsolate (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "IgnoreOnIsolate"))
-
-(defun systemd-unit-NeedDaemonReload (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "NeedDaemonReload"))
-
-(defun systemd-unit-JobTimeoutUSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "JobTimeoutUSec"))
-
-(defun systemd-unit-JobTimeoutAction (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "JobTimeoutAction"))
-
-(defun systemd-unit-JobTimeoutRebootArgument (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "JobTimeoutRebootArgument"))
-
-(defun systemd-unit-ConditionResult (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ConditionResult"))
-
-(defun systemd-unit-AssertResult (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "AssertResult"))
-
-(defun systemd-unit-ConditionTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ConditionTimestamp"))
-
-(defun systemd-unit-ConditionTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "ConditionTimestampMonotonic"))
-
-(defun systemd-unit-AssertTimestamp (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "AssertTimestamp"))
-
-(defun systemd-unit-AssertTimestampMonotonic (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "AssertTimestampMonotonic"))
-
-(defun systemd-unit-Conditions (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Conditions"))
-
-(defun systemd-unit-Asserts (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Asserts"))
-
-(defun systemd-unit-LoadError (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "LoadError"))
-
-(defun systemd-unit-Transient (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "Transient"))
-
-(defun systemd-unit-StartLimitIntervalSec (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "StartLimitIntervalSec"))
-
-(defun systemd-unit-StartLimitBurst (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "StartLimitBurst"))
-
-(defun systemd-unit-StartLimitAction (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "StartLimitAction"))
-
-(defun systemd-unit-RebootArgument (bus path)
- "Read only property."
- (dbus-get-property bus systemd-dbus-service path
- systemd-dbus-interface-unit "RebootArgument"))
-
-(defun systemd-unit-Start (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "Start" args))
-
-(defun systemd-unit-Stop (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "Stop" args))
-
-(defun systemd-unit-Reload (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "Reload" args))
-
-(defun systemd-unit-Restart (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "Restart" args))
-
-(defun systemd-unit-TryRestart (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "TryRestart" args))
-
-(defun systemd-unit-ReloadOrRestart (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "ReloadOrRestart" args))
-
-(defun systemd-unit-ReloadOrTryRestart (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "ReloadOrTryRestart" args))
-
-(defun systemd-unit-Kill (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "Kill" args))
-
-(defun systemd-unit-ResetFailed (bus path)
- (dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "ResetFailed"))
-
-(defun systemd-unit-SetProperties (bus path &rest args)
- (apply #'dbus-call-method bus systemd-dbus-service path
- systemd-dbus-interface-unit "SetProperties" args))
-
-(provide 'systemd)
-;;; systemd.el ends here
diff --git a/packages/tramp-theme/README b/packages/tramp-theme/README
deleted file mode 100644
index 093c1f0..0000000
--- a/packages/tramp-theme/README
+++ /dev/null
@@ -1,11 +0,0 @@
-This is a custom theme for remote buffers.
-
-It is not an own custom theme by itself. Rather, it is a custom
-theme to run on top of other custom themes. It shall be loaded
-always as the last custom theme, because it inherits existing
-settings.
-
-This custom theme extends `mode-line-buffer-identification' by the
-name of the remote host. It also allows to change faces according
-to the value of `default-directory' of a buffer. See
-`tramp-theme-face-remapping-alist' for customization options.
diff --git a/packages/tramp-theme/tramp-theme.el
b/packages/tramp-theme/tramp-theme.el
deleted file mode 100644
index 050a079..0000000
--- a/packages/tramp-theme/tramp-theme.el
+++ /dev/null
@@ -1,179 +0,0 @@
-;;; tramp-theme.el --- Custom theme for remote buffers
-
-;; Copyright (C) 2016-2017 Free Software Foundation, Inc.
-
-;; Author: Michael Albinus <michael.albinus@gmx.de>
-;; Keywords: convenience, faces
-;; Package: tramp-theme
-;; Version: 0.2
-;; Package-Requires: ((emacs "24.1"))
-
-;; 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is not an own custom theme by itself. Rather, it is a custom
-;; theme to run on top of other custom themes. It shall be loaded
-;; always as the last custom theme, because it inherits existing
-;; settings.
-
-;; This custom theme extends `mode-line-buffer-identification' by the
-;; name of the remote host. It also allows to change faces according
-;; to the value of `default-directory' of a buffer. See
-;; `tramp-theme-face-remapping-alist' for customization options.
-
-;;; Code:
-
-;; This is needed for the customized variables.
-(require 'dired)
-(require 'em-dirs)
-
-(deftheme tramp
- "A custom theme to decorate buffers when they are remote.
-It can be combined with other custom themes.")
-
-(defcustom tramp-theme-face-remapping-alist
- `((nil "^root$"
- (mode-line-buffer-id
- (:inherit mode-line-buffer-id
- :inverse-video
- ;; If the face uses already :inverse-video, we deactivate it.
- ;; Happens on displays of type 'tty, for example.
- ,(null
- (face-inverse-video-p
- 'mode-line-buffer-id nil '(mode-line default)))))))
- "Face remapping for decoration of a remote buffer.
-This is an alist of items (HOST USER REMAPPING-LIST). HOST and
-USER are regular expressions, or nil. REMAPPING-LIST must be an
-alist of face remappings as used by `face-remapping-alist'. If
-USER matches the remote user part of `default-directory', and
-HOST matches the remote host part of `default-directory',
-REMAPPING-LIST is applied to the current buffer.
-
-For instance, the following settings change the background color
-to \"Red\" for frames connected to the remote host \"foo\", it
-changes the background color to \"Green\" for frames connected to
-the remote host \"bar\", and it inverses the fringe face for
-frames using the remote user \"root\":
-
- ((nil \"^root$\" (fringe (:inherit fringe :inverse-video t)))
- (\"^foo$\" nil (default (:background \"Red\")))
- (\"^foo$\" nil (dired-directory (:background \"Red\")))
- (\"^foo$\" nil (eshell-prompt (:foreground \"White\")))
- (\"^bar$\" nil (default (:background \"Green\")))
- (\"^bar$\" nil (dired-directory (:background \"Green\"))))
-
-Per default, `mode-line-buffer-identification' is displayed
-inverse for buffers which are editable with \"root\" permissions."
- :group 'tramp
- :type `(repeat (list (choice :tag "Host regexp" regexp (const nil))
- (choice :tag "User regexp" regexp (const nil))
- (list :tag "Face Remapping"
- face (plist :value-type sexp)))))
-
-(defun tramp-theme-original-value (variable)
- "Return the original value of VARIABLE before loading `tramp-theme'."
- (let ((theme-value (get variable 'theme-value)))
- (or (cdr (car (delete (assoc 'tramp theme-value) theme-value)))
- (get variable 'tramp-theme-original-value))))
-
-(defvar-local tramp-theme-face-remapping-cookies nil
- "Cookies store of local face remapping settings.")
-
-(defun tramp-theme-mode-line-buffer-identification ()
- "Return a list suitable for `mode-line-buffer-identification'.
-It indicates the remote host being used, if any.
-
-Per side effect, it enables also face remapping in the current buffer."
- ;; Clear previous face remappings.
- (mapc 'face-remap-remove-relative tramp-theme-face-remapping-cookies)
- (setq tramp-theme-face-remapping-cookies nil)
-
- (append
- (when (custom-theme-enabled-p 'tramp)
- (let ((host (file-remote-p default-directory 'host))
- (user (file-remote-p default-directory 'user)))
- ;; Apply `tramp-theme-face-remapping-alist'.
- (dolist (elt tramp-theme-face-remapping-alist)
- (when (and (string-match (or (nth 0 elt) "") (or host ""))
- (string-match (or (nth 1 elt) "") (or user "")))
- (push (face-remap-add-relative (car (nth 2 elt)) (cdr (nth 2 elt)))
- tramp-theme-face-remapping-cookies)))
-
- ;; The extended string.
- (when host
- ;; Do not use FQDN.
- (when (string-match "^[^0-9][^.]*\\(\\..*\\)" host)
- (setq host (substring host 0 (match-beginning 1))))
- (list
- (propertize
- (concat (propertize host 'help-echo (purecopy "Host name")) ": ")
- 'face 'mode-line-buffer-id 'mouse-face 'mode-line-highlight)))))
-
- ;; That's the original definition.
- (tramp-theme-original-value 'mode-line-buffer-identification)))
-
-(defun tramp-theme-hook-function ()
- "Modify `mode-line-buffer-indication'.
-Used in different hooks, in order to accelerate the redisplay."
- (setq
- mode-line-buffer-identification
- (tramp-theme-mode-line-buffer-identification)))
-
-(unless (custom-theme-enabled-p 'tramp)
- ;; Save the original value.
- (unless (get 'mode-line-buffer-identification 'tramp-theme-original-value)
- (put 'mode-line-buffer-identification
- 'tramp-theme-original-value
- mode-line-buffer-identification))
-
- (custom-theme-set-variables
- 'tramp
- ;; Extend `mode-line-buffer-identification' by host name.
- '(mode-line-buffer-identification
- '(:eval (tramp-theme-mode-line-buffer-identification)))
- ;; `dired-mode' overwrites `mode-line-buffer-identification'. We
- ;; want to use our own extension.
- '(dired-mode-hook
- (cons
- 'tramp-theme-hook-function
- (delete 'tramp-theme-hook-function dired-mode-hook)))
- ;; Redisplay doesn't happen immediately. So we trigger it via
- ;; `find-file-hook' and `eshell-directory-change-hook'.
- '(find-file-hook
- (cons
- 'tramp-theme-hook-function
- (delete 'tramp-theme-hook-function find-file-hook)))
- '(eshell-directory-change-hook
- (cons
- 'tramp-theme-hook-function
- (delete 'tramp-theme-hook-function eshell-directory-change-hook)))))
-
-;;;###autoload
-(when load-file-name
- (add-to-list
- 'custom-theme-load-path
- (file-name-as-directory (file-name-directory load-file-name))))
-
-(provide-theme 'tramp)
-
-;;; TODO:
-
-;; * Use a :type for `tramp-theme-face-remapping-alist' which allows
-;; to edit the faces. Maybe use (widget-get custom-face-edit :args)
-;; for this.
-
-;;; tramp-theme.el ends here
diff --git a/packages/transcribe/transcribe.el
b/packages/transcribe/transcribe.el
deleted file mode 100644
index 0609a5d..0000000
--- a/packages/transcribe/transcribe.el
+++ /dev/null
@@ -1,419 +0,0 @@
-;;; transcribe.el --- Package for audio transcriptions
-
-;; Copyright 2014-2017 Free Software Foundation, Inc.
-
-;; Author: David Gonzalez Gandara <dggandara@member.fsf.org>
-;; Version: 1.5.2
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; REQUIRES:
-;; -----------------------------
-;; This module works without any requires, but in order to use the audio
-;; functions, you need to install the Emacs package "emms", by Joe Drew,
-;; and the external program "mpg321", by Jorgen Schafer and Ulrik Jensen,
-;; both under GPL licenses.
-;;
-;; USAGE:
-;; -------------------------
-;; Transcribe is a tool to make audio transcriptions for discourse analysis
-;; in the classroom.
-;; It allows the transcriber to control the audio easily while typing, as well
as
-;; automate the insertion of xml tags, in case the transcription protocol
-;; include them.
-;; The analysis functions will search for a specific structure
-;; of episodes that can be automatically added with the macro NewEpisode.
-;; The function expects the speech acts to be transcribed inside a turn xml
-;; tag with the identifier of the speaker with optional move attribute.
-;; Each speech act is spected inside a <l1> or <l2> tag, depending
-;; on the language used by the person. The attributes expected are the
-;; number of clauses that form the utterance, the number of errors the
-;; transcriber observes, and the function of the speech act. The parser will
-;; work even if some attributes are missing.
-;;
-;;
-;; AUDIO COMMANDS
-;; ------------------------------
-;; C-x C-p ------> Play audio file. You will be prompted for the name
-;; of the file. The recommended format is mp2.
-;; <f5> ---------> Pause or play audio.
-;; C-x <right> --> seek audio 10 seconds forward.
-;; C-x <left> --->seek audio 10 seconds backward.
-;; <f8> ---------> seek interactively: positive seconds go forward and
-;; negative seconds go backward
-;;
-;; XML TAGGING COMMANDS
-;; --------------------------------------------------
-;; C-x C-n ------> Create new episode structure. This is useful in case
your
-;; xml file structure requires it.
-;; <f2> ---------> Interactively insert a function attribute in a speech
act
-;; (l1 or l2) tag.
-;; <f3> ---------> Interactively insert a move attribute in a turn
(person) tag
-;; <f4> ---------> Interactively insert an attribute (any kind)
-;; <f9> ---------> Insert turn (person) tag. Inserts a move attribute.
-;; <f10> --------> Insert a custom tag. Edit the function to adapt to your
needs.
-;; <f11> --------> Insert speech act tag in L1, with clauses, errors and
function
-;; attributes.
-;; <f12> --------> Insert speech act tag in L2, with clauses, errors and
function
-;; attributes.
-;;
-;; AUTOMATIC PARSING
-;; -----------------------------------------------------
-;; C-x C-a ------> Analyses the text for measurments of performance.
-
-;;; Code:
-
-(require 'xml)
-
-;; (if t (require 'emms-setup))
-;; (require 'emms-player-mpd)
-;; (setq emms-player-mpd-server-name "localhost")
-;; (setq emms-player-mpd-server-port "6600")
-
-(emms-standard)
-(emms-default-players)
-(if t (require 'emms-player-mpg321-remote))
-(defvar emms-player-list)
-(push 'emms-player-mpg321-remote emms-player-list)
-
-(if t (require 'emms-mode-line));FIXME: isn't `emms-mode-line' autoloaded?
-(emms-mode-line 1)
-(if t (require 'emms-playing-time));FIXME: isn't `emms-playing-time'
autoloaded?
-(emms-playing-time 1)
-
-(defvar transcribe-function-list '("initiating" "responding" "control"
"expressive" "interpersonal"))
-(defvar transcribe-move-list '("initiation" "response" "follow-up"))
-(defvar transcribe-attribute-list '("clauses" "errors" "function" "move"))
-;; (append transcribe-attribute-list transcribe-function-list
transcribe-move-list)
-
-(defun transcribe-analyze-episode (episode person)
- "This calls the external python package analyze_episodes2.py. The new
- function transcribe-analyze implements its role now."
- (interactive "sepisode: \nsperson:")
- (shell-command (concat (expand-file-name "analyze_episodes2.py")
- " -e " episode " -p " person " -i " buffer-file-name )))
-
-(defun transcribe-raw-to-buffer ()
- "EXPERIMENTAL - Convert the xml tagged transcription to raw transcription,
with the names
- and the persons and the utterances only. The raw transcription will be send
to buffer called
- `Raw Output'."
- (interactive)
- (let* ((xml (xml-parse-region (point-min) (point-max)))
- (results (car xml))
- (episodes (xml-get-children results 'episode)))
-
- (dolist (episode episodes)
- (let* ((transcription (xml-get-children episode 'transcription)))
-
- (dolist (turn transcription)
- (dolist (intervention (xml-node-children turn))
- (if (listp intervention)
- (progn
- (with-current-buffer "Raw Output"
- (insert (format "%s\t" (line-number-at-pos)))
- (insert (format "%s:\t" (car intervention)))
- (dolist (utterance (nthcdr 2 intervention))
- (if (listp utterance)
- (progn
- (insert (format "%s " (nth 2 utterance))))
-
- (insert (format "%s" utterance))))))
-
- (with-current-buffer "Raw Output"
- (insert (format "%s" (line-number-at-pos)))
- (insert (format "%s" intervention))))))))))
-
-(defun transcribe-analyze (episodenumber personid)
- "Extract from a given episode and person the number of asunits per
- second produced, and the number of clauses per asunits, for L2 and L1.
- It writes two output files, one for L2 utterances and one for L1
- utterances, so that they can be used with external programs. Output will
- be inserted in `Statistics Output' buffer."
- (interactive "sepisodenumber: \nspersonid:")
- (let* ((interventionsl2 '())
- (interventionsl1 '())
- (xml (xml-parse-region (point-min) (point-max)))
- (results (car xml))
- (episodes (xml-get-children results 'episode))
- (asunitsl2 0.0000)
- (asunitsl1 0.0000)
- (shifts 0.0000);; TODO implement
- (initiating 0.0000)
- (responding 0.0000)
- (control 0.0000)
- (expressive 0.0000)
- (interpersonal 0.0000)
- (clausesl1 0.0000)
- ;; (errorsl1 0.0000);; TODO implement
- (clausesl2 0.0000)
- (errorsl2 0.0000)
- (duration nil)
- (role nil)
- (context nil)
- (demand nil)
- ;; (clausesmessage nil)
- (number nil))
-
- (dolist (episode episodes)
- (let*((numbernode (xml-get-children episode 'number))
- (tasknode (xml-get-children episode 'task)))
-
- (setq number (nth 2 (car numbernode)))
- (when (equal episodenumber number)
- (let* ((durationnode (xml-get-children episode 'duration))
- (transcription (xml-get-children episode 'transcription)))
-
- (setq duration (nth 2 (car durationnode)))
-
- (dolist (task tasknode)
- (let* ((rolenode (xml-get-children task 'role))
- (contextnode (xml-get-children task 'context))
- (demandnode (xml-get-children task 'demand)))
-
- (setq role (nth 2 (car rolenode)))
- (setq context (nth 2 (car contextnode)))
- (setq demand (nth 2 (car demandnode)))
- ;; (with-current-buffer "Statistics Output"
- ;; (insert (format "role: %s; context: %s; demand: %s\n"
role context demand)))
- ))
-
- (dolist (turn transcription)
- (let* ((interventionnode (xml-get-children turn
- (intern personid))))
-
- (dolist (intervention interventionnode)
- (let* ((l2node (xml-get-children intervention 'l2))
- (l1node (xml-get-children intervention 'l1)))
-
- (dolist (l2turn l2node)
- (let* ((l2 (nth 2 l2turn))
- (attrs (nth 1 l2turn))
- (clausesl2nodeinc (cdr (assq 'clauses attrs)))
- (errorsl2inc (cdr (assq 'errors attrs)))
- (function (cdr (assq 'function attrs))))
-
- (when (string-equal function "initiating")
- (setq initiating (+ initiating 1)))
- (when (string-equal function "responding")
- (setq responding (+ responding 1)))
- (when (string-equal function "control")
- (setq control (+ control 1)))
- (when (string-equal function "expressive")
- (setq expressive (+ expressive 1)))
- (when (string-equal function "interpersonal")
- (setq interpersonal (+ interpersonal 1)))
- (when attrs
- (setq clausesl2 (+ clausesl2 (string-to-number
- clausesl2nodeinc)))
- (setq errorsl2 (+ errorsl2 (string-to-number
- errorsl2inc))))
- (when l2
- ;; (add-to-list 'interventionsl2 l2)
- (when (string-match "@*" l2) (setq shifts (1+
shifts)))
- (cl-pushnew l2 interventionsl2 :test #'equal)
- (setq asunitsl2 (1+ asunitsl2)))))
- (dolist (l1turn l1node)
- (let*((l1 (nth 2 l1turn))
- (clausesl1node (nth 1 l1turn))
- (clausesl1nodeinc (cdr (car clausesl1node))))
-
- (when (not (equal clausesl1node nil))
- (setq clausesl1 (+ clausesl1 (string-to-number
- clausesl1nodeinc))))
- (when l1
- ;; (add-to-list 'interventionsl1 l1)
- (when (string-match "@*" l1) (setq shifts (1+
shifts)))
- (cl-pushnew l1 interventionsl1 :test #'equal)
- (setq asunitsl1 (1+ asunitsl1)))))))))))))
- ;; (reverse interventionsl2)
- ;; (write-region (format "%s" interventionsl2) nil (format
"transcribe-output-%s-%s-l2.txt" episodenumber personid))
- ;; Write raw interventions to file will be supported by a different function
- ;; (reverse interventionsl1)
- ;; (write-region (format "%s" interventionsl1) nil (format
"transcribe-output-%s-%s-l1.txt" episodenumber personid))
- ;; (print interventionsl2) ;uncomment to display all the interventions on
screen
- (let((asunitspersecondl2 (/ asunitsl2 (string-to-number duration)))
- (clausesperasunitl2 (/ clausesl2 asunitsl2))
- (errorsperasunitl2 (/ errorsl2 asunitsl2))
- (asunitspersecondl1 (/ asunitsl1 (string-to-number duration)))
- ;; (clausesperasunitl1 (/ clausesl1 asunitsl1))
- (initiatingperasunitl2 (/ initiating asunitsl2))
- (respondingperasunitl2 (/ responding asunitsl2))
- (controlperasunitl2 (/ control asunitsl2))
- (expressiveperasunitl2 (/ expressive asunitsl2))
- (interpersonalperasunitl2 (/ interpersonal asunitsl2))
- (shiftsperasunit (/ shifts (+ asunitsl1 asunitsl2))))
-
- ;; Get rid of divisions by zero
- (when (= asunitsl2 0)
- (setq initiatingperasunitl2 0.0)
- (setq respondingperasunitl2 0.0)
- (setq controlperasunitl2 0.0)
- (setq expressiveperasunitl2 0.0)
- (setq interpersonalperasunitl2 0.0)
- (setq shiftsperasunit 0.0))
-
- ;; (princ clausesmessage)
- (princ (format "episode: %s, duration: %s, person: %s\n" episodenumber
duration personid))
- (with-current-buffer "Statistics Output"
- (insert (format
"%s,%s,%s,0,0,%s,%s,%s,%s,%s,QUAL-L2,%s,%s,%s,%s,%s,%s,aux,level,subject,yearofclil,month\n"
personid episodenumber duration role context demand asunitspersecondl2
asunitspersecondl1 initiatingperasunitl2 respondingperasunitl2
controlperasunitl2 expressiveperasunitl2 interpersonalperasunitl2
shiftsperasunit)))
- (princ (format "L2(Asunits/second): %s, L2(clauses/Asunit): %s,
L2(errors/Asunit):%s, L1(Asunits/second): %s\n"
- asunitspersecondl2 clausesperasunitl2 errorsperasunitl2
asunitspersecondl1))
- (princ (format "Functions/unit: Initiating: %s, Responding: %s, Control:
%s, Expressive: %s, Interpersonal: %s" initiatingperasunitl2
respondingperasunitl2 controlperasunitl2 expressiveperasunitl2
interpersonalperasunitl2)))))
-
-(defun transcribe-analyze-all ()
- "Analyze all file and output to `Statistics Output' buffer. The buffer will
- lost all previous data. The data in the buffer can be saved to a file and be
- passed to R for statistical analysis."
- (interactive)
- (let* ((xml (xml-parse-region (point-min) (point-max)))
- (results (car xml))
- (episodes (xml-get-children results 'episode)))
-
- (with-current-buffer "Statistics Output"
- (erase-buffer)
- (insert
"person,episode,duration,C-UNITS(L2),C-UNITS(L1),role,context,demand,QUAN-L2,QUAN-L1,QUAL-L2,initiating,responding,control,expressive,interpersonal,shifts,aux,level,subjects,yearofCLIL,month\n"))
- (dolist (episode episodes)
- (let* ((numbernode (xml-get-children episode 'number))
- (participantsnode (xml-get-children episode 'participants))
- ;; (transcription (xml-get-children episode 'transcription))
- (number (nth 2 (car numbernode)))
- (participantsstring (nth 2 (car participantsnode)))
- (participants (split-string participantsstring)))
-
- (dolist (participant participants)
- (transcribe-analyze number participant))))))
-
-
-(define-skeleton transcribe-xml-tag-person
- "Insert a speaker xml tag and move point accordingly."
- "Person: "
- "<" str " move=\"" (completing-read "Move: " transcribe-move-list)
- "\">" _ "</" str ">")
-
-(define-skeleton transcribe-xml-tag
- "Encapsulate the marked region in the given tag."
- "Tag: "
- "<" str ">" _ "</" str ">")
-(define-obsolete-function-alias 'transcribe-region-xml-tag
- #'transcribe-xml-tag "1.6")
-
-(define-skeleton transcribe-add-attribute
- "Add an xml attribute at point with the name and value specified."
- (completing-read "Attribute name: " transcribe-attribute-list)
- ;; FIXME: provide more specific value completion depending on the
- ;; chosen attribute.
- str "=\"" '(read-string "Value: ") "\"")
-
-(define-skeleton transcribe-add-attribute-function
- "Add the xml attribute `function' at point with the name specified."
- (completing-read "Function name: " transcribe-function-list)
- "function=\"" str "\"")
-
-(define-skeleton transcribe-add-attribute-move
- "Add the xml attribute `move' at point with the name specified."
- (completing-read "Move name: " transcribe-move-list)
- "move=\"" str "\"")
-
-(define-skeleton transcribe-xml-tag-l1
- "Insert an l1 tag and places the cursor."
- (completing-read "Function: " transcribe-function-list)
- '(re-search-forward "</l.>" (line-end-position) t)
- "<l1 clauses=\"1\" errors=\"0\" function=\"" str "\">" _ "</l1>")
-
-(define-skeleton transcribe-xml-tag-l2
- "Insert a l2 tag and place the cursor."
- (completing-read "function:" transcribe-function-list)
- '(re-search-forward "</l.>" (line-end-position) t)
- "<l2 clauses=\"1\" errors=\"0\" function=\"" str "\">" _ "</l2>")
-
-(define-skeleton transcribe-xml-tag-break
- "Break a unit into two.
-That is, insert a closing and an opening tag."
- "Tag: "
- ;; FIXME: Auto-compute the tag rather than pestering the user!
- ;; Maybe we could simply use `nxml-split-element', for example.
- "</" str "><" str ">")
-
-(defun transcribe-display-audio-info ()
- (interactive)
- (emms-player-mpg321-remote-proc)
- (shell-command "/usr/bin/mpg321 -R - &"))
-
-
-(fset 'NewEpisode
-
"<episode>\n<number>DATE-NUMBER</number>\n<duration></duration>\n<comment></comment>\n<subject>Subject
(level)</subject>\n<participants></participants>\n<task>\n\t<role>low or
high</role>\n<context>low or high</context>\n<demand>low or
high</demand>\r</task>\n<auxiliar>Yes/no</auxiliar>\n<transcription>\n</transcription>\n</episode>");Inserts
a new episode structure
-
-
-(defvar transcribe-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-x C-p") 'emms-play-file)
- (define-key map (kbd "C-x C-a") 'transcribe-analyze)
- (define-key map (kbd "C-x C-n") 'NewEpisode)
- (define-key map (kbd "C-x <down>") 'emms-stop)
- (define-key map (kbd "C-x <right>") 'emms-seek-forward)
- (define-key map (kbd "C-x <left>") 'emms-seek-backward)
- (define-key map (kbd "<f2>") 'transcribe-add-attribute-move)
- (define-key map (kbd "<f3>") 'transcribe-add-attribute-function)
- (define-key map (kbd "<f4>") 'transcribe-add-attribute)
- (define-key map (kbd "<f5>") 'emms-pause)
- (define-key map (kbd "<f8>") 'emms-seek)
- (define-key map (kbd "<f9>") 'transcribe-xml-tag)
- (define-key map (kbd "<f10>") 'transcribe-xml-tag-person)
- (define-key map (kbd "<f11>") 'transcribe-xml-tag-l1)
- (define-key map (kbd "<f12>") 'transcribe-xml-tag-l2)
- map)
- "Keymap for Transcribe minor mode.")
-
-
-(easy-menu-define transcribe-mode-menu transcribe-mode-map
- "Menu for Transcribe mode"
- '("Transcribe"
- ["Raw Output" transcribe-raw-to-buffer]
- "---"
- ["Analyze" transcribe-analyze]
- ["Analyze all" transcribe-analyze-all]
- "---"
- ["Add transcription header" NewEpisode]
- ["Add move attribute" transcribe-add-attribute-move]
- ["Add function attribute" transcribe-add-attribute-function]
- ["Add L1 intervention" transcribe-xml-tag-l1]
- ["Add L2 intervention" transcribe-xml-tag-l2]
- ["Add move" transcribe-xml-tag-person]
- "---"
- ["Play audio file" emms-play-file]
- ))
-
-
-;;;###autoload
-(define-minor-mode transcribe-mode
- "Toggle transcribe-mode"
- nil
- " Trans"
- transcribe-mode-map
- (generate-new-buffer "Statistics Output")
- (generate-new-buffer "Raw Output")
-;; (with-current-buffer "Raw Output"
-;; (linum-mode t)
-;; (setq linum-format "%d "))
- (with-current-buffer "Statistics Output"
- ;; (insert
"person,episode,duration,C-UNITS(L2),C-UNITS(L1),role,context,demand,QUAN-L2,QUAN-L1,QUAL-L2,segmented,aux,level,subjects,yearofCLIL,month\n")
- )
- ;; TODO: save the students present in transcription in list so that we can
use that list for transcribe-analyze-all
-)
-
-(provide 'transcribe)
-
-;;; transcribe.el ends here
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file1.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file1.text
deleted file mode 100644
index fa6dc6c..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-1/bar-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file2.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file2.text
deleted file mode 100644
index a1379dc..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/bar-file2.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-1/bar-file2.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file1.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file1.text
deleted file mode 100644
index 6ca3f4a..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-1/foo-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file2.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file2.text
deleted file mode 100644
index 0c46e78..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-1/foo-file2.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-1/foo-file2.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file1.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file1.text
deleted file mode 100644
index 24ca29e..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-alice-2/bar-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file2.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file2.text
deleted file mode 100644
index e3d8e7b..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/bar-file2.text
+++ /dev/null
@@ -1 +0,0 @@
-alice-2/bar-file2.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file1.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file1.text
deleted file mode 100644
index ac4ffaa..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-alice-2/foo-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.text
deleted file mode 100644
index dbf803b..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.text
+++ /dev/null
@@ -1 +0,0 @@
-alice-2/foo-file3.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.texts
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.texts
deleted file mode 100644
index 124d83e..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-2/foo-file3.texts
+++ /dev/null
@@ -1 +0,0 @@
-This file name is a strict extension of foo-file3.text, to test a corner case
diff --git
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-3/foo-file4.text
b/packages/uniquify-files/uniquify-files-resources/Alice/alice-3/foo-file4.text
deleted file mode 100644
index 5af2740..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Alice/alice-3/foo-file4.text
+++ /dev/null
@@ -1 +0,0 @@
-Alice/alice-3/foo-file4.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Bob/alice-3/foo-file4.text
b/packages/uniquify-files/uniquify-files-resources/Bob/alice-3/foo-file4.text
deleted file mode 100644
index 5893d49..0000000
---
a/packages/uniquify-files/uniquify-files-resources/Bob/alice-3/foo-file4.text
+++ /dev/null
@@ -1 +0,0 @@
-Bob/alice-3/foo-file4.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file1.text
b/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file1.text
deleted file mode 100644
index ba2e142..0000000
--- a/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-1/foo-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file2.text
b/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file2.text
deleted file mode 100644
index 6bd9bdb..0000000
--- a/packages/uniquify-files/uniquify-files-resources/Bob/bob-1/foo-file2.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-1/foo-file2.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file1.text
b/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file1.text
deleted file mode 100644
index 754a1f1..0000000
--- a/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-2/foo-file1.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file5.text
b/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file5.text
deleted file mode 100644
index 2a3b1e9..0000000
--- a/packages/uniquify-files/uniquify-files-resources/Bob/bob-2/foo-file5.text
+++ /dev/null
@@ -1 +0,0 @@
-bob-2/foo-file5.text
diff --git a/packages/uniquify-files/uniquify-files-resources/foo-file1.text
b/packages/uniquify-files/uniquify-files-resources/foo-file1.text
deleted file mode 100644
index 00b4928..0000000
--- a/packages/uniquify-files/uniquify-files-resources/foo-file1.text
+++ /dev/null
@@ -1 +0,0 @@
-foo-file1.text
diff --git a/packages/uniquify-files/uniquify-files-resources/foo-file3.texts2
b/packages/uniquify-files/uniquify-files-resources/foo-file3.texts2
deleted file mode 100644
index ae97731..0000000
--- a/packages/uniquify-files/uniquify-files-resources/foo-file3.texts2
+++ /dev/null
@@ -1 +0,0 @@
-foo-file3.texts2
diff --git
a/packages/uniquify-files/uniquify-files-resources/wisitoken-generate-packrat-test.text
b/packages/uniquify-files/uniquify-files-resources/wisitoken-generate-packrat-test.text
deleted file mode 100644
index 988f655..0000000
---
a/packages/uniquify-files/uniquify-files-resources/wisitoken-generate-packrat-test.text
+++ /dev/null
@@ -1 +0,0 @@
-Wisitoken-generate-packrat-test.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/wisitoken-syntax_trees-test.text
b/packages/uniquify-files/uniquify-files-resources/wisitoken-syntax_trees-test.text
deleted file mode 100644
index 5035ff7..0000000
---
a/packages/uniquify-files/uniquify-files-resources/wisitoken-syntax_trees-test.text
+++ /dev/null
@@ -1 +0,0 @@
-Wisitoken-syntax_trees-test.text
diff --git
a/packages/uniquify-files/uniquify-files-resources/wisitoken-text_io_trace.text
b/packages/uniquify-files/uniquify-files-resources/wisitoken-text_io_trace.text
deleted file mode 100644
index a2d8f82..0000000
---
a/packages/uniquify-files/uniquify-files-resources/wisitoken-text_io_trace.text
+++ /dev/null
@@ -1 +0,0 @@
-Wisitoken-text_io_trace.text
diff --git a/packages/uniquify-files/uniquify-files-test.el
b/packages/uniquify-files/uniquify-files-test.el
deleted file mode 100644
index a75638c..0000000
--- a/packages/uniquify-files/uniquify-files-test.el
+++ /dev/null
@@ -1,487 +0,0 @@
-;;; uniquify-files-test.el - Test functions in uniquify-files.el -*-
lexical-binding:t no-byte-compile:t -*-
-;;
-;; Copyright (C) 2017, 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;;
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;; This is not a complete test of the completion style; the way the
-;; completion functions interact with completing-read is not fully
-;; tested. The following table gives useful test cases for a manual
-;; interactive test (copy it to an org-mode buffer).
-
-;; See `test-uniquify-file-all-completions-face' below for an
-;; explanation of `no-byte-compile'.
-
-(require 'ert)
-(require 'uniquify-files)
-
-(defconst uft-root
- (concat
- (file-name-directory (or load-file-name (buffer-file-name)))
- ;; We deliberately leave out the trailing '/' here, because users
- ;; often do; the code must cope.
- "uniquify-files-resources"))
-
-(defconst uft-alice1 (concat uft-root "/Alice/alice-1"))
-(defconst uft-alice2 (concat uft-root "/Alice/alice-2"))
-(defconst uft-Alice-alice3 (concat uft-root "/Alice/alice-3"))
-(defconst uft-Bob-alice3 (concat uft-root "/Bob/alice-3"))
-(defconst uft-bob1 (concat uft-root "/Bob/bob-1"))
-(defconst uft-bob2 (concat uft-root "/Bob/bob-2"))
-
-(defconst uft-path
- (list uft-root
- (concat uft-root "/Alice")
- uft-alice1
- uft-alice2
- uft-Alice-alice3
- (concat uft-root "/Bob")
- uft-Bob-alice3
- uft-bob1
- uft-bob2))
-
-(defun uft-table ()
- (let (files)
- (dolist (dir uft-path)
- (mapc
- (lambda (absfile)
- (when (and (not (string-equal "." (substring absfile -1)))
- (not (string-equal ".." (substring absfile -2)))
- (not (file-directory-p absfile)))
- (push absfile files)))
- (directory-files dir t)))
- (apply-partially 'uniq-file-completion-table (uniq-file-uniquify files))))
-
-(ert-deftest test-uniq-file-test-completion ()
- (let ((table (uft-table)))
- (should (equal (test-completion "foo-fi" table)
- nil))
-
- (should (equal (test-completion "f-fi<dir" table)
- nil))
-
- (should (equal (test-completion "foo-file1.text<>" table)
- t))
-
- (should (equal (test-completion "foo-file1.text" table)
- nil))
-
- (should (equal (test-completion "foo-file1.text<Alice/alice-1/>" table)
- t))
-
- (should (equal (test-completion "foo-file3.tex" table) ;; partial file name
- nil))
-
- (should (equal (test-completion "foo-file3.texts2" table)
- t))
-
- (should (equal (test-completion "bar-file2.text<Alice/alice-" table)
- nil))
- ))
-
-(ert-deftest test-uniq-file-all-completions-noface ()
- (let ((table (uft-table))
- (completion-ignore-case nil))
- (should (equal
- (sort (uniq-file-all-completions "" table nil nil) #'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- "foo-file1.text<>"
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>"
- "foo-file1.text<Bob/bob-1/>"
- "foo-file1.text<Bob/bob-2/>"
- "foo-file2.text<Alice/alice-1/>"
- "foo-file2.text<Bob/bob-1/>"
- "foo-file3.text"
- "foo-file3.texts"
- "foo-file3.texts2"
- "foo-file4.text<Alice/alice-3/>"
- "foo-file4.text<Bob/alice-3/>"
- "foo-file5.text"
- "wisitoken-generate-packrat-test.text"
- "wisitoken-syntax_trees-test.text"
- "wisitoken-text_io_trace.text"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "*-fi" table nil nil)
#'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- "foo-file1.text<>"
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>"
- "foo-file1.text<Bob/bob-1/>"
- "foo-file1.text<Bob/bob-2/>"
- "foo-file2.text<Alice/alice-1/>"
- "foo-file2.text<Bob/bob-1/>"
- "foo-file3.text"
- "foo-file3.texts"
- "foo-file3.texts2"
- "foo-file4.text<Alice/alice-3/>"
- "foo-file4.text<Bob/alice-3/>"
- "foo-file5.text"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "a" table nil nil) #'string-lessp)
- ;; Should _not_ match directory names
- nil))
-
- (should (equal
- (sort (uniq-file-all-completions "b" table nil nil) #'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "foo" table nil nil)
#'string-lessp)
- (list
- "foo-file1.text<>"
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>"
- "foo-file1.text<Bob/bob-1/>"
- "foo-file1.text<Bob/bob-2/>"
- "foo-file2.text<Alice/alice-1/>"
- "foo-file2.text<Bob/bob-1/>"
- "foo-file3.text"
- "foo-file3.texts"
- "foo-file3.texts2"
- "foo-file4.text<Alice/alice-3/>"
- "foo-file4.text<Bob/alice-3/>"
- "foo-file5.text"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "f-file2" table nil nil)
#'string-lessp)
- (list
- "foo-file2.text<Alice/alice-1/>"
- "foo-file2.text<Bob/bob-1/>"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "b-fi<" table nil nil)
#'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "f-file<" table nil nil)
#'string-lessp)
- (list
- "foo-file1.text<>"
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>"
- "foo-file1.text<Bob/bob-1/>"
- "foo-file1.text<Bob/bob-2/>"
- "foo-file2.text<Alice/alice-1/>"
- "foo-file2.text<Bob/bob-1/>"
- "foo-file3.text"
- "foo-file3.texts"
- "foo-file3.texts2"
- "foo-file4.text<Alice/alice-3/>"
- "foo-file4.text<Bob/alice-3/>"
- "foo-file5.text"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "b-fi<a-" table nil nil)
#'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "b-fi<a-1" table nil nil)
#'string-lessp)
- (list "bar-file1.text<alice-1/>"
- "bar-file2.text<alice-1/>")))
-
- (should (equal (uniq-file-all-completions "f-file1.text<a-1" table nil nil)
- (list "foo-file1.text<Alice/alice-1/>")))
-
- (should (equal (sort (uniq-file-all-completions "f-file1.text<al" table
nil nil) #'string-lessp)
- (list
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>")))
-
- (should (equal (sort (uniq-file-all-completions "f-file4.text<a-3" table
nil nil) #'string-lessp)
- (list
- "foo-file4.text<Alice/alice-3/>"
- "foo-file4.text<Bob/alice-3/>")))
-
- (should (equal (sort (uniq-file-all-completions "foo-file4.text<Bob" table
nil nil) #'string-lessp)
- (list
- "foo-file4.text<Bob/alice-3/>")))
-
- (should (equal (uniq-file-all-completions "f-file5" table nil nil)
- (list "foo-file5.text")))
-
- (should (equal (uniq-file-all-completions "foo-file1.text<Alice/alice-1/>"
table nil nil)
- (list "foo-file1.text<Alice/alice-1/>")))
-
- (should (equal
- (sort (uniq-file-all-completions "b-fi<a>" table nil nil)
#'string-lessp)
- (list
- "bar-file1.text<alice-1/>"
- "bar-file1.text<alice-2/>"
- "bar-file2.text<alice-1/>"
- "bar-file2.text<alice-2/>"
- )))
-
- (should (equal
- (sort (uniq-file-all-completions "foo-file1.text<>" table nil nil)
#'string-lessp)
- ;; This is complete but not unique, because the directory part
matches multiple directories.
- (list
- "foo-file1.text<>"
- "foo-file1.text<Alice/alice-1/>"
- "foo-file1.text<Alice/alice-2/>"
- "foo-file1.text<Bob/bob-1/>"
- "foo-file1.text<Bob/bob-2/>"
- )))
- ))
-
-(defun test-uniq-file-hilit (pos-list string)
- "Set 'face text property to 'completions-first-difference at
-all positions in POS-LIST in STRING; return new string."
- (while pos-list
- (let ((pos (pop pos-list)))
- (put-text-property pos (1+ pos) 'face 'completions-first-difference
string)))
- string)
-
-(ert-deftest test-uniq-file-all-completions-face ()
- ;; `all-completions' tested above without considering face text
- ;; properties; here we test just those properties. Test cases are
- ;; the same as above.
- ;;
- ;; WORKAROUND: byte-compiling this test makes it fail; it appears to be
- ;; sharing strings that should not be shared because they have
- ;; different text properties.
- (let ((table (uft-table))
- (completion-ignore-case nil))
-
- (should (equal-including-properties
- (sort (uniq-file-all-completions "b" table nil nil) #'string-lessp)
- (list
- (test-uniq-file-hilit '(8) "bar-file1.text<alice-1/>")
- (test-uniq-file-hilit '(8) "bar-file1.text<alice-2/>")
- (test-uniq-file-hilit '(8) "bar-file2.text<alice-1/>")
- (test-uniq-file-hilit '(8) "bar-file2.text<alice-2/>")
- )))
-
- (should (equal-including-properties
- (sort (uniq-file-all-completions "foo" table nil nil)
#'string-lessp)
- (list
- (test-uniq-file-hilit '(8) "foo-file1.text<>")
- (test-uniq-file-hilit '(8) "foo-file1.text<Alice/alice-1/>")
- (test-uniq-file-hilit '(8) "foo-file1.text<Alice/alice-2/>")
- (test-uniq-file-hilit '(8) "foo-file1.text<Bob/bob-1/>")
- (test-uniq-file-hilit '(8) "foo-file1.text<Bob/bob-2/>")
- (test-uniq-file-hilit '(8) "foo-file2.text<Alice/alice-1/>")
- (test-uniq-file-hilit '(8) "foo-file2.text<Bob/bob-1/>")
- (test-uniq-file-hilit '(8) "foo-file3.text")
- (test-uniq-file-hilit '(8) "foo-file3.texts")
- (test-uniq-file-hilit '(8) "foo-file3.texts2")
- (test-uniq-file-hilit '(8) "foo-file4.text<Alice/alice-3/>")
- (test-uniq-file-hilit '(8) "foo-file4.text<Bob/alice-3/>")
- (test-uniq-file-hilit '(8) "foo-file5.text")
- )))
-
- (should (equal-including-properties
- (sort (uniq-file-all-completions "f-file2" table nil nil)
#'string-lessp)
- (list
- (test-uniq-file-hilit '(15) "foo-file2.text<Alice/alice-1/>")
- (test-uniq-file-hilit '(15) "foo-file2.text<Bob/bob-1/>")
- )))
-
- (should (equal-including-properties
- (sort (uniq-file-all-completions "foo-file3.text" table nil nil)
#'string-lessp)
- (list
- (test-uniq-file-hilit '() "foo-file3.text")
- (test-uniq-file-hilit '(14) "foo-file3.texts")
- (test-uniq-file-hilit '(14) "foo-file3.texts2")
- )))
-
- ;; Two places for possible completion, with different intervening text
- (should (equal-including-properties
- (sort (uniq-file-all-completions "wisi-te" table nil 5)
#'string-lessp)
- (list ;; 0 10 20 30
- (test-uniq-file-hilit '(10 18)
"wisitoken-generate-packrat-test.text")
- (test-uniq-file-hilit '(10 25) "wisitoken-syntax_trees-test.text")
- (test-uniq-file-hilit '(10 12) "wisitoken-text_io_trace.text")
- )))
- ))
-
-(ert-deftest test-uniq-file-try-completion ()
- (let ((table (uft-table))
- (completion-ignore-case nil)
- string)
-
- (setq string "fo")
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("foo-file" . 8)))
-
- (setq string "b")
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("bar-file" . 8)))
-
- (setq string "fo<al")
- (should (equal (uniq-file-try-completion string table nil 2)
- '("foo-file.text<alice-" . 8)))
- (should (equal (uniq-file-try-completion string table nil 5)
- '("foo-file<alice-" . 15)))
-
- (let ((completion-ignore-case t))
- (setq string "fo<al")
- (should (equal (uniq-file-try-completion string table nil 2)
- '("foo-file.text<alice" . 8)))
- (should (equal (uniq-file-try-completion string table nil 5)
- '("foo-file<alice" . 14)))
- )
-
- (setq string "foo-file3") ;; not unique, not valid
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("foo-file3.text" . 14)))
-
- (setq string "f-file1.text<a-1")
- ;; Not unique, because "a" accidentally matches "packages" in
- ;; uft-root-dir, and "-" covers "/". Also not valid.
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("foo-file1.text<Alice/alice-1/>" . 30)))
-
- (setq string "foo-file1.text") ;; valid but not unique
- (should (equal (uniq-file-try-completion string table nil (length string))
- (cons "foo-file1.text<" 15)))
-
- (setq string "foo-file1<") ;; not valid
- (should (equal (uniq-file-try-completion string table nil (length string))
- (cons "foo-file1.text<" 15)))
-
- (setq string "foo-file1.text<>") ;; valid but not unique
- (should (equal (uniq-file-try-completion string table nil (length string))
- (cons "foo-file1.text<>" 15)))
-
- (setq string "foo-file1.text<Alice/alice-1/>") ;; valid and unique
- (should (equal (uniq-file-try-completion string table nil (length string))
- t))
-
- (setq string "foo-file3.texts") ;; not unique, valid
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("foo-file3.texts" . 15)))
-
- (setq string "foo-file3.texts2") ;; unique and valid
- (should (equal (uniq-file-try-completion string table nil (length string))
- t))
-
- (setq string "fil2") ;; misspelled
- (should (equal (uniq-file-try-completion string table nil (length string))
- nil))
-
- (setq string "b-file2")
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("bar-file2.text<alice-" . 21)))
-
- ;; prev + <tab>; input is prev output
- (setq string "bar-file2.text<alice-")
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("bar-file2.text<alice-" . 21)))
-
- ;; prev + <tab>; input is prev output
- (setq string "bar-file2.text<alice-")
- (should (equal (uniq-file-try-completion string table nil (length string))
- '("bar-file2.text<alice-" . 21)))
-
- ;; completion-try-completion called from icomplete-completions with
- ;; result of all-completions instead of table function.
- (setq string "f-file<")
- (let ((comps (uniq-file-all-completions string table nil nil)))
- (should (equal (uniq-file-try-completion string comps nil (length
string))
- (cons "foo-file" 8))))
- ))
-
-(ert-deftest test-uniq-file-uniquify ()
- (should (equal (uniq-file-uniquify
- '("/Alice/alice1/file1.text"
- "/Alice/alice1/file2.text"
- "/Alice/alice2/file1.text"
- "/Alice/alice2/file3.text"
- "/Bob/bob1/file1.text"))
- (list
- '("file3.text" . "/Alice/alice2/file3.text")
- '("file2.text" . "/Alice/alice1/file2.text")
- '("file1.text<Bob/bob1/>" . "/Bob/bob1/file1.text")
- '("file1.text<Alice/alice2/>" . "/Alice/alice2/file1.text")
- '("file1.text<Alice/alice1/>" . "/Alice/alice1/file1.text")
- )))
-
- (should (equal (uniq-file-uniquify
- (list
- (concat uft-alice1 "/foo-file1.text")
- (concat uft-alice2 "/foo-file1.text")
- (concat uft-bob1 "/foo-file1.text")
- (concat uft-bob2 "/foo-file1.text")
- (concat uft-root "/foo-file1.text")
- ))
- (list
- (cons "foo-file1.text<>" (concat uft-root
"/foo-file1.text"))
- (cons "foo-file1.text<Bob/bob-2/>" (concat uft-bob2
"/foo-file1.text"))
- (cons "foo-file1.text<Bob/bob-1/>" (concat uft-bob1
"/foo-file1.text"))
- (cons "foo-file1.text<Alice/alice-2/>" (concat uft-alice2
"/foo-file1.text"))
- (cons "foo-file1.text<Alice/alice-1/>" (concat uft-alice1
"/foo-file1.text"))
- )))
-
- (should (equal (uniq-file-uniquify
- (list
- (concat uft-alice1 "/bar-file1.c")
- (concat uft-alice1 "/bar-file2.c")
- (concat uft-alice2 "/bar-file1.c")
- (concat uft-alice2 "/bar-file2.c")
- (concat uft-bob1 "/foo-file1.c")
- (concat uft-bob1 "/foo-file2.c")
- (concat uft-bob2 "/foo-file1.c")
- (concat uft-bob2 "/foo-file5.c")
- ))
- (list
- (cons "foo-file5.c" (concat uft-bob2
"/foo-file5.c"))
- (cons "foo-file2.c" (concat uft-bob1
"/foo-file2.c"))
- (cons "foo-file1.c<bob-2/>" (concat uft-bob2
"/foo-file1.c"))
- (cons "foo-file1.c<bob-1/>" (concat uft-bob1
"/foo-file1.c"))
- (cons "bar-file2.c<alice-2/>" (concat uft-alice2
"/bar-file2.c"))
- (cons "bar-file2.c<alice-1/>" (concat uft-alice1
"/bar-file2.c"))
- (cons "bar-file1.c<alice-2/>" (concat uft-alice2
"/bar-file1.c"))
- (cons "bar-file1.c<alice-1/>" (concat uft-alice1
"/bar-file1.c"))
- )))
- )
-
-(provide 'uniquify-files-test)
-;;; uniquify-files-test.el ends here
diff --git a/packages/uniquify-files/uniquify-files.el
b/packages/uniquify-files/uniquify-files.el
deleted file mode 100644
index d943053..0000000
--- a/packages/uniquify-files/uniquify-files.el
+++ /dev/null
@@ -1,324 +0,0 @@
-;;; uniquify-files.el --- Completion style for files, minimizing directories
-*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2019, 2020 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Keywords: completion table
-;; uniquify
-;; Version: 1.0.3
-;; package-requires: ((emacs "25.0"))
-;;
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary
-
-;; A file completion style in which the completion string displayed to
-;; the user consists of the file basename followed by enough of the
-;; directory part to make the string identify a unique file.
-;;
-;; We accomplish this by preprocessing the list of absolute file names
-;; to be in that style, in an alist with the original absolute file
-;; names, and do completion on that alist.
-
-(require 'cl-lib)
-(require 'files)
-(require 'project)
-
-(defconst uniq-file--regexp "^\\(.*\\)<\\([^>]*\\)>?$"
- ;; The trailing '>' is optional so the user can type "<dir" in the
- ;; input buffer to complete directories.
- "Regexp matching uniqufied file name.
-Match 1 is the filename, match 2 is the relative directory.")
-
-(defun uniq-file-conflicts (conflicts)
- "Subroutine of `uniq-file-uniquify'."
- (let ((common-root ;; shared prefix of dirs in conflicts - may be nil
- (fill-common-string-prefix (file-name-directory (nth 0 conflicts))
(file-name-directory (nth 1 conflicts)))))
-
- (let ((temp (cddr conflicts)))
- (while (and common-root
- temp)
- (setq common-root (fill-common-string-prefix common-root
(file-name-directory (pop temp))))))
-
- (when common-root
- ;; Trim `common-root' back to last '/'
- (let ((i (1- (length common-root))))
- (while (and (> i 0)
- (not (= (aref common-root i) ?/)))
- (setq i (1- i)))
- (setq common-root (substring common-root 0 (1+ i)))))
-
- (cl-mapcar
- (lambda (name)
- (cons (concat (file-name-nondirectory name)
- "<"
- (substring (file-name-directory name) (length
common-root))
- ">")
- name))
- conflicts)
- ))
-
-(defun uniq-file-uniquify (names)
- "Return an alist of uniquified names built from NAMES.
-NAMES is a list containing absolute file names.
-
-The result contains file basenames with partial directory paths
-appended."
- (let ((case-fold-search completion-ignore-case)
- result
- conflicts ;; list of names where all non-directory names are the same.
- )
-
- ;; Sort names on basename so duplicates are grouped together
- (setq names (sort names (lambda (a b)
- (string< (file-name-nondirectory a)
(file-name-nondirectory b)))))
-
- (while names
- (setq conflicts (list (pop names)))
- (while (and names
- (string= (file-name-nondirectory (car conflicts))
(file-name-nondirectory (car names))))
- (push (pop names) conflicts))
-
- (if (= 1 (length conflicts))
- (push (cons
- (concat (file-name-nondirectory (car conflicts)))
- (car conflicts))
- result)
-
- (setq result (append (uniq-file-conflicts conflicts) result)))
- )
- result))
-
-(defun uniq-file--pcm-pat (string point)
- "Return a pcm pattern that matches STRING (a uniquified file name)."
- (let* ((completion-pcm--delim-wild-regex
- (concat "[" completion-pcm-word-delimiters "<>*]"))
- ;; If STRING ends in an empty directory part, some valid
- ;; completions won't have any directory part.
- (trimmed-string
- (if (and (< 0 (length string))
- (= (aref string (1- (length string))) ?<))
- (substring string 0 -1)
- string))
- dir-start
- (pattern (completion-pcm--string->pattern trimmed-string point)))
-
- ;; If trimmed-string has a directory part, allow uniquifying
- ;; directories.
- (when (and (setq dir-start (string-match "<" trimmed-string))
- (< dir-start (1- (length trimmed-string))))
- (let (new-pattern
- item)
- (while pattern
- (setq item (pop pattern))
- (push item new-pattern)
- (when (equal item "<")
- (setq item (pop pattern))
- (if (eq item 'any-delim)
- (push 'any new-pattern)
- (push item new-pattern))))
- (setq pattern (nreverse new-pattern))))
- pattern))
-
-(defun uniq-file--pcm-merged-pat (string all point)
- "Return a pcm pattern that is the merged completion of STRING in ALL.
-ALL must be a list of uniquified file names.
-Pattern is in reverse order."
- (let* ((pattern (uniq-file--pcm-pat string point)))
- (completion-pcm--merge-completions all pattern)))
-
-(defun uniq-file-try-completion (user-string table pred point)
- "Implement `completion-try-completion' for uniquify-file."
- (let (result
- uniq-all
- done)
-
- ;; Compute result or uniq-all, set done.
- (cond
- ((functionp table) ;; TABLE is a wrapper function that calls
uniq-file-completion-table.
-
- (setq uniq-all (uniq-file-all-completions user-string table pred point))
-
- (cond
- ((null uniq-all) ;; No matches.
- (setq result nil)
- (setq done t))
-
- ((= 1 (length uniq-all)) ;; One match; unique.
- (setq done t)
-
- ;; Check for valid completion
- (if (string-equal user-string (car uniq-all))
- (setq result t)
-
- (setq result (car uniq-all))
- (setq result (cons result (length result)))))
-
- (t ;; Multiple matches
- (setq done nil))
- ))
-
- ;; The following cases handle being called from
- ;; icomplete-completions with the result of `all-completions'
- ;; instead of the real table function. TABLE is a list of
- ;; uniquified file names.
-
- ((null table) ;; No matches.
- (setq result nil)
- (setq done t))
-
- (t ;; TABLE is a list of uniquified file names
- (setq uniq-all table)
- (setq done nil))
- )
-
- (if done
- result
-
- ;; Find merged completion of uniqified file names
- (let* ((merged-pat (uniq-file--pcm-merged-pat user-string uniq-all
point))
-
- ;; `merged-pat' is in reverse order. Place new point at:
- (point-pat (or (memq 'point merged-pat) ;; the old point
- (memq 'any merged-pat) ;; a place where there's
something to choose
- (memq 'star merged-pat) ;; ""
- merged-pat)) ;; the end
-
- ;; `merged-pat' does not contain 'point when the field
- ;; containing 'point is fully completed.
-
- (new-point (length (completion-pcm--pattern->string point-pat)))
-
- ;; Compute this after `new-point' because `nreverse'
- ;; changes `point-pat' by side effect.
- (merged (completion-pcm--pattern->string (nreverse merged-pat))))
-
- (cons merged new-point)))
- ))
-
-(defun uniq-file--hilit (string all point)
- "Apply face text properties to each element of ALL.
-STRING is the current user input.
-ALL is a list of strings in user format.
-POINT is the position of point in STRING.
-Returns new list.
-
-Adds the face `completions-first-difference' to the first
-character after each completion field."
- (let* ((merged-pat (nreverse (uniq-file--pcm-merged-pat string all point)))
- (field-count 0)
- (regex (completion-pcm--pattern->regex merged-pat '(any star any-delim
point)))
- )
- (dolist (x merged-pat)
- (when (not (stringp x))
- (setq field-count (1+ field-count))))
-
- (mapcar
- (lambda (str)
- ;; First remove previously applied face; `str' may be a reference
- ;; to a list used in a previous completion.
- (remove-text-properties 0 (length str) '(face
completions-first-difference) str)
- (when (string-match regex str)
- (cl-loop
- for i from 1 to field-count
- do
- (when (and
- (match-beginning i)
- (<= (1+ (match-beginning i)) (length str)))
- (put-text-property (match-beginning i) (1+ (match-beginning i))
'face 'completions-first-difference str))
- ))
- str)
- all)))
-
-(defun uniq-file-all-completions (string table pred point)
- "Implement `completion-all-completions' for uniquify-file."
- ;; Returns list of data format strings (abs file names).
- (let ((all (all-completions string table pred)))
- (when all
- (uniq-file--hilit string all point))
- ))
-
-(defun uniq-file-completion-table (files string pred action)
- "Implement a completion table for uniquified file names in FILES.
-FILES is an alist of (UNIQIFIED-NAME . ABS-NAME). Completion is
-done on UNIQIFIED-NAME, PRED is called with ABS-NAME."
- (cond
- ((eq action 'alist)
- (cdr (assoc string files)))
-
- ((eq (car-safe action) 'boundaries)
- ;; We don't use boundaries; return the default definition.
- (cons 'boundaries
- (cons 0 (length (cdr action)))))
-
- ((eq action 'metadata)
- (cons 'metadata
- (list
- ;; category controls what completion styles are appropriate.
- '(category . uniquify-file)
- )))
-
- ((memq action
- '(nil ;; Called from `try-completion'
- lambda ;; Called from `test-completion'
- t)) ;; Called from all-completions
-
- (let ((regex (completion-pcm--pattern->regex
- (uniq-file--pcm-pat string (length string))))
- (case-fold-search completion-ignore-case)
- (result nil))
- (dolist (pair files)
- (when (and
- (string-match regex (car pair))
- (or (null pred)
- (funcall pred (cdr pair))))
- (push (car pair) result)))
-
- (cond
- ((null action)
- (try-completion string result))
-
- ((eq 'lambda action)
- (test-completion string files pred))
-
- ((eq t action)
- result)
- )))
- ))
-
-(add-to-list 'completion-styles-alist
- '(uniquify-file
- uniq-file-try-completion
- uniq-file-all-completions
- "display uniquified file names."))
-
-;;; Integration with emacs 27 project.el
-
-;;;###autoload
-(defun uniq-file-read (prompt all-files &optional predicate hist default)
- "For `project-read-file-name-function'."
- (let* ((alist (uniq-file-uniquify all-files))
- (table (apply-partially #'uniq-file-completion-table alist))
- (found (project--completing-read-strict
- prompt table predicate hist default)))
- (cdr (assoc found alist))))
-
-;;;###autoload
-(setq-default project-read-file-name-function #'uniq-file-read)
-
-(provide 'uniquify-files)
-;;; uniquify-files.el ends here
diff --git a/packages/validate/validate.el b/packages/validate/validate.el
deleted file mode 100644
index a51cd81..0000000
--- a/packages/validate/validate.el
+++ /dev/null
@@ -1,211 +0,0 @@
-;;; validate.el --- Schema validation for Emacs-lisp -*- lexical-binding: t;
-*-
-
-;; Copyright (C) 2016 Free Software Foundation, Inc.
-
-;; Author: Artur Malabarba <emacs@endlessparentheses.com>
-;; Keywords: lisp
-;; Package-Requires: ((emacs "24.1") (cl-lib "0.5") (seq "2.16"))
-;; Version: 1.0.4
-
-;;; Commentary:
-;;
-;; This library offers two functions that perform schema validation.
-;; Use this is your Elisp packages to provide very informative error
-;; messages when your users accidentally misconfigure a variable.
-;; For instance, if everything is fine, these do the same thing:
-;;
-;; 1. (validate-variable 'cider-known-endpoints)
-;; 2. cider-known-endpoints
-;;
-;; However, if the user has misconfigured this variable, option
-;; 1. will immediately give them an informative error message, while
-;; option 2. won't say anything and will lead to confusing errors down
-;; the line.
-;;
-;; The format and language of the schemas is the same one used in the
-;; `:type' property of a `defcustom'.
-;;
-;; See: (info "(elisp) Customization Types")
-;;
-;; Both functions throw a `user-error' if the value in question
-;; doesn't match the schema, and return the value itself if it
-;; matches. The function `validate-variable' verifies whether the value of a
-;; custom variable matches its custom-type, while `validate-value' checks an
-;; arbitrary value against an arbitrary schema.
-;;
-;; Missing features: `:inline', `plist', `coding-system', `color',
-;; `hook', `restricted-sexp'.
-
-;;; License:
-;;
-;; This file is 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 <http://www.gnu.org/licenses/>.
-
-;;; Code:
-(require 'cl-lib)
-(require 'seq)
-(require 'cus-edit)
-
-(defun validate--check-list-contents (values schemas)
- "Check that all VALUES match all SCHEMAS."
- (when schemas
- (if (not (= (length values) (length schemas)))
- "wrong number of elements"
- (seq-find #'identity (seq-mapn #'validate--check values schemas)))))
-
-(defun validate--indent-by-2 (x)
- (replace-regexp-in-string "^" " " x))
-
-(defun validate--check (value schema)
- "Return nil if VALUE matches SCHEMA.
-If they don't match, return an explanation."
- (let ((args (cdr-safe schema))
- (expected-type (or (car-safe schema) schema))
- (props nil))
- (while (and (keywordp (car args)) (cdr args))
- (setq props `(,(pop args) ,(pop args) ,@props)))
- (setq args (or (plist-get props :args)
- args))
- (let ((r
- (cl-labels ((wtype ;wrong-type
- (tt) (unless (funcall (intern (format "%sp" tt)) value)
- (format "not a %s" tt))))
- ;; TODO: hook (top-level only).
- (cl-case expected-type
- ((sexp other) nil)
- (variable (cond ((wtype 'symbol))
- ((not (boundp value)) "this symbol has no
variable binding")))
- ((integer number float string character symbol function boolean
face)
- (wtype expected-type))
- (regexp (cond ((ignore-errors (string-match value "") t) nil)
- ((wtype 'string))
- (t "not a valid regexp")))
- (repeat (cond
- ((or (not args) (cdr args)) (error "`repeat' needs
exactly one argument"))
- ((wtype 'list))
- (t (let ((subschema (car args)))
- (seq-some (lambda (v) (validate--check v
subschema)) value)))))
- ((const function-item variable-item) (unless (equal value (car
args))
- "not the expected
value"))
- (file (cond ((wtype 'string))
- ((file-exists-p value) nil)
- ((plist-get props :must-match) "file does not
exist")
- ((not (file-writable-p value)) "file is not
accessible")))
- (directory (cond ((wtype 'string))
- ((file-directory-p value) nil)
- ((file-exists-p value) "path is not a
directory")
- ((not (file-writable-p value)) "directory is
not accessible")))
- (key-sequence (and (wtype 'string)
- (wtype 'vector)))
- ;; TODO: `coding-system', `color'
- (coding-system (wtype 'symbol))
- (color (wtype 'string))
- (cons (or (wtype 'cons)
- (validate--check (car value) (car args))
- (validate--check (cdr value) (cadr args))))
- ((list group) (or (wtype 'list)
- (validate--check-list-contents value args)))
- (vector (or (wtype 'vector)
- (validate--check-list-contents value args)))
- (alist (let ((value-type (plist-get props :value-type))
- (key-type (plist-get props :key-type)))
- (cond ((not value-type) (error "`alist' needs a
:value-type"))
- ((not key-type) (error "`alist' needs a
:key-type"))
- ((wtype 'list))
- (t (validate--check value
- `(repeat (cons ,key-type
,value-type)))))))
- ;; TODO: `plist'
- ((choice radio) (if (not (cdr args))
- (error "`choice' needs at least one
argument")
- (let ((gather (mapcar (lambda (x)
(validate--check value x)) args)))
- (when (seq-every-p #'identity gather)
- (concat "all of the options failed\n"
- (mapconcat
#'validate--indent-by-2 gather "\n"))))))
- ;; TODO: `restricted-sexp'
- (set (or (wtype 'list)
- (let ((failed (list t)))
- (dolist (schema args)
- (let ((elem (seq-find (lambda (x) (not
(validate--check x schema)))
- value
- failed)))
- (unless (eq elem failed)
- (setq value (remove elem value)))))
- (when value
- (concat "the following values don't match any of
the options:\n "
- (mapconcat (lambda (x) (format "%s" x))
value "\n "))))))))))
- (when r
- (let ((print-length 4)
- (print-level 2))
- (format "Looking for `%S' in `%S' failed because:\n%s"
- schema value
- (if (string-match "\\`Looking" r)
- r
- (validate--indent-by-2 r))))))))
-
-
-;;; Exposed API
-;;;###autoload
-(defun validate-value (value schema &optional noerror)
- "Check that VALUE matches SCHEMA.
-If it matches return VALUE, otherwise signal a `user-error'.
-
-If NOERROR is non-nil, return t to indicate a match and nil to
-indicate a failure."
- (let ((report (validate--check value schema)))
- (if report
- (unless noerror
- (user-error "%s" report))
- value)))
-
-;;;###autoload
-(defun validate-variable (symbol &optional noerror)
- "Check that SYMBOL's value matches its schema.
-SYMBOL must be the name of a custom option with a defined
-`custom-type'. If SYMBOL has a value and a type, they are checked
-with `validate-value'. NOERROR is passed to `validate-value'."
- (let* ((val (symbol-value symbol))
- (type (custom-variable-type symbol)))
- (if type
- (validate-value val type)
- (if noerror val
- (error "Variable `%s' has no custom-type." symbol)))))
-
-;;;###autoload
-(defun validate-mark-safe-local (symbol)
- "Mark SYMBOL as a safe local if its custom type is obeyed."
- (put symbol 'safe-local-variable
- (lambda (val)
- (validate-value val (custom-variable-type symbol) 'noerror))))
-
-(defmacro validate-setq (&rest svs)
- "Like `setq', but throw an error if validation fails.
-VALUE is validated against SYMBOL's custom type.
-
-\(fn [SYM VAL] ...)"
- (let ((out))
- (while svs
- (let ((symbol (pop svs))
- (value (if (not svs)
- (error "`validate-setq' takes an even number of
arguments")
- (pop svs))))
- (push `(if (boundp ',symbol)
- (setq ,symbol (validate-value ,value (custom-variable-type
',symbol)))
- (user-error "Trying to validate a variable that's not defined
yet: `%s'.\nYou need to require the package before validating"
- ',symbol))
- out)))
- `(progn ,@(reverse out))))
-
-(provide 'validate)
-;;; validate.el ends here
diff --git a/packages/visual-fill/visual-fill.el
b/packages/visual-fill/visual-fill.el
deleted file mode 100644
index b98ba8b..0000000
--- a/packages/visual-fill/visual-fill.el
+++ /dev/null
@@ -1,77 +0,0 @@
-;;; visual-fill.el --- Auto-refill paragraphs without modifying the buffer
-*- lexical-binding: t; -*-
-
-;; Copyright (C) 2018 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Version: 0.1
-;; Keywords:
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This `visual-fill-mode' minor mode basically "unfills" paragraphs within
-;; jit-lock, hence without modifying the buffer. Combined with the normal
-;; line-wrapping this performs a kind of "auto refill" which can be more or
-;; less sophisticated depending on the line-wrapping used.
-;;
-;; For best effect, combine it with `visual-line-mode' and
-;; `adaptive-wrap-prefix-mode'.
-
-;;; Code:
-
-(defconst visual-fill--space " ")
-
-(defun visual-fill--cleanup (start end)
- (while (and (< start end)
- (setq start (text-property-any start end
- 'display visual-fill--space)))
- (remove-text-properties
- start
- (setq start (or (text-property-not-all start end
- 'display visual-fill--space)
- end))
- '(display nil))))
-
-(defun visual-fill--jit (start end)
- (visual-fill--cleanup start end)
- (goto-char start)
- (forward-line 0)
- (let ((after-sep (looking-at paragraph-separate)))
- (while (< (point) end)
- (forward-line 1)
- (if after-sep
- (setq after-sep (looking-at paragraph-separate))
- (unless (or (setq after-sep (looking-at paragraph-separate))
- (looking-at paragraph-start))
- (put-text-property (1- (point))
- (if (looking-at (if adaptive-fill-mode
- adaptive-fill-regexp "[
\t]+"))
- (match-end 0)
- (point))
- 'display visual-fill--space))))))
-
-;;;###autoload
-(define-minor-mode visual-fill-mode
- "Auto-refill paragraphs without modifying the buffer."
- :lighter " VFill"
- :global nil
- (jit-lock-unregister #'visual-fill--jit)
- (with-silent-modifications
- (visual-fill--cleanup (point-min) (point-max)))
- (when visual-fill-mode
- (jit-lock-register #'visual-fill--jit)))
-
-(provide 'visual-fill)
-;;; visual-fill.el ends here