commit 344e9deaa50fc22a981f7940aa79c9f17e635ce1 parent c1df39e858dba1cc7523696ef0465ba57ce87dff Author: dwrz <dwrz@dwrz.net> Date: Sun, 17 Nov 2024 14:21:34 +0000 Update Emacs packages Diffstat:
273 files changed, 40704 insertions(+), 40485 deletions(-)
diff --git a/emacs/elpa/archives/gnu/archive-contents b/emacs/elpa/archives/gnu/archive-contents @@ -631,16 +631,20 @@ ("Elias G. Perez" . "eg642616@gmail.com")) (:commit . "945c9905af2045ab2e57717c01e5b20a907f939a"))]) (comint-mime . - [(0 6) + [(0 7) ((emacs - (28 1))) + (28 1)) + (compat + (29 1)) + (mathjax + (0 1))) "Display content of various MIME types in comint buffers" tar ((:url . "https://github.com/astoff/comint-mime") (:keywords "processes" "multimedia") (:maintainer "Augusto Stoffel" . "arstoffel@gmail.com") (:authors ("Augusto Stoffel" . "arstoffel@gmail.com")) - (:commit . "b8a5347f80ffc55421997493b646eb922450c720"))]) + (:commit . "5e7b609a4f8c4ba8ec6d1d994c01143b79b93c33"))]) (compact-docstrings . [(0 2) nil "Shrink blank lines in docstrings and doc comments" tar @@ -1301,16 +1305,16 @@ ("Eduardo Ochs" . "eduardoochs@gmail.com")) (:commit . "25c810004c2201960f32a60b362eb6ebe524de9f"))]) (ef-themes . - [(1 8 0) + [(1 9 0) ((emacs (27 1))) "Colorful and legible themes" tar - ((:url . "https://git.sr.ht/~protesilaos/ef-themes") + ((:url . "https://github.com/protesilaos/ef-themes") (:keywords "faces" "theme" "accessibility") (:maintainer "Protesilaos Stavrou" . "info@protesilaos.com") (:authors ("Protesilaos Stavrou" . "info@protesilaos.com")) - (:commit . "18960c3bcb87e72418e638602a843be58aef07d1"))]) + (:commit . "b1333b703805a21ed6414386830cb5d1977475b7"))]) (eglot . [(1 17) ((emacs diff --git a/emacs/elpa/archives/gnu/archive-contents.signed b/emacs/elpa/archives/gnu/archive-contents.signed @@ -1 +1 @@ -Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) <elpasign@elpa.gnu.org> (trust undefined) created at 2024-11-13T22:05:06+0000 using EDDSA -\ No newline at end of file +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) <elpasign@elpa.gnu.org> (trust undefined) created at 2024-11-17T10:05:01+0000 using EDDSA +\ No newline at end of file diff --git a/emacs/elpa/archives/melpa/archive-contents b/emacs/elpa/archives/melpa/archive-contents @@ -337,13 +337,13 @@ (bibretrieve . [(20191124 1855) ((auctex (11 87)) (emacs (24 3))) "Retrieve BibTeX entries from the internet" tar ((:url . "https://github.com/pzorin/bibretrieve") (:commit . "81dc8e0db3629cc180eafb2bc34b60dcd8980316") (:revdesc . "81dc8e0db362") (:keywords "bibtex" "bibliography" "mathscinet" "arxiv" "zbmath") (:maintainers ("Pavel Zorin-Kranich" . "pzorin@uni-bonn.de")) (:maintainer "Pavel Zorin-Kranich" . "pzorin@uni-bonn.de"))]) (bibslurp . [(20151202 2346) ((s (1 6 0)) (dash (1 5 0))) "Retrieve BibTeX entries from NASA ADS" tar ((:url . "https://github.com/mkmcc/bibslurp") (:commit . "aeba96368f2a06959e4fe945375ce2a54d34b189") (:revdesc . "aeba96368f2a") (:keywords "bibliography" "nasa ads"))]) (bibtex-capf . [(20240122 1558) ((emacs (27 1)) (parsebib (3 0)) (org (9 5))) "Completion at point for bibtex" tar ((:url . "https://github.com/mclear-tools/bibtex-capf") (:commit . "31826efefcbbdebdb700a06b5070df0f06ce2291") (:revdesc . "31826efefcbb") (:keywords "bibtex" "convenience"))]) - (bibtex-completion . [(20240220 1216) ((parsebib (1 0)) (s (1 9 0)) (dash (2 6 0)) (f (0 16 2)) (cl-lib (0 5)) (biblio (0 2)) (emacs (26 1))) "A BibTeX backend for completion frameworks" tar ((:url . "https://github.com/tmalsburg/helm-bibtex") (:commit . "8b71b4f5ce62eeaf18067f57faaddc06449fbe1c") (:revdesc . "8b71b4f5ce62") (:authors ("Titus von der Malsburg" . "malsburg@posteo.de") ("Justin Burkett" . "justin@burkett.cc")) (:maintainers ("Titus von der Malsburg" . "malsburg@posteo.de")) (:maintainer "Titus von der Malsburg" . "malsburg@posteo.de"))]) + (bibtex-completion . [(20241116 726) ((parsebib (6 0)) (s (1 9 0)) (dash (2 6 0)) (f (0 16 2)) (cl-lib (0 5)) (biblio (0 2)) (emacs (26 1))) "A BibTeX backend for completion frameworks" tar ((:url . "https://github.com/tmalsburg/helm-bibtex") (:commit . "6064e8625b2958f34d6d40312903a85c173b5261") (:revdesc . "6064e8625b29") (:authors ("Titus von der Malsburg" . "malsburg@posteo.de") ("Justin Burkett" . "justin@burkett.cc")) (:maintainers ("Titus von der Malsburg" . "malsburg@posteo.de")) (:maintainer "Titus von der Malsburg" . "malsburg@posteo.de"))]) (bibtex-utils . [(20190703 2117) nil "Provides utilities for extending BibTeX mode" tar ((:url . "https://github.com/plantarum/bibtex-utils") (:commit . "26a8f0909b6adbf545a2b5e57ce7f779bf7a65af") (:revdesc . "26a8f0909b6a") (:keywords "bibtex") (:authors ("Tyler Smith" . "tyler@plantarum.ca")) (:maintainers ("Tyler Smith" . "tyler@plantarum.ca")) (:maintainer "Tyler Smith" . "tyler@plantarum.ca"))]) (bicycle . [(20240831 2208) ((emacs (26 1)) (compat (30 0 0 0))) "Cycle outline and code visibility" tar ((:url . "https://github.com/tarsius/bicycle") (:commit . "04c3e44eb10303b81c47c1d333df1fa23a224963") (:revdesc . "04c3e44eb103") (:keywords "outlines") (:authors ("Jonas Bernoulli" . "emacs.bicycle@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.bicycle@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.bicycle@jonas.bernoulli.dev"))]) (bifocal . [(20200325 539) ((emacs (24 4))) "Split-screen scrolling for comint-mode buffers" tar ((:url . "https://github.com/riscy/bifocal-mode") (:commit . "773a6dde790c4a240e643a9071e4c7bce09d40de") (:revdesc . "773a6dde790c") (:keywords "frames" "processes"))]) (binclock . [(20170802 1116) ((cl-lib (0 5))) "Display the current time using a binary clock" tar ((:url . "https://github.com/davep/binclock.el") (:commit . "87042230d7f3fe3e9a77fae0dbab7d8f7e7794ad") (:revdesc . "87042230d7f3") (:keywords "games" "time" "display") (:authors ("Dave Pearson" . "davep@davep.org")) (:maintainers ("Dave Pearson" . "davep@davep.org")) (:maintainer "Dave Pearson" . "davep@davep.org"))]) (bind . [(20231001 2051) ((emacs (25 1))) "Bind commands to keys" tar ((:url . "https://github.com/repelliuss/bind") (:commit . "4c1698a7c1c9f3d45559c3be871d87d76a1cbe00") (:revdesc . "4c1698a7c1c9") (:authors ("repelliuss" . "https://github.com/repelliuss")) (:maintainers ("repelliuss" . "repelliuss@gmail.com")) (:maintainer "repelliuss" . "repelliuss@gmail.com"))]) - (bind-chord . [(20221117 1610) ((emacs (24 3)) (bind-key (1 0)) (key-chord (0 6))) "Key-chord binding helper for use-package-chords" tar ((:url . "https://github.com/jwiegley/use-package") (:commit . "9090080b15486c3e337be254226efe7e5fde4c99") (:revdesc . "9090080b1548") (:keywords "convenience" "tools" "extensions") (:authors ("Justin Talbott" . "justin@waymondo.com")) (:maintainers ("Justin Talbott" . "justin@waymondo.com")) (:maintainer "Justin Talbott" . "justin@waymondo.com"))]) + (bind-chord . [(20241115 2228) ((emacs (24 3)) (bind-key (1 0)) (key-chord (0 6))) "Key-chord binding helper for use-package-chords" tar ((:url . "https://github.com/waymondo/use-package-chords") (:commit . "a2b16a1e64b19ae9428a6cd8f3e09b8159707a29") (:revdesc . "a2b16a1e64b1") (:keywords "convenience" "tools" "extensions") (:authors ("Justin Talbott" . "justin@waymondo.com")) (:maintainers ("Justin Talbott" . "justin@waymondo.com")) (:maintainer "Justin Talbott" . "justin@waymondo.com"))]) (bind-map . [(20240308 2050) ((emacs (24 3))) "Bind personal keymaps in multiple locations" tar ((:url . "https://github.com/justbur/emacs-bind-map") (:commit . "d7b0e42b78f708669ec368ebbd1f503094ceee22") (:revdesc . "d7b0e42b78f7") (:authors ("Justin Burkett" . "justin@burkett.cc")) (:maintainers ("Justin Burkett" . "justin@burkett.cc")) (:maintainer "Justin Burkett" . "justin@burkett.cc"))]) (binder . [(20241023 1154) ((emacs (24 4)) (seq (2 20))) "Global minor mode to facilitate multi-file writing projects" tar ((:url . "https://codeberg.org/divyaranjan/binder") (:commit . "928a68ff2cb186404f4247499a9d8a7a7a8c1f84") (:revdesc . "928a68ff2cb1") (:keywords "files" "outlines" "wp" "text") (:authors ("Paul W. Rankin" . "rnkn@rnkn.xyz")) (:maintainers ("Paul W. Rankin" . "rnkn@rnkn.xyz")) (:maintainer "Paul W. Rankin" . "rnkn@rnkn.xyz"))]) (bing-dict . [(20200216 110) nil "Minimalists' English-Chinese Bing dictionary" tar ((:url . "https://github.com/cute-jumper/bing-dict.el") (:commit . "1d581aaa9622b34f8fb83af5579fa252aa24cfef") (:revdesc . "1d581aaa9622") (:keywords "extensions") (:authors ("Junpeng Qiu" . "qjpchmail@gmail.com")) (:maintainers ("Junpeng Qiu" . "qjpchmail@gmail.com")) (:maintainer "Junpeng Qiu" . "qjpchmail@gmail.com"))]) @@ -531,7 +531,7 @@ (chapel-mode . [(20210513 457) ((emacs (25 1)) (hydra (0 15 0))) "A major mode for the Chapel programming language" tar ((:url . "https://github.com/damon-kwok/chapel-mode") (:commit . "39fd24bb7cf44808200354ac0496be4fc4fddd9a") (:revdesc . "39fd24bb7cf4") (:keywords "chapel" "chpl" "programming" "languages"))]) (char-menu . [(20210321 1657) ((emacs (24 3)) (avy-menu (0 1))) "Create your own menu for fast insertion of arbitrary symbols" tar ((:url . "https://github.com/mrkkrp/char-menu") (:commit . "d77c4d64fc8acc386a0fb9727d346c838e75f011") (:revdesc . "d77c4d64fc8a") (:keywords "convenience" "editing") (:authors ("Mark Karpov" . "markkarpov92@gmail.com")) (:maintainers ("Mark Karpov" . "markkarpov92@gmail.com")) (:maintainer "Mark Karpov" . "markkarpov92@gmail.com"))]) (charmap . [(20200616 1418) nil "Unicode table for Emacs" tar ((:url . "https://github.com/lateau/charmap") (:commit . "feac50b87d2a596c5e5b7b82b79ddd65b6dedd8c") (:revdesc . "feac50b87d2a") (:keywords "unicode" "character" "ucs") (:authors ("Anan Mikami" . "lateau@gmail.com")) (:maintainers ("Anan Mikami" . "lateau@gmail.com")) (:maintainer "Anan Mikami" . "lateau@gmail.com"))]) - (chatgpt-shell . [(20241112 1907) ((emacs (28 1)) (shell-maker (0 62 1))) "ChatGPT shell + buffer insert commands" tar ((:url . "https://github.com/xenodium/chatgpt-shell") (:commit . "42d24de2e2e7e6badb0137ad642b98cfba8a6ccc") (:revdesc . "42d24de2e2e7"))]) + (chatgpt-shell . [(20241113 2229) ((emacs (28 1)) (shell-maker (0 62 1))) "ChatGPT shell + buffer insert commands" tar ((:url . "https://github.com/xenodium/chatgpt-shell") (:commit . "fa383b47ed258c1d7b61d7399df02f74a0f8aa98") (:revdesc . "fa383b47ed25"))]) (chatu . [(20240518 615) ((org (9 6 6)) (emacs (29 1)) (plantuml-mode (1 2 9))) "Convert and insert any images to org-mode or markdown buffer" tar ((:url . "https://github.com/kimim/chatu") (:commit . "f813f0bc926346fbd8151d2ae7079119d4657abb") (:revdesc . "f813f0bc9263") (:keywords "multimedia" "convenience") (:authors ("Kimi Ma" . "kimi.im@outlook.com")) (:maintainers ("Kimi Ma" . "kimi.im@outlook.com")) (:maintainer "Kimi Ma" . "kimi.im@outlook.com"))]) (chatwork . [(20240910 1531) nil "ChatWork client for Emacs" tar ((:url . "https://github.com/ataka/chatwork") (:commit . "5abbf07bd6063c922191cc645f5771a943e3043c") (:revdesc . "5abbf07bd606") (:keywords "web") (:authors ("Masayuki Ataka" . "masayuki.ataka@gmail.com")) (:maintainers ("Masayuki Ataka" . "masayuki.ataka@gmail.com")) (:maintainer "Masayuki Ataka" . "masayuki.ataka@gmail.com"))]) (cheat-sh . [(20210607 1307) ((emacs (25 1))) "Interact with cheat.sh" tar ((:url . "https://github.com/davep/cheat-sh.el") (:commit . "33bae22feae8d3375739c6bdef08d0dcdf47ee42") (:revdesc . "33bae22feae8") (:keywords "docs" "help") (:authors ("Dave Pearson" . "davep@davep.org")) (:maintainers ("Dave Pearson" . "davep@davep.org")) (:maintainer "Dave Pearson" . "davep@davep.org"))]) @@ -563,7 +563,7 @@ (chruby . [(20180114 1652) ((cl-lib (0 5))) "Emacs integration for chruby" tar ((:url . "https://github.com/plexus/chruby.el") (:commit . "42bc6d521f832eca8e2ba210f30d03ad5529788f") (:revdesc . "42bc6d521f83") (:keywords "languages") (:authors ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainers ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainer "Arne Brasseur" . "arne@arnebrasseur.net"))]) (chyla-dark-theme . [(20240824 1615) ((emacs (24 1))) "Chyla.org - dark green color theme" tar ((:url . "https://github.com/chyla/ChylaDarkThemeForEmacs") (:commit . "274ff01146e265f773478b16a59483b638b986f8") (:revdesc . "274ff01146e2") (:authors ("Adam Chyła https://chyla.org/" . "adam@chyla.org")) (:maintainers ("Adam Chyła https://chyla.org/" . "adam@chyla.org")) (:maintainer "Adam Chyła https://chyla.org/" . "adam@chyla.org"))]) (chyla-theme . [(20240708 2017) ((emacs (24 1))) "Chyla.org - green color theme" tar ((:url . "https://github.com/chyla/ChylaThemeForEmacs") (:commit . "c2bb425eaff0975e0c7081f282d291f7853f8376") (:revdesc . "c2bb425eaff0") (:authors ("Adam Chyła https://chyla.org/" . "adam@chyla.org")) (:maintainers ("Adam Chyła https://chyla.org/" . "adam@chyla.org")) (:maintainer "Adam Chyła https://chyla.org/" . "adam@chyla.org"))]) - (cider . [(20241031 717) ((emacs (26)) (clojure-mode (5 19)) (parseedn (1 2 1)) (queue (0 2)) (spinner (1 7)) (seq (2 22)) (sesman (0 3 2)) (transient (0 4 1))) "Clojure Interactive Development Environment that Rocks" tar ((:url . "https://github.com/clojure-emacs/cider") (:commit . "52016de3848909ccdaaf7184169d6a65004ab0ab") (:revdesc . "52016de38489") (:keywords "languages" "clojure" "cider") (:authors ("Tim King" . "kingtim@gmail.com") ("Phil Hagelberg" . "technomancy@gmail.com") ("Bozhidar Batsov" . "bozhidar@batsov.dev") ("Artur Malabarba" . "bruce.connor.am@gmail.com") ("Hugo Duncan" . "hugo@hugoduncan.org") ("Steve Purcell" . "steve@sanityinc.com")) (:maintainers ("Bozhidar Batsov" . "bozhidar@batsov.dev")) (:maintainer "Bozhidar Batsov" . "bozhidar@batsov.dev"))]) + (cider . [(20241115 343) ((emacs (26)) (clojure-mode (5 19)) (parseedn (1 2 1)) (queue (0 2)) (spinner (1 7)) (seq (2 22)) (sesman (0 3 2)) (transient (0 4 1))) "Clojure Interactive Development Environment that Rocks" tar ((:url . "https://github.com/clojure-emacs/cider") (:commit . "c228dec27df6b2c68262f17158208fe699e1ce02") (:revdesc . "c228dec27df6") (:keywords "languages" "clojure" "cider") (:authors ("Tim King" . "kingtim@gmail.com") ("Phil Hagelberg" . "technomancy@gmail.com") ("Bozhidar Batsov" . "bozhidar@batsov.dev") ("Artur Malabarba" . "bruce.connor.am@gmail.com") ("Hugo Duncan" . "hugo@hugoduncan.org") ("Steve Purcell" . "steve@sanityinc.com")) (:maintainers ("Bozhidar Batsov" . "bozhidar@batsov.dev")) (:maintainer "Bozhidar Batsov" . "bozhidar@batsov.dev"))]) (cider-decompile . [(20151122 537) ((cider (0 3 0)) (javap-mode (9))) "Decompilation extension for cider" tar ((:url . "https://github.com/clojure-emacs/cider-decompile") (:commit . "5d87035f3c3c14025e8f01c0c53d0ce2c8f56651") (:revdesc . "5d87035f3c3c") (:keywords "languages" "clojure" "cider"))]) (cider-eval-sexp-fu . [(20190311 2152) ((emacs (24)) (eval-sexp-fu (0 5 0))) "Briefly highlights an evaluated sexp" tar ((:url . "https://github.com/clojure-emacs/cider-eval-sexp-fu") (:commit . "7fd229f1441356866aedba611fd0cf4e89b50921") (:revdesc . "7fd229f14413") (:keywords "languages" "clojure" "cider") (:authors ("Sylvain Benner" . "sylvain.benner@gmail.com")) (:maintainers ("Sylvain Benner" . "sylvain.benner@gmail.com")) (:maintainer "Sylvain Benner" . "sylvain.benner@gmail.com"))]) (cider-hydra . [(20190816 1121) ((cider (0 22 0)) (hydra (0 13 0))) "Hydras for CIDER" tar ((:url . "https://github.com/clojure-emacs/cider-hydra") (:commit . "c3b8a15d72dddfbc390ab6a454bd7e4c765a2c95") (:revdesc . "c3b8a15d72dd") (:keywords "convenience" "tools") (:authors ("Tianxiang Xiong" . "tianxiang.xiong@gmail.com")) (:maintainers ("Tianxiang Xiong" . "tianxiang.xiong@gmail.com")) (:maintainer "Tianxiang Xiong" . "tianxiang.xiong@gmail.com"))]) @@ -777,16 +777,16 @@ (connection . [(20191111 446) nil "TCP-based client connection" tar ((:url . "https://github.com/myrkr/dictionary-el") (:commit . "c9cad101100975e88873636bfd426b7a19304ebd") (:revdesc . "c9cad1011009") (:keywords "network") (:authors ("Torsten Hilbrich" . "torsten.hilbrich@gmx.net")) (:maintainers ("Torsten Hilbrich" . "torsten.hilbrich@gmx.net")) (:maintainer "Torsten Hilbrich" . "torsten.hilbrich@gmx.net"))]) (conner . [(20240828 123) ((emacs (29 1))) "Define and run project specific commands" tar ((:url . "https://github.com/tralph3/conner") (:commit . "93caf208e8e7f6b0627e5eb162f1488311d16b4c") (:revdesc . "93caf208e8e7") (:keywords "tools"))]) (constant-theme . [(20180921 1012) ((emacs (24 1))) "A calm, dark, almost monochrome color theme" tar ((:url . "https://github.com/Jannis/emacs-constant-theme") (:commit . "0feb9f99d708633d62fa548c953ebbe68fd70de0") (:revdesc . "0feb9f99d708") (:keywords "themes") (:authors ("Jannis Pohlmann" . "contact@jannispohlmann.de")) (:maintainers ("Jannis Pohlmann" . "contact@jannispohlmann.de")) (:maintainer "Jannis Pohlmann" . "contact@jannispohlmann.de"))]) - (consult . [(20241105 2133) ((emacs (28 1)) (compat (30))) "Consulting completing-read" tar ((:url . "https://github.com/minad/consult") (:commit . "7a7af8dcdda02b9aa4a680a228b3f3a5cfa95334") (:revdesc . "7a7af8dcdda0") (:keywords "matching" "files" "completion") (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) + (consult . [(20241115 517) ((emacs (28 1)) (compat (30))) "Consulting completing-read" tar ((:url . "https://github.com/minad/consult") (:commit . "554c21567a05e367a0daf60a199ba1db6ba09eca") (:revdesc . "554c21567a05") (:keywords "matching" "files" "completion") (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) (consult-ag . [(20230227 406) ((emacs (27 1)) (consult (0 32))) "The silver searcher integration using Consult" tar ((:url . "https://github.com/yadex205/consult-ag") (:commit . "9eb4df265aedf2628a714610c2ade6d2f21de053") (:revdesc . "9eb4df265aed") (:authors ("Kanon Kakuno and contributors" . "yadex205@outlook.jp")) (:maintainers ("Kanon Kakuno and contributors" . "yadex205@outlook.jp")) (:maintainer "Kanon Kakuno and contributors" . "yadex205@outlook.jp"))]) (consult-codesearch . [(20230315 1424) ((emacs (27 1)) (consult (0 20))) "Consult interface for codesearch" tar ((:url . "https://github.com/youngker/consult-codesearch.el") (:commit . "51df545bb57b468058245950322ae15f6c3a0ce2") (:revdesc . "51df545bb57b") (:keywords "tools") (:authors ("Youngjoo Lee" . "youngker@gmail.com")) (:maintainers ("Youngjoo Lee" . "youngker@gmail.com")) (:maintainer "Youngjoo Lee" . "youngker@gmail.com"))]) (consult-company . [(20230606 1824) ((emacs (27 1)) (company (0 9)) (consult (0 9))) "Consult frontend for company" tar ((:url . "https://github.com/mohkale/consult-company") (:commit . "6e309fa9115c9ecd29aa27bff4e3b733979e5dbc") (:revdesc . "6e309fa9115c") (:authors ("mohsin kaleem" . "mohkale@kisara.moe")) (:maintainers ("mohsin kaleem" . "mohkale@kisara.moe")) (:maintainer "mohsin kaleem" . "mohkale@kisara.moe"))]) (consult-compile-multi . [(20240923 1814) ((emacs (28 1)) (compile-multi (0 4)) (consult (0 34))) "Consulting read support for `compile-multi'" tar ((:url . "https://github.com/mohkale/compile-multi") (:commit . "94b2f267d1e424cf523643a3c9841c83f0a86368") (:revdesc . "94b2f267d1e4") (:keywords "tools" "compile" "build") (:authors ("mohsin kaleem" . "mohkale@kisara.moe")) (:maintainers ("mohsin kaleem" . "mohkale@kisara.moe")) (:maintainer "mohsin kaleem" . "mohkale@kisara.moe"))]) (consult-dash . [(20230529 1419) ((emacs (27 2)) (dash-docs (1 4 0)) (consult (0 16))) "Consult front-end for dash-docs" tar ((:url . "https://codeberg.org/ravi/consult-dash") (:commit . "af9f26393583e4b5eb5f29fa4d7e72bf1a46d5f9") (:revdesc . "af9f26393583") (:keywords "consult" "dash" "docs") (:authors ("Ravi R Kiran" . "lists.ravi@gmail.com")) (:maintainers ("Ravi R Kiran" . "lists.ravi@gmail.com")) (:maintainer "Ravi R Kiran" . "lists.ravi@gmail.com"))]) - (consult-dir . [(20240506 236) ((emacs (27 1)) (consult (1 0))) "Insert paths into the minibuffer prompt" tar ((:url . "https://github.com/karthink/consult-dir") (:commit . "15891383f34d43acc5bb82bda92239b1f54cf178") (:revdesc . "15891383f34d") (:keywords "convenience") (:maintainers ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainer "Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))]) + (consult-dir . [(20241114 454) ((emacs (27 1)) (consult (1 0))) "Insert paths into the minibuffer prompt" tar ((:url . "https://github.com/karthink/consult-dir") (:commit . "26fd5516511747ecefe98ef8e4592e330d99e6ae") (:revdesc . "26fd55165117") (:keywords "convenience") (:maintainers ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainer "Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))]) (consult-eglot . [(20241107 2125) ((emacs (27 1)) (eglot (1 7)) (consult (0 31)) (project (0 3 0))) "A consulting-read interface for eglot" tar ((:url . "https://github.com/mohkale/consult-eglot") (:commit . "c5f87d92448cd9c22a33ebd1feb54ca2fb89afa8") (:revdesc . "c5f87d92448c") (:keywords "tools" "completion" "lsp") (:authors ("mohsin kaleem" . "mohkale@kisara.moe")))]) (consult-eglot-embark . [(20241107 2125) ((emacs (27 1)) (consult-eglot (0 3)) (embark-consult (1 0))) "Embark integration for `consult-eglot'" tar ((:url . "https://github.com/mohkale/consult-eglot") (:commit . "c5f87d92448cd9c22a33ebd1feb54ca2fb89afa8") (:revdesc . "c5f87d92448c") (:keywords "tools" "completion" "lsp") (:authors ("mohsin kaleem" . "mohkale@kisara.moe")))]) - (consult-flycheck . [(20240926 917) ((emacs (28 1)) (consult (1 8)) (flycheck (34))) "Provides the command `consult-flycheck'" tar ((:url . "https://github.com/minad/consult-flycheck") (:commit . "bad8a8a25328782dfce3a9e4de6ad6d325b353d7") (:revdesc . "bad8a8a25328") (:keywords "languages" "tools" "completion") (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) + (consult-flycheck . [(20241114 1120) ((emacs (28 1)) (consult (1 8)) (flycheck (34))) "Provides the command `consult-flycheck'" tar ((:url . "https://github.com/minad/consult-flycheck") (:commit . "fa7a3a3b5d31d318582f7a1935a3c812fcdc4368") (:revdesc . "fa7a3a3b5d31") (:keywords "languages" "tools" "completion") (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) (consult-flyspell . [(20230322 204) ((emacs (25 1)) (consult (0 12))) "Consult integration for flyspell" tar ((:url . "https://gitlab.com/OlMon/consult-flyspell") (:commit . "7011e6634598530ea2d874e7e7389dc1bb94e1ca") (:revdesc . "7011e6634598") (:keywords "convenience"))]) (consult-gh . [(20241001 23) ((emacs (29 1)) (consult (1 0)) (markdown-mode (2 6))) "Consulting GitHub Client" tar ((:url . "https://github.com/armindarvish/consult-gh") (:commit . "bdc5516435ffa9efcd4de102b5d8549386b0ba6a") (:revdesc . "bdc5516435ff") (:keywords "convenience" "matching" "tools" "vc"))]) (consult-gh-embark . [(20240929 803) ((emacs (29 1)) (consult-gh (2 0)) (embark-consult (1 1))) "Embark Actions for consult-gh" tar ((:url . "https://github.com/armindarvish/consult-gh") (:commit . "4e4a1ef9a4823b37cf7057208f712aa69e1e0e2c") (:revdesc . "4e4a1ef9a482") (:keywords "matching" "git" "repositories" "forges" "completion"))]) @@ -813,13 +813,13 @@ (control-mode . [(20160624 1710) nil "A \"control\" mode, similar to vim's \"normal\" mode" tar ((:url . "https://github.com/stephendavidmarsh/control-mode") (:commit . "6bf487144119b03f9cc54168f70e3d7d8d84e22b") (:revdesc . "6bf487144119") (:keywords "convenience" "emulations") (:authors ("Stephen Marsh" . "stephen.david.marsh@gmail.com")) (:maintainers ("Stephen Marsh" . "stephen.david.marsh@gmail.com")) (:maintainer "Stephen Marsh" . "stephen.david.marsh@gmail.com"))]) (conventional-changelog . [(20230902 815) ((emacs (26 3)) (transient (0 4 1))) "Conventional Changelog Generator" tar ((:url . "https://github.com/liuyinz/emacs-conventional-changelog") (:commit . "97778186ff529a487d7fb0fc20d199d26ef70f5c") (:revdesc . "97778186ff52") (:keywords "tools") (:authors ("liuyinz" . "liuyinz95@gmail.com")) (:maintainers ("liuyinz" . "liuyinz95@gmail.com")) (:maintainer "liuyinz" . "liuyinz95@gmail.com"))]) (cool-mode . [(20231026 456) ((emacs (25))) "Major mode for cool compiler language" tar ((:url . "https://github.com/nverno/cool-mode") (:commit . "46b6a38a99a954c5e77e90506eafec4092690692") (:revdesc . "46b6a38a99a9") (:authors ("Noah Peart" . "noah.v.peart@gmail.com")) (:maintainers ("Noah Peart" . "noah.v.peart@gmail.com")) (:maintainer "Noah Peart" . "noah.v.peart@gmail.com"))]) - (copilot-chat . [(20241113 752) ((request (0 3 2)) (markdown-mode (2 6)) (emacs (27 1)) (chatgpt-shell (1 6 1)) (magit (4 0 0))) "Copilot chat interface" tar ((:url . "https://github.com/chep/copilot-chat.el") (:commit . "05c3c64bc16955270cb98f37190edab918dfc284") (:revdesc . "05c3c64bc169") (:keywords "convenience" "tools") (:authors ("cedric.chepied" . "cedric.chepied@gmail.com")) (:maintainers ("cedric.chepied" . "cedric.chepied@gmail.com")) (:maintainer "cedric.chepied" . "cedric.chepied@gmail.com"))]) + (copilot-chat . [(20241114 1226) ((request (0 3 2)) (markdown-mode (2 6)) (emacs (27 1)) (chatgpt-shell (1 6 1)) (magit (4 0 0))) "Copilot chat interface" tar ((:url . "https://github.com/chep/copilot-chat.el") (:commit . "d0bf1751a67cea931d732af1ee9bcc63bd1faaf6") (:revdesc . "d0bf1751a67c") (:keywords "convenience" "tools") (:authors ("cedric.chepied" . "cedric.chepied@gmail.com")) (:maintainers ("cedric.chepied" . "cedric.chepied@gmail.com")) (:maintainer "cedric.chepied" . "cedric.chepied@gmail.com"))]) (copy-as-format . [(20231112 1710) ((cl-lib (0 5))) "Copy buffer locations as GitHub/Slack/JIRA etc... formatted code" tar ((:url . "https://github.com/sshaw/copy-as-format") (:commit . "b9f6f725ca9701c5a02bfb479573fdfcce2e1e30") (:revdesc . "b9f6f725ca97") (:keywords "github" "slack" "jira" "telegram" "gitlab" "bitbucket" "org-mode" "pod" "rst" "asciidoc" "whatsapp" "tools" "convenience") (:authors ("Skye Shaw" . "skye.shaw@gmail.com")) (:maintainers ("Skye Shaw" . "skye.shaw@gmail.com")) (:maintainer "Skye Shaw" . "skye.shaw@gmail.com"))]) (copy-file-on-save . [(20230402 1829) ((emacs (24 3)) (compat (29))) "Copy file on save, automatic deployment it" tar ((:url . "https://github.com/emacs-php/emacs-auto-deployment") (:commit . "370b1586feb2690d3c72185bd4f17c31ce03673a") (:revdesc . "370b1586feb2") (:keywords "files" "comm" "deploy") (:authors ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainers ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainer "USAMI Kenta" . "tadsan@zonu.me"))]) (copyit . [(20241030 543) ((emacs (24 3)) (s (1 9 0))) "Copy it, yank anything!" tar ((:url . "https://github.com/zonuexe/emacs-copyit") (:commit . "09556ba8407dc2b132b7f76cd1b458c0773a1fe8") (:revdesc . "09556ba8407d") (:keywords "convenience" "yank" "clipboard") (:authors ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainers ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainer "USAMI Kenta" . "tadsan@zonu.me"))]) (copyit-pandoc . [(20190919 1258) ((emacs (24 3)) (copyit (0 1 0)) (pandoc (0 0 1))) "Copy it, yank anything!" tar ((:url . "https://github.com/zonuexe/emacs-copyit") (:commit . "c4f2c28e5b6270e8e3364341619f1154bb4e682e") (:revdesc . "c4f2c28e5b62") (:keywords "convenience" "yank" "clipboard") (:authors ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainers ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainer "USAMI Kenta" . "tadsan@zonu.me"))]) (coq-commenter . [(20170822 2309) ((dash (2 13 0)) (s (1 11 0)) (cl-lib (0 5))) "Coq commenting minor mode for proof" tar ((:url . "https://github.com/Ailrun/coq-commenter") (:commit . "7fe9a2cc0ebdb0b1e54a24eb7971d757fb588ac3") (:revdesc . "7fe9a2cc0ebd") (:keywords "comment" "coq" "proof") (:authors ("Junyoung Clare Jang" . "jjc9310@gmail.com")) (:maintainers ("Junyoung Clare Jang" . "jjc9310@gmail.com")) (:maintainer "Junyoung Clare Jang" . "jjc9310@gmail.com"))]) - (corfu . [(20241112 830) ((emacs (28 1)) (compat (30))) "COmpletion in Region FUnction" tar ((:url . "https://github.com/minad/corfu") (:commit . "3f468e9f355bb4e9a3e48d6323a51cc64eee3cc2") (:revdesc . "3f468e9f355b") (:keywords "abbrev" "convenience" "matching" "completion" "text") (:authors ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) + (corfu . [(20241115 528) ((emacs (28 1)) (compat (30))) "COmpletion in Region FUnction" tar ((:url . "https://github.com/minad/corfu") (:commit . "1529c30e2503c4a7e776201f190377cec3a6acd2") (:revdesc . "1529c30e2503") (:keywords "abbrev" "convenience" "matching" "completion" "text") (:authors ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) (corfu-candidate-overlay . [(20240322 1814) ((emacs (28 1)) (corfu (0 36))) "Show first candidate in an overlay while typing" tar ((:url . "https://code.bsdgeek.org/adam/corfu-candidate-overlay") (:commit . "f730de2c150720ee70d4d7be4b8bb533c7dfc97e") (:revdesc . "f730de2c1507") (:authors ("Adam Kruszewski" . "adam@kruszewski.name")) (:maintainers ("Adam Kruszewski" . "adam@kruszewski.name")) (:maintainer "Adam Kruszewski" . "adam@kruszewski.name"))]) (corfu-prescient . [(20240803 2320) ((emacs (27 1)) (prescient (6 1 0)) (corfu (1 1))) "Prescient.el + Corfu" tar ((:url . "https://github.com/radian-software/prescient.el") (:commit . "2b8a8b41228bddb2e11eb1c200e98a9edd04797c") (:revdesc . "2b8a8b41228b") (:keywords "extensions") (:authors ("Radian LLC" . "contact+prescient@radian.codes")) (:maintainers ("Radian LLC" . "contact+prescient@radian.codes")) (:maintainer "Radian LLC" . "contact+prescient@radian.codes"))]) (corral . [(20160502 948) nil "Quickly surround text with delimiters" tar ((:url . "https://github.com/nivekuil/corral") (:commit . "e7ab6aa118e46b93d4933d1364bc273f57cd6911") (:revdesc . "e7ab6aa118e4") (:authors ("Kevin Liu" . "mail@nivekuil.com")) (:maintainers ("Kevin Liu" . "mail@nivekuil.com")) (:maintainer "Kevin Liu" . "mail@nivekuil.com"))]) @@ -866,6 +866,7 @@ (cql-mode . [(20190315 225) ((emacs (24))) "Major mode for editting CQLs" tar ((:url . "https://github.com/Yuki-Inoue/cql-mode") (:commit . "d400c046850d3cf404778b2c47d6be4ff84ca04b") (:revdesc . "d400c046850d") (:keywords "cql" "cassandra") (:authors ("Yuki Inoue" . "inouetakahirokiatgmail.com")) (:maintainers ("Yuki Inoue" . "inouetakahirokiatgmail.com")) (:maintainer "Yuki Inoue" . "inouetakahirokiatgmail.com"))]) (cquery . [(20190118 542) ((emacs (25 1)) (lsp-mode (3 4)) (dash (0 13))) "Cquery client for lsp-mode" tar ((:url . "https://github.com/cquery-project/emacs-cquery") (:commit . "555e50984ebda177421fdcdc8c76cb29235d9694") (:revdesc . "555e50984ebd") (:keywords "languages" "lsp" "c++"))]) (crappy-jsp-mode . [(20140311 931) nil "A pretty crappy major-mode for jsp" tar ((:url . "https://github.com/magnars/crappy-jsp-mode") (:commit . "6c45ab92b452411cc0fab9bcee2f456276b4fc40") (:revdesc . "6c45ab92b452") (:keywords "jsp" "major" "mode"))]) + (crc . [(20241115 253) ((emacs (25 1))) "Cyclic Redundancy Check" tar ((:url . "https://codeberg.org/WammKD/Emacs-CRC") (:commit . "0c2d6bd56963c3a8b36e88d748a6cbaf3541c6a1") (:revdesc . "0c2d6bd56963") (:keywords "lisp" "checksum" "algorithms") (:authors ("Wamm K. D." . "jaft.r@outlook.com")) (:maintainers ("Wamm K. D." . "jaft.r@outlook.com")) (:maintainer "Wamm K. D." . "jaft.r@outlook.com"))]) (creamsody-theme . [(20240619 731) ((autothemer (0 2)) (emacs (24))) "Straight from the soda fountain" tar ((:url . "https://github.com/emacsfodder/emacs-theme-creamsody") (:commit . "10acf5c5d3e1108fc1e7a4ab487aa2ac79720f42") (:revdesc . "10acf5c5d3e1"))]) (create-link . [(20220621 1440) ((emacs (25 1))) "Smart format link generator" tar ((:url . "https://github.com/kijimaD/create-link") (:commit . "276fafcc6fb568ede256c8d459c3beb408ad9b46") (:revdesc . "276fafcc6fb5") (:keywords "link" "format" "browser" "convenience") (:authors ("Kijima Daigo" . "norimaking777@gmail.com")) (:maintainers ("Kijima Daigo" . "norimaking777@gmail.com")) (:maintainer "Kijima Daigo" . "norimaking777@gmail.com"))]) (creds . [(20140510 1706) ((s (1 9 0)) (dash (2 5 0))) "A parser credentials file library (not limited to credentials entries)" tar ((:url . "https://github.com/ardumont/emacs-creds") (:commit . "00ebefd10005c170b790a01380cb6a98f798ce5c") (:revdesc . "00ebefd10005") (:keywords "credentials") (:authors ("Antoine R. Dumont" . "eniotna.tATgmail.com")) (:maintainers ("Antoine R. Dumont" . "eniotna.tATgmail.com")) (:maintainer "Antoine R. Dumont" . "eniotna.tATgmail.com"))]) @@ -931,7 +932,7 @@ (dall-e-shell . [(20241112 1928) ((emacs (27 1)) (shell-maker (0 61 1))) "Interaction mode for DALL-E" tar ((:url . "https://github.com/xenodium/dall-e-shell") (:commit . "11d318a4ac37e6a5077ea4d66ddaa144f448cd14") (:revdesc . "11d318a4ac37"))]) (daml-lsp . [(20231101 1818) ((daml-mode (1 0)) (dash (2 18 0)) (f (0 20 0)) (ht (2 3)) (lsp-mode (7 0))) "LSP client definition for daml" tar ((:url . "https://github.com/bartfailt/daml-lsp") (:commit . "26ea6a1b34c49aaa5a2b395a0468c8af710bfab7") (:revdesc . "26ea6a1b34c4"))]) (daml-mode . [(20231106 916) ((emacs (27 1)) (haskell-mode (16 1))) "Major mode for daml" tar ((:url . "https://github.com/bartfailt/daml-mode") (:commit . "3ba1166edd4c22402996625b1f8a05a2d5b1cbc6") (:revdesc . "3ba1166edd4c"))]) - (danneskjold-theme . [(20240723 1000) nil "Beautiful high-contrast Emacs theme" tar ((:url . "https://github.com/rails-to-cosmos/danneskjold-theme") (:commit . "d495ba64e4a9e3e44b028b9fbc3898da3348ffdc") (:revdesc . "d495ba64e4a9") (:authors ("Dmitry Akatov" . "akatovda@yandex.com")) (:maintainers ("Dmitry Akatov" . "akatovda@yandex.com")) (:maintainer "Dmitry Akatov" . "akatovda@yandex.com"))]) + (danneskjold-theme . [(20241114 749) nil "Beautiful high-contrast Emacs theme" tar ((:url . "https://github.com/rails-to-cosmos/danneskjold-theme") (:commit . "96c000887d5bf7be17ff315c939bb7c8c962b86a") (:revdesc . "96c000887d5b") (:authors ("Dmitry Akatov" . "akatovda@yandex.com")) (:maintainers ("Dmitry Akatov" . "akatovda@yandex.com")) (:maintainer "Dmitry Akatov" . "akatovda@yandex.com"))]) (dante . [(20230808 658) ((dash (2 12 0)) (emacs (27 1)) (f (0 19 0)) (flycheck (0 30)) (company (0 9)) (flymake (1 0)) (s (1 11 0)) (lcr (1 5))) "Development mode for Haskell" tar ((:url . "https://github.com/jyp/dante") (:commit . "ca47f8cc1392c7045db7da8b4fafe86b7c044e90") (:revdesc . "ca47f8cc1392") (:keywords "haskell" "tools") (:authors ("Jean-Philippe Bernardy" . "jeanphilippe.bernardy@gmail.com")) (:maintainers ("Jean-Philippe Bernardy" . "jeanphilippe.bernardy@gmail.com")) (:maintainer "Jean-Philippe Bernardy" . "jeanphilippe.bernardy@gmail.com"))]) (dap-mode . [(20241101 659) ((emacs (27 1)) (dash (2 18 0)) (lsp-mode (6 0)) (bui (1 1 0)) (f (0 20 0)) (s (1 12 0)) (lsp-treemacs (0 1)) (posframe (0 7 0)) (ht (2 3)) (lsp-docker (1 0 0))) "Debug Adapter Protocol mode" tar ((:url . "https://github.com/emacs-lsp/dap-mode") (:commit . "605448b4fd90ca25924bf029acf2bdd047045133") (:revdesc . "605448b4fd90") (:keywords "languages" "debug") (:authors ("Ivan Yonchovski" . "yyoncho@gmail.com")) (:maintainers ("Ivan Yonchovski" . "yyoncho@gmail.com")) (:maintainer "Ivan Yonchovski" . "yyoncho@gmail.com"))]) (darcsum . [(20190316 2215) nil "A pcl-cvs like interface for managing darcs patches" tar ((:url . "https://github.com/emacsmirror/darcsum") (:commit . "6a8b690539d133c5e3d17cb23fe4365fbb6fb493") (:revdesc . "6a8b690539d1") (:keywords "completion" "convenience" "tools" "vc") (:authors ("John Wiegley" . "johnw@gnu.org")) (:maintainers ("John Wiegley" . "johnw@gnu.org")) (:maintainer "John Wiegley" . "johnw@gnu.org"))]) @@ -964,7 +965,7 @@ (db . [(20140421 2111) ((kv (0 0 11))) "A database for EmacsLisp" tar ((:url . "https://github.com/nicferrier/emacs-db") (:commit . "b3a423fb8e72f9013009cbe033d654df2ce31438") (:revdesc . "b3a423fb8e72") (:keywords "data" "lisp") (:authors ("Nic Ferrier" . "nferrier@ferrier.me.uk")) (:maintainers ("Nic Ferrier" . "nferrier@ferrier.me.uk")) (:maintainer "Nic Ferrier" . "nferrier@ferrier.me.uk"))]) (db-pg . [(20130131 1902) ((pg (0 12)) (db (0 0 6))) "A PostgreSQL adapter for emacs-db" tar ((:url . "https://github.com/nicferrier/emacs-db-pg") (:commit . "7d5ab86b74b05fe003b3b434d4835f37f3f3eded") (:revdesc . "7d5ab86b74b0") (:keywords "data" "comm" "database" "postgresql") (:authors ("Nic Ferrier" . "nic@ferrier.me.uk")) (:maintainers ("Nic Ferrier" . "nic@ferrier.me.uk")) (:maintainer "Nic Ferrier" . "nic@ferrier.me.uk"))]) (dbc . [(20201001 1452) ((emacs (24 4)) (cl-lib (0 5)) (ht (2 3))) "Control how to open buffers" tar ((:url . "https://gitlab.com/matsievskiysv/display-buffer-control") (:commit . "6728e72f72347d098b7d75ac4c29a7d687cc9ed3") (:revdesc . "6728e72f7234") (:keywords "convenience"))]) - (dbml-mode . [(20240928 1643) ((emacs (24 4))) "Major mode for DBML" tar ((:url . "https://github.com/KeyWeeUsr/dbml-mode") (:commit . "42ddcf4f19a823120477a9f22881d02099b85f1f") (:revdesc . "42ddcf4f19a8") (:keywords "convenience" "dbml" "language" "markup" "highlight" "dbdiagram" "diagram") (:authors ("Peter Badida" . "keyweeusr@gmail.com")) (:maintainers ("Peter Badida" . "keyweeusr@gmail.com")) (:maintainer "Peter Badida" . "keyweeusr@gmail.com"))]) + (dbml-mode . [(20241116 752) ((emacs (24 4))) "Major mode for DBML" tar ((:url . "https://github.com/KeyWeeUsr/dbml-mode") (:commit . "8baafca584012247859fe1a9e1d55eeed757a714") (:revdesc . "8baafca58401") (:keywords "convenience" "dbml" "language" "markup" "highlight" "dbdiagram" "diagram") (:authors ("Peter Badida" . "keyweeusr@gmail.com")) (:maintainers ("Peter Badida" . "keyweeusr@gmail.com")) (:maintainer "Peter Badida" . "keyweeusr@gmail.com"))]) (ddate . [(20221031 1611) ((emacs (24 4))) "Manage Discordian dates with ddate" tar ((:url . "https://git.sr.ht/~earneson/emacs-ddate") (:commit . "31576a62792743c614e362688b3752b7a959814e") (:revdesc . "31576a627927") (:keywords "lisp" "dates" "tools" "dashboard") (:authors ("Erik L. Arneson" . "earneson@arnesonium.com")) (:maintainers ("Erik L. Arneson" . "earneson@arnesonium.com")) (:maintainer "Erik L. Arneson" . "earneson@arnesonium.com"))]) (ddskk . [(20230701 2340) ((ccc (1 43)) (cdb (20141201 754))) "Simple Kana to Kanji conversion program" tar ((:url . "https://github.com/skk-dev/ddskk") (:commit . "8c47f46e38a29a0f3eabcd524268d20573102467") (:revdesc . "8c47f46e38a2") (:keywords "japanese" "mule" "input method") (:authors ("Masahiko Sato" . "masahiko@kuis.kyoto-u.ac.jp")))]) (ddskk-posframe . [(20200812 917) ((emacs (26 1)) (posframe (0 4 3)) (ddskk (16 2 50))) "Show Henkan tooltip for ddskk via posframe" tar ((:url . "https://github.com/conao3/ddskk-posframe.el") (:commit . "299493dd951e5a0b43b8213321e3dc0bac10f762") (:revdesc . "299493dd951e") (:keywords "tooltip" "convenience" "posframe") (:authors ("Naoya Yamashita" . "conao3@gmail.com")) (:maintainers ("Naoya Yamashita" . "conao3@gmail.com")) (:maintainer "Naoya Yamashita" . "conao3@gmail.com"))]) @@ -1142,7 +1143,7 @@ (dokuwiki-mode . [(20170223 1301) nil "Major mode for DokuWiki document" tar ((:url . "https://github.com/kai2nenobu/emacs-dokuwiki-mode") (:commit . "e4e116f6fcc373e3f5937c1a7daa5c2c9c6d3fa1") (:revdesc . "e4e116f6fcc3") (:keywords "hypermedia" "text" "dokuwiki") (:authors ("Tsunenobu Kai" . "kai2nenobu@gmail.com")) (:maintainers ("Tsunenobu Kai" . "kai2nenobu@gmail.com")) (:maintainer "Tsunenobu Kai" . "kai2nenobu@gmail.com"))]) (dollaro . [(20151123 1302) ((s (1 6 0))) "Simple text templates" tar ((:url . "https://github.com/laynor/dollaro") (:commit . "500127f0172ac7a1eec627e026b59136580a74ac") (:revdesc . "500127f0172a") (:keywords "tools" "convenience") (:authors ("Alessandro Piras" . "laynor@gmail.com")) (:maintainers ("Alessandro Piras" . "laynor@gmail.com")) (:maintainer "Alessandro Piras" . "laynor@gmail.com"))]) (doom . [(20180301 2308) ((cl-lib (0 5))) "DOM implementation and manipulation library" tar ((:url . "https://github.com/kensanata/doom") (:commit . "e59040aefc92dd9b3134eb623624307fb9e4327b") (:revdesc . "e59040aefc92") (:keywords "xml" "dom") (:authors ("Alex Schroeder" . "alex@gnu.org") ("Henrik.Motakef" . "elisp@henrik-motakef.de") ("Katherine Whitlock" . "toroidal-code@gmail.com") ("Syohei YOSHIDA" . "syohex@gmail.com")))]) - (doom-modeline . [(20241102 1416) ((emacs (25 1)) (compat (29 1 4 5)) (nerd-icons (0 1 0)) (shrink-path (0 3 1))) "A minimal and modern mode-line" tar ((:url . "https://github.com/seagle0128/doom-modeline") (:commit . "645ef52e2a5fc35325e9acbf54efcb725d4b74ab") (:revdesc . "645ef52e2a5f") (:keywords "faces" "mode-line") (:authors ("Vincent Zhang" . "seagle0128@gmail.com")) (:maintainers ("Vincent Zhang" . "seagle0128@gmail.com")) (:maintainer "Vincent Zhang" . "seagle0128@gmail.com"))]) + (doom-modeline . [(20241117 1101) ((emacs (25 1)) (compat (29 1 4 5)) (nerd-icons (0 1 0)) (shrink-path (0 3 1))) "A minimal and modern mode-line" tar ((:url . "https://github.com/seagle0128/doom-modeline") (:commit . "e6ae2ecfea9b5dd26191e131382a7505f7a775b9") (:revdesc . "e6ae2ecfea9b") (:keywords "faces" "mode-line") (:authors ("Vincent Zhang" . "seagle0128@gmail.com")) (:maintainers ("Vincent Zhang" . "seagle0128@gmail.com")) (:maintainer "Vincent Zhang" . "seagle0128@gmail.com"))]) (doom-modeline-now-playing . [(20240522 1704) ((emacs (24 4)) (doom-modeline (3 0 0)) (async (1 9 3))) "Segment for Doom Modeline to show playerctl information" tar ((:url . "https://github.com/elken/doom-modeline-now-playing") (:commit . "1532f324f98a234aa14e12ebdfd17cebba978d6a") (:revdesc . "1532f324f98a") (:authors ("Ellis Kenyő" . "me@elken.dev")) (:maintainers ("Ellis Kenyő" . "me@elken.dev")) (:maintainer "Ellis Kenyő" . "me@elken.dev"))]) (doom-themes . [(20240909 2117) ((emacs (25 1)) (cl-lib (0 5))) "An opinionated pack of modern color-themes" tar ((:url . "https://github.com/doomemacs/themes") (:commit . "1cac71a4b2434036496a49b4440fdba3d0b5b387") (:revdesc . "1cac71a4b243") (:keywords "themes" "faces") (:authors ("Henrik Lissner" . "contact@henrik.io")) (:maintainers ("Henrik Lissner" . "contact@henrik.io")) (:maintainer "Henrik Lissner" . "contact@henrik.io"))]) (dot-env . [(20230820 2014) ((emacs (24 4)) (s (1 13 0))) "Dotenv functionality" tar ((:url . "https://github.com/amodelbello/dot-env.el") (:commit . "83ce690e8ef9175fc621c85d5fbef4f7ace7b7a8") (:revdesc . "83ce690e8ef9") (:keywords "convenience" "dotenv" "environment" "configuration"))]) @@ -1188,7 +1189,7 @@ (dut-mode . [(20170729 2111) ((emacs (24))) "Major mode for the Dut programming language" tar ((:url . "https://github.com/dut-lang/dut-mode") (:commit . "9235c7acaa6690942e9de8b7acd1e4be0c859dc1") (:revdesc . "9235c7acaa66") (:keywords "languages" "gut"))]) (dw . [(20210331 2311) ((emacs (25 1))) "Diceware passphrase generation commands" tar ((:url . "https://github.com/integral-dw/dw-passphrase-generator") (:commit . "61c5718ba64ace4c9e29de18aa2690ecc3f0f258") (:revdesc . "61c5718ba64a") (:keywords "convenience" "games") (:authors ("D. Williams" . "d.williams@posteo.net")) (:maintainers ("D. Williams" . "d.williams@posteo.net")) (:maintainer "D. Williams" . "d.williams@posteo.net"))]) (dwim-coder-mode . [(20240712 1047) ((emacs (29))) "DWIM keybindings for C, Python, Rust, and more" tar ((:url . "https://gitlab.com/sadiq/dwim-coder-mode") (:commit . "02f5fa0c3ae5cc17ca860c792d988705f41b0eee") (:revdesc . "02f5fa0c3ae5") (:keywords "convenience" "hacks") (:authors ("Mohammed Sadiq" . "sadiq@sadiqpk.org")) (:maintainers ("Mohammed Sadiq" . "sadiq@sadiqpk.org")) (:maintainer "Mohammed Sadiq" . "sadiq@sadiqpk.org"))]) - (dwim-shell-command . [(20241106 942) ((emacs (28 1))) "Shell commands with DWIM behaviour" tar ((:url . "https://github.com/xenodium/dwim-shell-command") (:commit . "dd742977abaa25991a8b0b8beff1ae9e4bb39fd6") (:revdesc . "dd742977abaa"))]) + (dwim-shell-command . [(20241115 845) ((emacs (28 1))) "Shell commands with DWIM behaviour" tar ((:url . "https://github.com/xenodium/dwim-shell-command") (:commit . "1fa8b9d361f01618bf65111ac0b253adb0599a09") (:revdesc . "1fa8b9d361f0"))]) (dyalog-mode . [(20230214 1027) ((cl-lib (0 2)) (emacs (24 3))) "Major mode for editing Dyalog APL source code" tar ((:url . "https://github.com/harsman/dyalog-mode") (:commit . "13c0d391aa878a1609259a89fe3e6db8d21935e8") (:revdesc . "13c0d391aa87") (:keywords "languages") (:authors ("Joakim Hårsman" . "joakim.harsman@gmail.com")) (:maintainers ("Joakim Hårsman" . "joakim.harsman@gmail.com")) (:maintainer "Joakim Hårsman" . "joakim.harsman@gmail.com"))]) (dylan . [(20241102 2315) ((emacs (25 1))) "Dylan editing modes" tar ((:url . "https://github.com/dylan-lang/dylan-emacs-support") (:commit . "21e5953e2b1832f6a2c72012bd13795dc1ede52f") (:revdesc . "21e5953e2b18"))]) (dynamic-fonts . [(20140731 1226) ((font-utils (0 7 0)) (persistent-soft (0 8 8)) (pcache (0 2 3))) "Set faces based on available fonts" tar ((:url . "https://github.com/rolandwalker/dynamic-fonts") (:commit . "004ee6014dc7dbff8f14d26015c91d9229f6eac0") (:revdesc . "004ee6014dc7") (:keywords "faces" "frames") (:authors ("Roland Walker" . "walker@pobox.com")) (:maintainers ("Roland Walker" . "walker@pobox.com")) (:maintainer "Roland Walker" . "walker@pobox.com"))]) @@ -1209,7 +1210,7 @@ (eacl . [(20220526 1434) ((emacs (25 1))) "Auto-complete lines by grepping project" tar ((:url . "https://github.com/redguardtoo/eacl") (:commit . "4fe2cafbfeb73d806ebea8801c3522ff2886f30b") (:revdesc . "4fe2cafbfeb7") (:keywords "abbrev" "convenience" "matching") (:authors ("Chen Bin" . "chenbinDOTshATgmailDOTcom")) (:maintainers ("Chen Bin" . "chenbinDOTshATgmailDOTcom")) (:maintainer "Chen Bin" . "chenbinDOTshATgmailDOTcom"))]) (earl . [(20241020 1847) ((emacs (29 1))) "Erlang distribution protocol implementation" tar ((:url . "https://github.com/axelf4/earl") (:commit . "aa10aae9891a599f523f269cc391ed316775d12a") (:revdesc . "aa10aae9891a") (:keywords "comm" "extensions" "languages" "processes") (:authors ("Axel Forsman" . "axel@axelf.se")) (:maintainers ("Axel Forsman" . "axel@axelf.se")) (:maintainer "Axel Forsman" . "axel@axelf.se"))]) (earthfile-mode . [(20230809 2250) ((emacs (26))) "Major mode for editing Earthly file" tar ((:url . "https://github.com/earthly/earthly-emacs") (:commit . "3029e5ab06171ca5947041e95053561e10e5ba41") (:revdesc . "3029e5ab0617") (:authors ("Thanabodee Charoenpiriyakij" . "wingyminus@gmail.com")) (:maintainers ("Thanabodee Charoenpiriyakij" . "wingyminus@gmail.com")) (:maintainer "Thanabodee Charoenpiriyakij" . "wingyminus@gmail.com"))]) - (eask . [(20241102 912) ((emacs (26 1))) "Core Eask APIs, for Eask CLI development" tar ((:url . "https://github.com/emacs-eask/eask") (:commit . "111c68db78219022d1559caefa5aac013c842486") (:revdesc . "111c68db7821") (:keywords "lisp" "eask" "api") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) + (eask . [(20241114 423) ((emacs (26 1))) "Core Eask APIs, for Eask CLI development" tar ((:url . "https://github.com/emacs-eask/eask") (:commit . "d449538ab8d5783d22dc84680c6f27b273cb4478") (:revdesc . "d449538ab8d5") (:keywords "lisp" "eask" "api") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) (eask-mode . [(20240101 819) ((emacs (24 3)) (eask (0 1 0))) "Major mode for editing Eask files" tar ((:url . "https://github.com/emacs-eask/eask-mode") (:commit . "774bf05f2d778a107f27f8fa47034ad15f16395c") (:revdesc . "774bf05f2d77") (:keywords "lisp" "eask") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) (easky . [(20240608 744) ((emacs (27 1)) (eask-mode (0 1 0)) (eask (0 1 0)) (ansi (0 4 1)) (lv (0 0)) (marquee-header (0 1 0))) "Control the Eask command-line interface" tar ((:url . "https://github.com/emacs-eask/easky") (:commit . "d75ec4865742a4939bd685360f8ec5b076bdcf77") (:revdesc . "d75ec4865742") (:keywords "maint" "easky") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) (easy-after-load . [(20170817 1231) nil "Eval-after-load for all files in a directory" tar ((:url . "https://github.com/pd/easy-after-load") (:commit . "29e20145da49ac9ea40463c552130777408040de") (:revdesc . "29e20145da49"))]) @@ -1219,7 +1220,7 @@ (easy-kill . [(20220511 557) ((emacs (25)) (cl-lib (0 5))) "Kill & mark things easily" tar ((:url . "https://github.com/leoliu/easy-kill") (:commit . "de7d66c3c864a4722a973ee9bc228a14be49ba0c") (:revdesc . "de7d66c3c864") (:keywords "killing" "convenience") (:authors ("Leo Liu" . "sdl.web@gmail.com")) (:maintainers ("Leo Liu" . "sdl.web@gmail.com")) (:maintainer "Leo Liu" . "sdl.web@gmail.com"))]) (easy-kill-extras . [(20240122 1649) ((easy-kill (0 9 4))) "Extra functions for easy-kill" tar ((:url . "https://github.com/knu/easy-kill-extras.el") (:commit . "6ec0a1ff47aee681f7aa7af4250ede75815385f2") (:revdesc . "6ec0a1ff47ae") (:keywords "killing" "convenience") (:authors ("Akinori MUSHA" . "knu@iDaemons.org")) (:maintainers ("Akinori MUSHA" . "knu@iDaemons.org")) (:maintainer "Akinori MUSHA" . "knu@iDaemons.org"))]) (easy-repeat . [(20150516 848) ((emacs (24 4))) "Repeat easily" tar ((:url . "https://github.com/xuchunyang/easy-repeat.el") (:commit . "060f0e6801c82c40c06961dc0528a00e18947a8c") (:revdesc . "060f0e6801c8") (:keywords "repeat" "convenience") (:authors ("Chunyang Xu" . "xuchunyang56@gmail.com")) (:maintainers ("Chunyang Xu" . "xuchunyang56@gmail.com")) (:maintainer "Chunyang Xu" . "xuchunyang56@gmail.com"))]) - (easysession . [(20241110 1924) ((emacs (25 1)) (f (0 18 2))) "Easily persist and restore your editing sessions" tar ((:url . "https://github.com/jamescherti/easysession.el") (:commit . "507aca3a3e01f79cf7b8ee73a056b2ecdfa7cc12") (:revdesc . "507aca3a3e01") (:keywords "convenience"))]) + (easysession . [(20241115 1449) ((emacs (25 1)) (f (0 18 2))) "Easily persist and restore your editing sessions" tar ((:url . "https://github.com/jamescherti/easysession.el") (:commit . "991653e2ee64e03c7790b789343c74b60f337004") (:revdesc . "991653e2ee64") (:keywords "convenience"))]) (ebdb-mua-sidecar . [(20240428 1852) ((emacs (28 1)) (universal-sidecar (1 5 1)) (ebdb (0 8 20))) "EBDB Integration for Universal Sidecar" tar ((:url . "https://git.sr.ht/~swflint/emacs-universal-sidecar") (:commit . "4c78015d10caba9c700e6e6b582004ae1c1d5344") (:revdesc . "4c78015d10ca") (:keywords "mail" "convenience") (:authors ("Samuel W. Flint" . "me@samuelwflint.com")) (:maintainers ("Samuel W. Flint" . "me@samuelwflint.com")) (:maintainer "Samuel W. Flint" . "me@samuelwflint.com"))]) (ebf . [(20210225 1211) ((dash (2 18 0)) (cl-lib (0 5))) "Brainfuck language transpiler to Emacs Lisp" tar ((:url . "https://github.com/rexim/ebf") (:commit . "6cbeb4d62416f4cfd5be8906667342af8ecc44a6") (:revdesc . "6cbeb4d62416") (:authors ("Alexey Kutepov" . "reximkut@gmail.com")) (:maintainers ("Alexey Kutepov" . "reximkut@gmail.com")) (:maintainer "Alexey Kutepov" . "reximkut@gmail.com"))]) (ebib . [(20241109 2340) ((parsebib (6 0)) (emacs (27 1)) (compat (29 1 4 3))) "A BibTeX database manager" tar ((:url . "https://github.com/joostkremers/ebib") (:commit . "5dac71546bb8541ee67104c17df6fc3ae5e364db") (:revdesc . "5dac71546bb8") (:keywords "text" "bibtex") (:authors ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainers ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainer "Joost Kremers" . "joostkremers@fastmail.fm"))]) @@ -1254,7 +1255,7 @@ (editorconfig-generate . [(20190513 433) ((emacs (24))) "Generate .editorconfig" tar ((:url . "https://github.com/10sr/editorconfig-generate-el") (:commit . "47a31f928f46d2a0188db8e2cffa5d6354a81573") (:revdesc . "47a31f928f46") (:keywords "tools") (:authors ("10sr" . "8.slashes@gmail.com")) (:maintainers ("10sr" . "8.slashes@gmail.com")) (:maintainer "10sr" . "8.slashes@gmail.com"))]) (edn . [(20160215 1219) ((cl-lib (0 3)) (emacs (24 1)) (peg (0 6))) "Support for reading and writing the edn data format from elisp" tar ((:url . "https://github.com/expez/edn.el") (:commit . "be9e32d1b49e35247b263b0243df7cfdc8d413ab") (:revdesc . "be9e32d1b49e") (:keywords "edn" "clojure") (:authors ("Lars Andersen" . "expez@expez.com")) (:maintainers ("Lars Andersen" . "expez@expez.com")) (:maintainer "Lars Andersen" . "expez@expez.com"))]) (ednc . [(20240209 2028) ((emacs (26 1))) "Emacs Desktop Notification Center" tar ((:url . "https://github.com/sinic/ednc") (:commit . "2580ada68ecc93aa693c61f997c9cf581698242e") (:revdesc . "2580ada68ecc") (:keywords "unix") (:authors ("Simon Nicolussi" . "sinic@sinic.name")) (:maintainers ("Simon Nicolussi" . "sinic@sinic.name")) (:maintainer "Simon Nicolussi" . "sinic@sinic.name"))]) - (edts . [(20230926 2146) ((auto-complete (20201213 1255)) (auto-highlight-symbol (20211106 638)) (dash (20210609 1330)) (emacs (24 3)) (erlang (20210315 1640)) (f (20191110 1357)) (popup (20210317 138)) (s (20210603 736))) "Erlang Development Tool Suite" tar ((:url . "https://github.com/sebastiw/edts") (:commit . "5c3cded3fab56baa60874f4e1efd14155cec587f") (:revdesc . "5c3cded3fab5"))]) + (edts-mode . [(20230926 2146) nil "EDTS setup and configuration" tar ((:url . "https://github.com/sebastiw/edts") (:commit . "5c3cded3fab56baa60874f4e1efd14155cec587f") (:revdesc . "5c3cded3fab5") (:keywords "erlang") (:authors ("Thomas Järvstrand" . "thomas.jarvstrand@gmail.com")) (:maintainers ("Thomas Järvstrand" . "thomas.jarvstrand@gmail.com")) (:maintainer "Thomas Järvstrand" . "thomas.jarvstrand@gmail.com"))]) (edwina . [(20221206 1610) ((emacs (25))) "Dynamic window manager" tar ((:url . "https://gitlab.com/ajgrf/edwina") (:commit . "f95c31b1de95df7e83338a5d4daf3363df325862") (:revdesc . "f95c31b1de95") (:keywords "convenience") (:authors ("Alex Griffin" . "a@ajgrf.com")) (:maintainers ("Alex Griffin" . "a@ajgrf.com")) (:maintainer "Alex Griffin" . "a@ajgrf.com"))]) (efar . [(20230216 1213) ((emacs (26 1))) "FAR-like file manager" tar ((:url . "https://github.com/suntsov/efar") (:commit . "78618a6cd9fe7d46c3728db3589d1fe50f7c1c6b") (:revdesc . "78618a6cd9fe") (:keywords "files") (:authors ("Vladimir Suntsov" . "vladimir@suntsov.online")) (:maintainers (nil . "vladimir@suntsov.online")) (:maintainer nil . "vladimir@suntsov.online"))]) (eff . [(20240708 231) ((emacs (28))) "Show symbols in Executable File Formats" tar ((:url . "https://github.com/oxidase/eff") (:commit . "b8298439360b29333d3dcd8a352e00cde2b6ccd7") (:revdesc . "b8298439360b") (:keywords "elf" "readelf" "convenience"))]) @@ -1269,7 +1270,7 @@ (eglot-jl . [(20240911 1352) ((emacs (25 1)) (eglot (1 4)) (project (0 8 1)) (cl-generic (1 0))) "Julia support for eglot" tar ((:url . "https://github.com/non-Jedi/eglot-jl") (:commit . "7c968cc61fb64016ebe6dc8ff83fd05923db4374") (:revdesc . "7c968cc61fb6") (:keywords "convenience" "languages") (:authors ("Adam Beckmeyer" . "adam_git@thebeckmeyers.xyz")) (:maintainers ("Adam Beckmeyer" . "adam_git@thebeckmeyers.xyz")) (:maintainer "Adam Beckmeyer" . "adam_git@thebeckmeyers.xyz"))]) (eglot-luau . [(20241102 1924) ((emacs (29 1)) (eglot (1 17))) "Luau language server integration for eglot" tar ((:url . "https://github.com/kennethloeffler/eglot-luau") (:commit . "23335f45fb91de606e6971e93179df0fee0fd062") (:revdesc . "23335f45fb91") (:keywords "roblox" "luau" "tools") (:authors ("Kenneth Loeffler" . "kenloef@gmail.com")) (:maintainers ("Kenneth Loeffler" . "kenloef@gmail.com")) (:maintainer "Kenneth Loeffler" . "kenloef@gmail.com"))]) (eglot-signature-eldoc-talkative . [(20240626 815) ((emacs (29 1)) (eglot (1 16)) (eldoc (1 14 0)) (jsonrpc (1 0 23))) "Make Eglot make ElDoc echo docs" tar ((:url . "https://codeberg.org/mekeor/eglot-signature-eldoc-talkative") (:commit . "34cc207265f26f13142f5c62276e0ba18e1d55e4") (:revdesc . "34cc207265f2") (:keywords "convenience" "documentation" "eglot" "eldoc" "languages" "lsp") (:authors ("João Távora" . "joaotavora@gmail.com") ("Mekeor Melire" . "mekeor@posteo.de")) (:maintainers ("Mekeor Melire" . "mekeor@posteo.de")) (:maintainer "Mekeor Melire" . "mekeor@posteo.de"))]) - (eglot-tempel . [(20241012 1053) ((eglot (1 9)) (tempel (0 5)) (emacs (29 1)) (peg (1 0 1))) "Use tempel to expand snippets from eglot" tar ((:url . "https://github.com/fejfighter/eglot-tempel") (:commit . "72d5069809084db4447cad40531449714d75041e") (:revdesc . "72d506980908") (:keywords "convenience" "languages" "tools") (:authors ("Jeff Walsh" . "fejfighter@gmail.com")) (:maintainers ("Jeff Walsh" . "fejfighter@gmail.com")) (:maintainer "Jeff Walsh" . "fejfighter@gmail.com"))]) + (eglot-tempel . [(20241115 1110) ((eglot (1 9)) (tempel (0 5)) (emacs (29 1)) (peg (1 0 1))) "Use tempel to expand snippets from eglot" tar ((:url . "https://github.com/fejfighter/eglot-tempel") (:commit . "c6c9a18eba61f6bae7167fa62bab9b637592d20d") (:revdesc . "c6c9a18eba61") (:keywords "convenience" "languages" "tools") (:authors ("Jeff Walsh" . "fejfighter@gmail.com")) (:maintainers ("Jeff Walsh" . "fejfighter@gmail.com")) (:maintainer "Jeff Walsh" . "fejfighter@gmail.com"))]) (ego . [(20200803 1101) ((emacs (24 5)) (ht (1 5)) (mustache (0 22)) (htmlize (1 47)) (org (8 0)) (dash (2 0 0))) "A static site generator based on org mode, forked from org-page" tar ((:url . "https://github.com/emacs-china/EGO") (:commit . "211c4cb2af2582849d9df984fb2346deecaf79be") (:revdesc . "211c4cb2af25") (:keywords "org-mode" "convenience" "beautify") (:authors ("Feng Shu" . "tumashuAT163.com") ("Kelvin Hu" . "iniDOTkelvinATgmailDOTcom") ("Kuangdash" . "kuangdashAT163.com")) (:maintainers ("Feng Shu" . "tumashuAT163.com") ("Kelvin Hu" . "iniDOTkelvinATgmailDOTcom") ("Kuangdash" . "kuangdashAT163.com")) (:maintainer "Feng Shu" . "tumashuAT163.com"))]) (eide . [(20240122 1953) ((emacs (26 1))) "IDE interface" tar ((:url . "https://forge.tedomum.net/hjuvi/eide.git") (:commit . "d497539f00c33e3bee85d0f4b8ca367672fa2219") (:revdesc . "d497539f00c3") (:authors ("Cédric Marie" . "cedric@hjuvi.fr.eu.org")) (:maintainers ("Cédric Marie" . "cedric@hjuvi.fr.eu.org")) (:maintainer "Cédric Marie" . "cedric@hjuvi.fr.eu.org"))]) (eimp . [(20120826 2039) nil "Emacs Image Manipulation Package" tar ((:url . "https://github.com/nicferrier/eimp") (:commit . "2e7536fe6d8f7faf1bad7a8ae37faba0162c3b4f") (:revdesc . "2e7536fe6d8f") (:keywords "files" "frames") (:authors ("Matthew P. Hodges" . "MPHodges@member.fsf.org")) (:maintainers ("Nic Ferrier" . "nferrier@ferrier.me.uk")) (:maintainer "Nic Ferrier" . "nferrier@ferrier.me.uk"))]) @@ -1284,7 +1285,7 @@ (el-get . [(20240408 837) nil "Manage the external elisp bits and pieces you depend upon" tar ((:url . "https://github.com/dimitri/el-get") (:commit . "1c5b0eb7fa162523183a96e409e4e3ae6b5cc3a0") (:revdesc . "1c5b0eb7fa16") (:keywords "emacs" "package" "elisp" "install" "elpa" "git" "git-svn" "bzr" "cvs" "svn" "darcs" "hg" "apt-get" "fink" "pacman" "http" "http-tar" "emacswiki") (:authors ("Dimitri Fontaine" . "dim@tapoueh.org")) (:maintainers ("Dimitri Fontaine" . "dim@tapoueh.org")) (:maintainer "Dimitri Fontaine" . "dim@tapoueh.org"))]) (el-init . [(20150728 920) ((emacs (24)) (cl-lib (0 5)) (anaphora (1 0 0))) "A loader inspired by init-loader" tar ((:url . "https://github.com/HKey/el-init") (:commit . "25fd21d820bca1cf576b8f70c8d5a3bc76792597") (:revdesc . "25fd21d820bc") (:authors ("Hiroki YAMAKAWA" . "s06139@gmail.com")) (:maintainers ("Hiroki YAMAKAWA" . "s06139@gmail.com")) (:maintainer "Hiroki YAMAKAWA" . "s06139@gmail.com"))]) (el-init-viewer . [(20150303 828) ((emacs (24)) (cl-lib (0 5)) (ctable (0 1 2)) (dash (2 10 0)) (anaphora (1 0 0)) (el-init (0 1 4))) "Record viewer for el-init" tar ((:url . "https://github.com/HKey/el-init-viewer") (:commit . "c40417db7808c8b8c9b2f196a69de5da7eee84a2") (:revdesc . "c40417db7808") (:authors ("Hiroki YAMAKAWA" . "s06139@gmail.com")) (:maintainers ("Hiroki YAMAKAWA" . "s06139@gmail.com")) (:maintainer "Hiroki YAMAKAWA" . "s06139@gmail.com"))]) - (el-job . [(20241102 1057) ((emacs (28 1)) (compat (30))) "Call a function using all CPU cores" tar ((:url . "https://github.com/meedstrom/el-job") (:commit . "6323ebbb6727f7b8611e210d08cbe3edf9772d8d") (:revdesc . "6323ebbb6727") (:keywords "processes") (:authors ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainers ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainer "Martin Edström" . "meedstrom91@gmail.com"))]) + (el-job . [(20241114 2235) ((emacs (28 1)) (compat (30))) "Call a function using all CPU cores" tar ((:url . "https://github.com/meedstrom/el-job") (:commit . "32ea3c18394ef56bb61c4699c02038122160ea3a") (:revdesc . "32ea3c18394e") (:keywords "processes") (:authors ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainers ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainer "Martin Edström" . "meedstrom91@gmail.com"))]) (el-mock . [(20220625 1949) nil "Tiny Mock and Stub framework in Emacs Lisp" tar ((:url . "https://github.com/rejeep/el-mock.el") (:commit . "6cfbc9de8f1927295dca6864907fe4156bd71910") (:revdesc . "6cfbc9de8f19") (:keywords "lisp" "testing" "unittest") (:authors ("rubikitch" . "rubikitch@ruby-lang.org")) (:maintainers ("Johan Andersson" . "johan.rejeep@gmail.com")) (:maintainer "Johan Andersson" . "johan.rejeep@gmail.com"))]) (el-patch . [(20231123 2216) ((emacs (26))) "Future-proof your Elisp" tar ((:url . "https://github.com/radian-software/el-patch") (:commit . "92803e7ea6e07cd56667ed7ea0dfacfc1f37f6d9") (:revdesc . "92803e7ea6e0") (:keywords "extensions") (:authors ("Radian LLC" . "contact+el-patch@radian.codes")) (:maintainers ("Radian LLC" . "contact+el-patch@radian.codes")) (:maintainer "Radian LLC" . "contact+el-patch@radian.codes"))]) (el-secretario . [(20220426 1905) ((emacs (27 1)) (org-ql (0 6 -1)) (hercules (0 3))) "Unify all your inboxes with the Emacs secretary" tar ((:url . "https://git.sr.ht/~zetagon/el-secretario") (:commit . "575396ca689065188ad0f90c379d9bcf7ff6fc0b") (:revdesc . "575396ca6890") (:keywords "convenience") (:authors ("Leo Okawa Ericson" . "http://github/Zetagon")) (:maintainers ("Leo" . "github@relevant-information.com")) (:maintainer "Leo" . "github@relevant-information.com"))]) @@ -1303,7 +1304,7 @@ (elcontext . [(20210109 1238) ((ht (2 3)) (hydra (0 14 0)) (emacs (24 3)) (f (0 20 0)) (osx-location (0 4)) (uuidgen (0 3))) "Create context specific actions" tar ((:url . "https://github.com/rollacaster/elcontext") (:commit . "2efd3dd8c5176c4f071bb048be6cb069b05d6e9e") (:revdesc . "2efd3dd8c517") (:keywords "calendar" "convenience"))]) (elcord . [(20240826 1824) ((emacs (25 1))) "Allows you to integrate Rich Presence from Discord" tar ((:url . "https://github.com/Mstrodl/elcord") (:commit . "b47767e1cdc8e0e4aa50913db19609e7e093f002") (:revdesc . "b47767e1cdc8") (:keywords "games") (:authors ("Wilfredo Velázquez-Rodríguez" . "zulu.inuoe@gmail.com")) (:maintainers ("Wilfredo Velázquez-Rodríguez" . "zulu.inuoe@gmail.com")) (:maintainer "Wilfredo Velázquez-Rodríguez" . "zulu.inuoe@gmail.com"))]) (elcouch . [(20230903 750) ((emacs (25 1)) (json-mode (1 0 0)) (libelcouch (0 11 0)) (navigel (0 3 0))) "View and manipulate CouchDB databases" tar ((:url . "https://github.com/DamienCassou/elcouch") (:commit . "a426e9bee9501284f4e1e84766621ca6b130c79a") (:revdesc . "a426e9bee950") (:keywords "data" "tools") (:authors ("Damien Cassou" . "damien@cassou.me")) (:maintainers ("Damien Cassou" . "damien@cassou.me")) (:maintainer "Damien Cassou" . "damien@cassou.me"))]) - (elcute . [(20240920 1226) ((emacs (29 1))) "Commands for marking and killing lines electrically" tar ((:url . "https://codeberg.org/vilij/slurpbarf-elcute") (:commit . "481b7ea70b8ba6c972b33abad169494097e699cd") (:revdesc . "481b7ea70b8b") (:keywords "convenience"))]) + (elcute . [(20241115 1459) ((emacs (29 1))) "Commands for marking and killing lines electrically" tar ((:url . "https://codeberg.org/vilij/slurpbarf-elcute") (:commit . "c6e7d4b5da6f1116b479c71d9c7fa0aca71d4030") (:revdesc . "c6e7d4b5da6f") (:keywords "convenience"))]) (eldev . [(20241105 1904) ((emacs (24 4))) "Elisp development tool" tar ((:url . "https://github.com/emacs-eldev/eldev") (:commit . "f3c35dbde7dc60e8b5aea4b1e1d26a983d93862f") (:revdesc . "f3c35dbde7dc") (:keywords "maint" "tools") (:authors ("Paul Pogonyshev" . "pogonyshev@gmail.com")) (:maintainers ("Paul Pogonyshev" . "pogonyshev@gmail.com")) (:maintainer "Paul Pogonyshev" . "pogonyshev@gmail.com"))]) (eldoc-box . [(20241026 259) ((emacs (27 1))) "Display documentation in childframe" tar ((:url . "https://github.com/casouri/eldoc-box") (:commit . "cd01cc9cc9aee1f604f4259a41b0ab2659c946af") (:revdesc . "cd01cc9cc9ae") (:authors ("Yuan Fu" . "casouri@gmail.com")) (:maintainers ("Yuan Fu" . "casouri@gmail.com")) (:maintainer "Yuan Fu" . "casouri@gmail.com"))]) (eldoc-cmake . [(20190419 2244) ((emacs (25 1))) "Eldoc support for CMake" tar ((:url . "https://github.com/ikirill/eldoc-cmake") (:commit . "4453c03b5c95ff32842f13db2fc317fb0fe2f79e") (:revdesc . "4453c03b5c95"))]) @@ -1314,7 +1315,7 @@ (eldoc-toml . [(20211026 1122) ((emacs (24 4))) "TOML table name at point for ElDoc" tar ((:url . "https://github.com/it-is-wednesday/eldoc-toml") (:commit . "61106be3c3f3a5b293c3f285eec8c6f400142b6d") (:revdesc . "61106be3c3f3") (:keywords "data") (:authors ("Maor Kadosh" . "git@avocadosh.xyz")) (:maintainers ("Maor Kadosh" . "git@avocadosh.xyz")) (:maintainer "Maor Kadosh" . "git@avocadosh.xyz"))]) (electric-case . [(20150417 1112) nil "Insert camelCase, snake_case words without \"Shift\"ing" tar ((:url . "https://github.com/zk-phi/electric-case") (:commit . "984b6a4c6c4cdcefeecb59e941f5f184cc1dedff") (:revdesc . "984b6a4c6c4c"))]) (electric-cursor . [(20221221 438) ((emacs (25 1))) "Change cursor automatically depending on mode" tar ((:url . "https://codeberg.org/acdw/electric-cursor.el") (:commit . "bc09aa8c5d3cc32e3e6452cbf8018fc1ea772b73") (:revdesc . "bc09aa8c5d3c") (:keywords "terminals" "frames") (:authors ("Case Duckworth" . "acdw@acdw.net")) (:maintainers ("Case Duckworth" . "acdw@acdw.net")) (:maintainer "Case Duckworth" . "acdw@acdw.net"))]) - (electric-operator . [(20231014 1107) ((dash (2 10 0)) (emacs (24 4))) "Automatically add spaces around operators" tar ((:url . "https://github.com/davidshepherd7/electric-operator") (:commit . "18e555a5cdfd7264c179f810d7fd4c71a80b715a") (:revdesc . "18e555a5cdfd") (:keywords "electric") (:authors ("David Shepherd" . "davidshepherd7@gmail.com")) (:maintainers ("David Shepherd" . "davidshepherd7@gmail.com")) (:maintainer "David Shepherd" . "davidshepherd7@gmail.com"))]) + (electric-operator . [(20241114 1756) ((dash (2 10 0)) (emacs (24 4))) "Automatically add spaces around operators" tar ((:url . "https://github.com/davidshepherd7/electric-operator") (:commit . "ca19beb358f0a6f02aa2edc43fec2216c1bf471d") (:revdesc . "ca19beb358f0") (:keywords "electric") (:authors ("David Shepherd" . "davidshepherd7@gmail.com")) (:maintainers ("David Shepherd" . "davidshepherd7@gmail.com")) (:maintainer "David Shepherd" . "davidshepherd7@gmail.com"))]) (electric-ospl . [(20240428 1829) ((emacs (26 1))) "Electric OSPL Mode" tar ((:url . "https://git.sr.ht/~swflint/electric-ospl-mode") (:commit . "deab4493530ab4bb2112c18d8ca6ccc652e24a63") (:revdesc . "deab4493530a") (:keywords "convenience" "text") (:authors ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainers ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainer "Samuel W. Flint" . "swflint@flintfam.org"))]) (electric-spacing . [(20220220 1540) nil "Insert operators with surrounding spaces smartly" tar ((:url . "https://github.com/xwl/electric-spacing") (:commit . "c37b2502512dd49a8311d7c34e9bfd1af3d4dbcd") (:revdesc . "c37b2502512d") (:authors ("William Xu" . "william.xwl@gmail.com")) (:maintainers ("William Xu" . "william.xwl@gmail.com")) (:maintainer "William Xu" . "william.xwl@gmail.com"))]) (elegant-agenda-mode . [(20210115 353) ((emacs (26 1))) "An elegant theme for your org-agenda" tar ((:url . "https://github.com/justinbarclay/elegant-agenda-mode") (:commit . "5cbc688584ba103ea3be7d7b30e5d94e52f59eb6") (:revdesc . "5cbc688584ba") (:keywords "faces") (:authors ("Justin Barclay" . "justinbarclay@gmail.com")) (:maintainers ("Justin Barclay" . "justinbarclay@gmail.com")) (:maintainer "Justin Barclay" . "justinbarclay@gmail.com"))]) @@ -1389,7 +1390,7 @@ (emacs-everywhere . [(20240509 1715) ((emacs (26 3))) "System-wide popup windows for quick edits" tar ((:url . "https://github.com/tecosaur/emacs-everywhere") (:commit . "0b731ca6da351ba40953d090acf69e81757d437b") (:revdesc . "0b731ca6da35") (:keywords "convenience" "frames") (:authors ("TEC" . "https://github.com/tecosaur")) (:maintainers ("TEC" . "contact@tecosaur.net")) (:maintainer "TEC" . "contact@tecosaur.net"))]) (emacsc . [(20240629 1325) nil "Helper for emacsc(1)" tar ((:url . "https://github.com/knu/emacsc") (:commit . "49b0bbbcd021424da4000bf47193bd2d928b2228") (:revdesc . "49b0bbbcd021") (:keywords "tools") (:authors ("Akinori MUSHA" . "knu@iDaemons.org")) (:maintainers ("Akinori MUSHA" . "knu@iDaemons.org")) (:maintainer "Akinori MUSHA" . "knu@iDaemons.org"))]) (emacsist-view . [(20160426 1223) nil "Mode for viewing emacsist.com" tar ((:url . "https://github.com/lujun9972/emacsist-view") (:commit . "f67761259ed779a9bc95c9a4e0474522990c5c6b") (:revdesc . "f67761259ed7") (:keywords "convenience" "usability") (:authors ("DarkSun" . "lujun9972@gmail.com")) (:maintainers ("DarkSun" . "lujun9972@gmail.com")) (:maintainer "DarkSun" . "lujun9972@gmail.com"))]) - (emacsql . [(20240906 1342) ((emacs (25 1))) "High-level SQL database front-end" tar ((:url . "https://github.com/magit/emacsql") (:commit . "fb05d0f72729a4b4452a3b1168a9b7b35a851a53") (:revdesc . "fb05d0f72729") (:authors ("Christopher Wellons" . "wellons@nullprogram.com")) (:maintainers ("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))]) + (emacsql . [(20241116 1523) ((emacs (26 1))) "High-level SQL database front-end" tar ((:url . "https://github.com/magit/emacsql") (:commit . "8ebf559f58fdeba53d23e80562181fb67917942e") (:revdesc . "8ebf559f58fd") (:authors ("Christopher Wellons" . "wellons@nullprogram.com")) (:maintainers ("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))]) (emacsshot . [(20191206 944) ((emacs (24 4))) "Snapshot a frame or window from within" tar ((:url . "https://gitlab.com/marcowahl/emacsshot") (:commit . "fe958b11056f3c671ebdd604d5aa574323284ca5") (:revdesc . "fe958b11056f") (:keywords "convenience") (:authors ("Marco Wahl" . "marcowahlsoft@gmail.com")))]) (emamux . [(20200315 1220) ((emacs (24 3))) "Interact with tmux" tar ((:url . "https://github.com/emacsorphanage/emamux") (:commit . "6172131d78038f0b1490e24bac60534bf4ad3b30") (:revdesc . "6172131d7803") (:authors ("Syohei YOSHIDA" . "syohex@gmail.com")) (:maintainers ("Syohei YOSHIDA" . "syohex@gmail.com")) (:maintainer "Syohei YOSHIDA" . "syohex@gmail.com"))]) (emamux-ruby-test . [(20130812 1639) ((emamux (0 1)) (projectile (0 9 1))) "Ruby test with emamux" tar ((:url . "https://github.com/emacsorphanage/emamux-ruby-test") (:commit . "785bfd44d097a46bb2ebe1e62ac7595fd4dc9ab5") (:revdesc . "785bfd44d097"))]) @@ -1538,7 +1539,7 @@ (eval-sexp-fu . [(20191128 825) ((cl-lib (0))) "Tiny functionality enhancements for evaluating sexps" tar ((:url . "https://github.com/hchbaw/eval-sexp-fu.el") (:commit . "36d2fe3bcf602e15ca10a7f487da103515ef391a") (:revdesc . "36d2fe3bcf60") (:keywords "lisp" "highlight" "convenience") (:authors ("Takeshi Banse" . "takebi@laafc.net")) (:maintainers ("Takeshi Banse" . "takebi@laafc.net")) (:maintainer "Takeshi Banse" . "takebi@laafc.net"))]) (evalator . [(20160213 128) ((helm-core (1 9 1))) "Package for interactive transformation of data with helm" tar ((:url . "https://github.com/seanirby/evalator") (:commit . "f30da4da48c0b3f3cfa1fc1c7cfdb53ffe79df36") (:revdesc . "f30da4da48c0") (:keywords "languages" "elisp" "helm") (:maintainers ("Sean Irby" . "sean.t.irby@gmail.com")) (:maintainer "Sean Irby" . "sean.t.irby@gmail.com"))]) (evalator-clojure . [(20160208 2148) ((cider (0 10 0)) (evalator (1 0 0))) "Clojure evaluation context for evalator via CIDER" tar ((:url . "https://github.com/seanirby/evalator-clojure") (:commit . "caa4e0a137bdfada86593128a654e16aa617ad50") (:revdesc . "caa4e0a137bd") (:keywords "languages" "clojure" "cider" "helm") (:maintainers ("Sean Irby" . "sean.t.irby@gmail.com")) (:maintainer "Sean Irby" . "sean.t.irby@gmail.com"))]) - (evangelion-theme . [(20240907 723) ((emacs (27 1))) "A dark colour scheme inspired by Neon Genesis Evangelion" tar ((:url . "https://github.com/crmsnbleyd/evangelion-theme") (:commit . "59fb3f39611d995c2e322a22e661165b87f4667e") (:revdesc . "59fb3f39611d") (:keywords "faces" "theme") (:authors ("Andrew Jose" . "mail@drewsh.com")) (:maintainers ("Andrew Jose" . "mail@drewsh.com")) (:maintainer "Andrew Jose" . "mail@drewsh.com"))]) + (evangelion-theme . [(20241116 1036) ((emacs (27 1))) "A dark colour scheme inspired by Neon Genesis Evangelion" tar ((:url . "https://github.com/crmsnbleyd/evangelion-theme") (:commit . "89577330e93f1c11b3e75d1c8bbae6accc18fc48") (:revdesc . "89577330e93f") (:keywords "faces" "theme") (:authors ("Andrew Jose" . "mail@drewsh.com")) (:maintainers ("Andrew Jose" . "mail@drewsh.com")) (:maintainer "Andrew Jose" . "mail@drewsh.com"))]) (eve-mode . [(20170822 2231) ((emacs (25)) (polymode (1 0)) (markdown-mode (2 0))) "Major mode for editing Eve documents" tar ((:url . "https://github.com/witheve/emacs-eve-mode") (:commit . "a4661114d9c18725691b76321d72167ca5a9070a") (:revdesc . "a4661114d9c1") (:keywords "languages" "wp" "tools") (:authors ("Joshua Cole" . "joshuafcole@gmail.com")) (:maintainers ("Joshua Cole" . "joshuafcole@gmail.com")) (:maintainer "Joshua Cole" . "joshuafcole@gmail.com"))]) (evenok . [(20241031 2134) ((emacs (28 1))) "Themes with perceptively evenly distributed colors" tar ((:url . "https://codeberg.org/mekeor/evenok") (:commit . "06a84eea4cf9a845266f8bde68abe25d85bd2b77") (:revdesc . "06a84eea4cf9") (:keywords "faces" "theme") (:authors ("Mekeor Melire" . "mekeor@posteo.de")) (:maintainers ("Mekeor Melire" . "mekeor@posteo.de")) (:maintainer "Mekeor Melire" . "mekeor@posteo.de"))]) (everlasting-scratch . [(20240612 814) ((emacs (25 1))) "The *scratch* that lasts forever" tar ((:url . "https://github.com/beacoder/everlasting-scratch") (:commit . "fa1b2af29e8bb463400bbea912ab4dfaa2b0c890") (:revdesc . "fa1b2af29e8b") (:keywords "convenience" "tool") (:authors ("Huming Chen" . "chenhuming@gmail.com")) (:maintainers ("Huming Chen" . "chenhuming@gmail.com")) (:maintainer "Huming Chen" . "chenhuming@gmail.com"))]) @@ -1550,7 +1551,7 @@ (evil-cleverparens . [(20240529 1025) ((evil (1 0)) (paredit (1)) (smartparens (1 6 1)) (emacs (24 4)) (dash (2 12 0))) "Evil friendly minor-mode for editing lisp" tar ((:url . "https://github.com/emacs-evil/evil-cleverparens") (:commit . "6637717af0bdac55f97eef98433d53a10395cf77") (:revdesc . "6637717af0bd") (:keywords "convenience" "emulations") (:authors ("Olli Piepponen" . "opieppo@gmail.com")) (:maintainers ("Olli Piepponen" . "opieppo@gmail.com")) (:maintainer "Olli Piepponen" . "opieppo@gmail.com"))]) (evil-colemak-basics . [(20241004 1613) ((emacs (24 3)) (evil (1 2 12)) (evil-snipe (2 0 3))) "Basic Colemak key bindings for evil-mode" tar ((:url . "https://github.com/wbolster/emacs-evil-colemak-basics") (:commit . "9465c8da35fe7dd0f66184e671e357ec91faa3fe") (:revdesc . "9465c8da35fe") (:keywords "convenience" "emulations" "colemak" "evil") (:authors ("Wouter Bolsterlee" . "wouter@bolsterl.ee")) (:maintainers ("Wouter Bolsterlee" . "wouter@bolsterl.ee")) (:maintainer "Wouter Bolsterlee" . "wouter@bolsterl.ee"))]) (evil-colemak-minimal . [(20171006 1317) ((emacs (24)) (evil (1 2 12))) "Minimal Colemak key bindings for evil-mode" tar ((:url . "https://github.com/bmallred/evil-colemak-minimal") (:commit . "6d98b6da60f414524a0d718f76024c26dce742b3") (:revdesc . "6d98b6da60f4") (:keywords "colemak" "evil") (:authors ("Bryan Allred" . "bryan@revolvingcow.com")) (:maintainers ("Bryan Allred" . "bryan@revolvingcow.com")) (:maintainer "Bryan Allred" . "bryan@revolvingcow.com"))]) - (evil-collection . [(20241031 1423) ((emacs (26 3)) (evil (1 2 13)) (annalist (1 0))) "A set of keybindings for Evil mode" tar ((:url . "https://github.com/emacs-evil/evil-collection") (:commit . "5a1315bfc7f21533de12f35544b29c29ccec491d") (:revdesc . "5a1315bfc7f2") (:keywords "evil" "tools") (:authors ("James Nguyen" . "james@jojojames.com")) (:maintainers ("James Nguyen" . "james@jojojames.com")) (:maintainer "James Nguyen" . "james@jojojames.com"))]) + (evil-collection . [(20241116 1603) ((emacs (26 3)) (evil (1 2 13)) (annalist (1 0))) "A set of keybindings for Evil mode" tar ((:url . "https://github.com/emacs-evil/evil-collection") (:commit . "4f179477f7d2ab705b05f5e3524a9aa3de8d6d3d") (:revdesc . "4f179477f7d2") (:keywords "evil" "tools") (:authors ("James Nguyen" . "james@jojojames.com")) (:maintainers ("James Nguyen" . "james@jojojames.com")) (:maintainer "James Nguyen" . "james@jojojames.com"))]) (evil-commentary . [(20230610 1006) ((evil (1 0 0))) "Comment stuff out. A port of vim-commentary" tar ((:url . "https://github.com/linktohack/evil-commentary") (:commit . "c5945f28ce47644c828aac1f5f6ec335478d17fb") (:revdesc . "c5945f28ce47") (:keywords "evil" "comment" "commentary" "evil-commentary") (:authors ("Quang Linh LE" . "linktohack@gmail.com")) (:maintainers ("Quang Linh LE" . "linktohack@gmail.com")) (:maintainer "Quang Linh LE" . "linktohack@gmail.com"))]) (evil-dvorak . [(20160416 1841) ((evil (1 0 8))) "Evil keybindings for that work with dvorak mode" tar ((:url . "https://github.com/jbranso/evil-dvorak") (:commit . "e7b80077d6f332452049eb3d7ea51f6c8fbf5947") (:revdesc . "e7b80077d6f3") (:keywords "dvorak" "evil" "vim"))]) (evil-easymotion . [(20200424 135) ((emacs (24)) (avy (0 3 0)) (cl-lib (0 5))) "A port of vim's easymotion to emacs" tar ((:url . "https://github.com/PythonNut/evil-easymotion") (:commit . "f96c2ed38ddc07908db7c3c11bcd6285a3e8c2e9") (:revdesc . "f96c2ed38ddc") (:keywords "convenience" "evil") (:authors ("PythonNut" . "pythonnut@pythonnut.com")) (:maintainers ("PythonNut" . "pythonnut@pythonnut.com")) (:maintainer "PythonNut" . "pythonnut@pythonnut.com"))]) @@ -1882,7 +1883,7 @@ (flymake-biome . [(20241007 1626) ((emacs (27 1))) "A flymake plugin for Javascript files using biome" tar ((:url . "https://github.com/erickgnavar/flymake-biome") (:commit . "03fa55d23fdc80fb4bc963cd144da460e7da0220") (:revdesc . "03fa55d23fdc") (:authors ("Erick Navarro" . "erick@navarro.io")) (:maintainers ("Erick Navarro" . "erick@navarro.io")) (:maintainer "Erick Navarro" . "erick@navarro.io"))]) (flymake-clippy . [(20231102 1616) ((emacs (26 1))) "Flymake backend for Clippy" tar ((:url . "https://github.com/mgmarlow/flymake-clippy") (:commit . "62c670c19e575a0d7dd723cbd195c18de60bb494") (:revdesc . "62c670c19e57") (:keywords "tools") (:authors ("Graham Marlow" . "info@mgmarlow.com")) (:maintainers ("Graham Marlow" . "info@mgmarlow.com")) (:maintainer "Graham Marlow" . "info@mgmarlow.com"))]) (flymake-coffee . [(20170723 146) ((flymake-easy (0 1))) "A flymake handler for coffee script" tar ((:url . "https://github.com/purcell/flymake-coffee") (:commit . "dee295acf30820ed15fe0de17137d50bc27fc80c") (:revdesc . "dee295acf308") (:authors ("Steve Purcell" . "steve@sanityinc.com")) (:maintainers ("Steve Purcell" . "steve@sanityinc.com")) (:maintainer "Steve Purcell" . "steve@sanityinc.com"))]) - (flymake-collection . [(20240903 1828) ((emacs (28 1)) (let-alist (1 0)) (flymake (1 2 1))) "Collection of checkers for flymake, bringing flymake to the level of flycheck" tar ((:url . "https://github.com/mohkale/flymake-collection") (:commit . "ecc15c74630fa75e7792aa23cec79ea4afc28cc2") (:revdesc . "ecc15c74630f") (:keywords "language" "tools") (:authors ("Mohsin Kaleem" . "mohkale@kisara.moe")) (:maintainers ("Mohsin Kaleem" . "mohkale@kisara.moe")) (:maintainer "Mohsin Kaleem" . "mohkale@kisara.moe"))]) + (flymake-collection . [(20241117 1157) ((emacs (28 1)) (let-alist (1 0)) (flymake (1 2 1))) "Collection of checkers for flymake, bringing flymake to the level of flycheck" tar ((:url . "https://github.com/mohkale/flymake-collection") (:commit . "1b62fd9b5844b231cb48b4919064420d64a123ff") (:revdesc . "1b62fd9b5844") (:keywords "language" "tools") (:authors ("Mohsin Kaleem" . "mohkale@kisara.moe")) (:maintainers ("Mohsin Kaleem" . "mohkale@kisara.moe")) (:maintainer "Mohsin Kaleem" . "mohkale@kisara.moe"))]) (flymake-cspell . [(20240304 1349) ((emacs (26 1))) "A Flymake backend for CSpell" tar ((:url . "https://github.com/fritzgrabo/flymake-cspell") (:commit . "a573c07142cd0142c4cc1affd57f96b4d5c229b3") (:revdesc . "a573c07142cd") (:keywords "wp") (:authors ("Fritz Grabo" . "hello@fritzgrabo.com")) (:maintainers ("Fritz Grabo" . "hello@fritzgrabo.com")) (:maintainer "Fritz Grabo" . "hello@fritzgrabo.com"))]) (flymake-css . [(20170723 146) ((flymake-easy (0 1))) "Flymake support for css using csslint" tar ((:url . "https://github.com/purcell/flymake-css") (:commit . "de090163ba289910ceeb61b13368ce42d0f2dfd8") (:revdesc . "de090163ba28") (:authors ("Steve Purcell" . "steve@sanityinc.com")) (:maintainers ("Steve Purcell" . "steve@sanityinc.com")) (:maintainer "Steve Purcell" . "steve@sanityinc.com"))]) (flymake-cursor . [(20220506 1458) ((flymake (0 3))) "Show flymake messages in the minibuffer after delay" tar ((:url . "https://github.com/flymake/emacs-flymake-cursor") (:commit . "95806594cacddbbc0c3aa2351a6a7cf28e73a8bf") (:revdesc . "95806594cacd") (:keywords "languages" "mode" "flymake") (:authors ("Dino Chiesa" . "dpchiesa@hotmail.com") ("Sam Graham" . "libflymake-emacsBLAHBLAHillusori.co.uk")) (:maintainers ("Sam Graham" . "libflymake-emacsBLAHBLAHillusori.co.uk") ("Jen-Chieh Shen" . "jcs090218@gmail.com")) (:maintainer "Sam Graham" . "libflymake-emacsBLAHBLAHillusori.co.uk"))]) @@ -1971,7 +1972,7 @@ (foreign-regexp . [(20200325 50) nil "Search and replace by foreign regexp" tar ((:url . "https://github.com/k-talo/foreign-regexp.el") (:commit . "e2dd47f2160cadc194eb156e7c76c3c869e6706e") (:revdesc . "e2dd47f2160c") (:keywords "convenience" "emulations" "matching" "tools" "unix" "wp") (:authors ("K-talo Miyazaki" . "KeitarodotMiyazakiatgmaildotcom")) (:maintainers ("K-talo Miyazaki" . "KeitarodotMiyazakiatgmaildotcom")) (:maintainer "K-talo Miyazaki" . "KeitarodotMiyazakiatgmaildotcom"))]) (foreman-mode . [(20170725 1422) ((s (1 9 0)) (dash (2 10 0)) (dash-functional (1 2 0)) (f (0 17 2)) (emacs (24))) "View and manage Procfile-based applications" tar ((:url . "https://github.com/zweifisch/foreman-mode") (:commit . "22b3bb13134b617870ed1e888af739f4818be929") (:revdesc . "22b3bb13134b") (:keywords "foreman") (:authors ("ZHOU Feng" . "zf.pascal@gmail.com")) (:maintainers ("ZHOU Feng" . "zf.pascal@gmail.com")) (:maintainer "ZHOU Feng" . "zf.pascal@gmail.com"))]) (forest-blue-theme . [(20160627 842) ((emacs (24))) "Emacs theme with a dark background" tar ((:url . "https://github.com/olkinn/forest-blue-emacs") (:commit . "58096ce1a25615d2bae806c3775bae3e2775019d") (:revdesc . "58096ce1a256"))]) - (forge . [(20241111 2039) ((emacs (27 1)) (compat (30 0 0 0)) (closql (2 0 0)) (dash (2 19 1)) (emacsql (4 0 3)) (ghub (4 1 1)) (let-alist (1 0 6)) (magit (4 1 1)) (markdown-mode (2 6)) (seq (2 24)) (transient (0 7 6)) (yaml (0 5 5))) "Access Git forges from Magit" tar ((:url . "https://github.com/magit/forge") (:commit . "b0d4a8dabed8355ac966138456b81335511373a6") (:revdesc . "b0d4a8dabed8") (:keywords "git" "tools" "vc") (:authors ("Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev"))]) + (forge . [(20241114 1523) ((emacs (27 1)) (compat (30 0 0 0)) (closql (2 0 0)) (dash (2 19 1)) (emacsql (4 0 3)) (ghub (4 1 1)) (let-alist (1 0 6)) (magit (4 1 1)) (markdown-mode (2 6)) (seq (2 24)) (transient (0 7 6)) (yaml (0 5 5))) "Access Git forges from Magit" tar ((:url . "https://github.com/magit/forge") (:commit . "969b52372a9cdddf23804c999355c72644effeb2") (:revdesc . "969b52372a9c") (:keywords "git" "tools" "vc") (:authors ("Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.forge@jonas.bernoulli.dev"))]) (form-feed . [(20210508 1627) ((emacs (24 1))) "Display ^L glyphs as horizontal lines" tar ((:url . "https://depp.brause.cc/form-feed.git") (:commit . "ac1f0ef30a11979f5dfe12d8c05a666739e486ff") (:revdesc . "ac1f0ef30a11") (:keywords "faces") (:authors ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainers ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainer "Vasilij Schneidermann" . "mail@vasilij.de"))]) (form-feed-st . [(20231002 2211) ((emacs (25 1))) "Display ^L glyphs as full-width horizontal lines" tar ((:url . "https://github.com/leodag/form-feed-st") (:commit . "f91c8daf35b7588e0aa24c8716c8cfd8ff0067c8") (:revdesc . "f91c8daf35b7") (:keywords "faces"))]) (format-all . [(20241001 839) ((emacs (24 4)) (inheritenv (0 1)) (language-id (0 20))) "Auto-format C, C++, JS, Python, Ruby and 50 other languages" tar ((:url . "https://github.com/lassik/emacs-format-all-the-code") (:commit . "9ae47456dad2925e4d41f58bd2c864b87f82aa8b") (:revdesc . "9ae47456dad2") (:keywords "languages" "util") (:authors ("Lassi Kortela" . "lassi@lassi.io")) (:maintainers ("Lassi Kortela" . "lassi@lassi.io")) (:maintainer "Lassi Kortela" . "lassi@lassi.io"))]) @@ -2149,7 +2150,7 @@ (gnome-calendar . [(20161110 1256) nil "Integration with the GNOME Shell calendar" tar ((:url . "https://github.com/NicolasPetton/gnome-calendar.el") (:commit . "668591bec95c23934c5e1ef100cec4824e7cb25d") (:revdesc . "668591bec95c") (:keywords "gnome" "calendar") (:authors ("Nicolas Petton" . "nicolas@petton.fr")) (:maintainers ("Nicolas Petton" . "nicolas@petton.fr")) (:maintainer "Nicolas Petton" . "nicolas@petton.fr"))]) (gnome-screencast . [(20210125 2001) ((emacs (25))) "Use Gnome screen recording functionality using elisp" tar ((:url . "https://github.com/juergenhoetzel/emacs-gnome-screencast") (:commit . "1f4ef60fe9d452320dc02f89e289bac04ef2ad1c") (:revdesc . "1f4ef60fe9d4") (:keywords "tools" "multimedia") (:authors ("Jürgen Hötzel" . "juergen@hoetzel.info")) (:maintainers ("Jürgen Hötzel" . "juergen@hoetzel.info")) (:maintainer "Jürgen Hötzel" . "juergen@hoetzel.info"))]) (gnomenm . [(20150316 1918) ((s (1 9 0)) (dash (2 3 0)) (kv (0 0 19))) "Emacs interface to Gnome nmcli command" tar ((:url . "https://github.com/nicferrier/emacs-nm") (:commit . "9065cda44ffc9e06239b8189a0154d31314c3b4d") (:revdesc . "9065cda44ffc") (:keywords "processes" "hardware") (:authors ("Nic Ferrier" . "nferrier@ferrier.me.uk")) (:maintainers ("Nic Ferrier" . "nferrier@ferrier.me.uk")) (:maintainer "Nic Ferrier" . "nferrier@ferrier.me.uk"))]) - (gnosis . [(20241108 632) ((emacs (27 2)) (emacsql (4 0 1)) (compat (29 1 4 2)) (transient (0 7 2))) "Spaced Repetition System" tar ((:url . "https://git.thanosapollo.org/gnosis") (:commit . "b30a06fc16c18b6de7d5a21facf2b5fd8d90b613") (:revdesc . "b30a06fc16c1") (:keywords "extensions") (:authors ("Thanos Apollo" . "public@thanosapollo.org")) (:maintainers ("Thanos Apollo" . "public@thanosapollo.org")) (:maintainer "Thanos Apollo" . "public@thanosapollo.org"))]) + (gnosis . [(20241115 1041) ((emacs (27 2)) (emacsql (4 0 1)) (compat (29 1 4 2)) (transient (0 7 2))) "Spaced Repetition System" tar ((:url . "https://git.thanosapollo.org/gnosis") (:commit . "eefd0abb3cb7ca8a09c249686ff67555724624da") (:revdesc . "eefd0abb3cb7") (:keywords "extensions") (:authors ("Thanos Apollo" . "public@thanosapollo.org")) (:maintainers ("Thanos Apollo" . "public@thanosapollo.org")) (:maintainer "Thanos Apollo" . "public@thanosapollo.org"))]) (gntp . [(20141025 250) nil "Growl Notification Protocol for Emacs" tar ((:url . "https://github.com/tekai/gntp.el") (:commit . "767571135e2c0985944017dc59b0be79af222ef5") (:revdesc . "767571135e2c") (:authors ("Engelke Eschner" . "tekai@gmx.li")) (:maintainers ("Engelke Eschner" . "tekai@gmx.li")) (:maintainer "Engelke Eschner" . "tekai@gmx.li"))]) (gnu-apl-mode . [(20220404 341) ((emacs (27))) "Integrate GNU APL with Emacs" tar ((:url . "https://github.com/lokedhs/gnu-apl-mode") (:commit . "c8695b0d55b5167263a843252ffd21a589018427") (:revdesc . "c8695b0d55b5") (:keywords "languages") (:authors ("Elias Mårtenson" . "lokedhs@gmail.com")) (:maintainers ("Elias Mårtenson" . "lokedhs@gmail.com")) (:maintainer "Elias Mårtenson" . "lokedhs@gmail.com"))]) (gnu-indent . [(20221127 2112) ((emacs (25 1))) "Indent your code with GNU Indent" tar ((:url . "https://codeberg.org/akib/emacs-gnu-indent") (:commit . "f31dbe60478b6270bb57b6b05998df8eec56f801") (:revdesc . "f31dbe60478b") (:keywords "tools" "c") (:authors ("Akib Azmain Turja" . "akib@disroot.org")) (:maintainers ("Akib Azmain Turja" . "akib@disroot.org")) (:maintainer "Akib Azmain Turja" . "akib@disroot.org"))]) @@ -2226,7 +2227,7 @@ (gpt . [(20241020 1841) ((emacs (24 4))) "Run instruction-following language models" tar ((:url . "https://github.com/stuhlmueller/gpt.el") (:commit . "3f3d0c4c1f2d5460ed3296a63c7938c5040aaa8e") (:revdesc . "3f3d0c4c1f2d") (:keywords "openai" "anthropic" "claude" "language" "copilot" "convenience" "tools") (:authors ("Andreas Stuhlmueller" . "andreas@ought.org")) (:maintainers ("Andreas Stuhlmueller" . "andreas@ought.org")) (:maintainer "Andreas Stuhlmueller" . "andreas@ought.org"))]) (gpt-commit . [(20230716 331) ((emacs (27 1)) (magit (2 90)) (request (0 3 2))) "Commit messages with GPT in Emacs" tar ((:url . "https://github.com/ywkim/gpt-commit") (:commit . "8a8883be2051eed499c5bc3035a75ff56d64d5ff") (:revdesc . "8a8883be2051") (:authors ("Youngwook Kim" . "youngwook.kim@gmail.com")) (:maintainers ("Youngwook Kim" . "youngwook.kim@gmail.com")) (:maintainer "Youngwook Kim" . "youngwook.kim@gmail.com"))]) (gptai . [(20230530 1853) ((emacs (24 1))) "Integrate with the OpenAI API" tar ((:url . "https://github.com/antonhibl/gptai") (:commit . "e7b8b91b425986868e8bc0edcac384ba47d4d4b7") (:revdesc . "e7b8b91b4259") (:keywords "comm" "convenience") (:authors ("Anton Hibl" . "antonhibl11@gmail.com")) (:maintainers ("Anton Hibl" . "antonhibl11@gmail.com")) (:maintainer "Anton Hibl" . "antonhibl11@gmail.com"))]) - (gptel . [(20241112 624) ((emacs (27 1)) (transient (0 4 0)) (compat (29 1 4 1))) "Interact with ChatGPT or other LLMs" tar ((:url . "https://github.com/karthink/gptel") (:commit . "4aa6b7ca79b1548c36e593d0d68d2dfa644fa958") (:revdesc . "4aa6b7ca79b1") (:keywords "convenience") (:authors ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainers ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainer "Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))]) + (gptel . [(20241115 456) ((emacs (27 1)) (transient (0 4 0)) (compat (29 1 4 1))) "Interact with ChatGPT or other LLMs" tar ((:url . "https://github.com/karthink/gptel") (:commit . "51ae43f4edefe0375acbcb836d94d8d0348a531d") (:revdesc . "51ae43f4edef") (:keywords "convenience") (:authors ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainers ("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) (:maintainer "Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))]) (gpx . [(20240609 2200) ((emacs (27 1))) "Major mode for GPX files" tar ((:url . "https://github.com/mkcms/gpx-mode") (:commit . "88aa5fed1b0987d90f442eb002ab0f2e4731e223") (:revdesc . "88aa5fed1b09") (:keywords "data" "tools") (:authors ("Michał Krzywkowski" . "k.michal@zoho.com")) (:maintainers ("Michał Krzywkowski" . "k.michal@zoho.com")) (:maintainer "Michał Krzywkowski" . "k.michal@zoho.com"))]) (grab-mac-link . [(20210511 1303) ((emacs (24))) "Grab link from Mac Apps and insert it into Emacs" tar ((:url . "https://github.com/xuchunyang/grab-mac-link.el") (:commit . "5fdb03bf57bc4a530374b896e0f8b5139dc794e3") (:revdesc . "5fdb03bf57bc") (:keywords "mac" "hyperlink"))]) (grab-x-link . [(20191113 848) ((emacs (24)) (cl-lib (0 5))) "Grab links from X11 apps and insert into Emacs" tar ((:url . "https://github.com/xuchunyang/grab-x-link") (:commit . "d898db46e4864118359fdedfe915e180de3fe290") (:revdesc . "d898db46e486") (:keywords "hyperlink") (:authors ("Xu Chunyang" . "mail@xuchunyang.me")) (:maintainers ("Xu Chunyang" . "mail@xuchunyang.me")) (:maintainer "Xu Chunyang" . "mail@xuchunyang.me"))]) @@ -2574,7 +2575,7 @@ (hookify . [(20141216 2209) ((s (1 9 0)) (dash (1 5 0))) "Interactive commands to create temporary hooks" tar ((:url . "https://github.com/Silex/hookify") (:commit . "e76127230716f7fab6662410c03c3872d17a172b") (:revdesc . "e76127230716") (:keywords "hook" "convenience") (:authors ("Philippe Vaucher" . "philippe.vaucher@gmail.com")) (:maintainers ("Philippe Vaucher" . "philippe.vaucher@gmail.com")) (:maintainer "Philippe Vaucher" . "philippe.vaucher@gmail.com"))]) (horizon-theme . [(20200720 1832) ((emacs (24 3))) "A beautifully warm dual theme" tar ((:url . "https://github.com/aodhneine/horizon-theme.el") (:commit . "9595549c514a9376c61d5d303405f6a6982e9e46") (:revdesc . "9595549c514a"))]) (horoscope . [(20180409 641) ((emacs (24))) "Generate horoscopes" tar ((:url . "https://github.com/mschuldt/horoscope.el") (:commit . "f4c683e991adce0a8f9023f15050f306f9b9a9ed") (:revdesc . "f4c683e991ad") (:keywords "extensions" "games") (:authors ("Bob Manson" . "manson@cygnus.com")) (:maintainers ("Noah Friedman" . "friedman@prep.ai.mit.edu")) (:maintainer "Noah Friedman" . "friedman@prep.ai.mit.edu"))]) - (hotfuzz . [(20241022 1616) ((emacs (27 1))) "Fuzzy completion style" tar ((:url . "https://github.com/axelf4/hotfuzz") (:commit . "2a9d24c6615a166b1191204aad1d3ca55a43ae9b") (:revdesc . "2a9d24c6615a") (:keywords "matching") (:authors ("Axel Forsman" . "axel@axelf.se")) (:maintainers ("Axel Forsman" . "axel@axelf.se")) (:maintainer "Axel Forsman" . "axel@axelf.se"))]) + (hotfuzz . [(20241116 1645) ((emacs (27 1))) "Fuzzy completion style" tar ((:url . "https://github.com/axelf4/hotfuzz") (:commit . "6899be957694a273eb71c21c3eae649d877c9e0b") (:revdesc . "6899be957694") (:keywords "matching") (:authors ("Axel Forsman" . "axel@axelf.se")) (:maintainers ("Axel Forsman" . "axel@axelf.se")) (:maintainer "Axel Forsman" . "axel@axelf.se"))]) (hound . [(20200122 1700) ((request (0 2 0)) (cl-lib (0 5))) "Display hound search results in a compilation window" tar ((:url . "https://github.com/ryoung786/hound.el") (:commit . "35e2cdc81fcc904b450a7ef3ec00fd25df6a4431") (:revdesc . "35e2cdc81fcc"))]) (hover . [(20220129 1935) ((emacs (25 2)) (dash (2 14 1))) "Package to use hover with flutter" tar ((:url . "https://github.com/ericdallo/hover.el") (:commit . "2b826735bb8d3bcfced489a1e0fa21b10fbc967e") (:revdesc . "2b826735bb8d") (:keywords "hover" "flutter" "mobile" "tools"))]) (howdoi . [(20150204 43) nil "Instant coding answers via Emacs" tar ((:url . "https://github.com/atykhonov/emacs-howdoi") (:commit . "5fbf7069ee160c597a328e5ce5fb32920e1ca88f") (:revdesc . "5fbf7069ee16") (:keywords "howdoi" "convenience") (:authors ("Andrey Tykhonov" . "atykhonovatgmail.com")) (:maintainers ("Andrey Tykhonov" . "atykhonov@gmail.com")) (:maintainer "Andrey Tykhonov" . "atykhonov@gmail.com"))]) @@ -2606,7 +2607,7 @@ (hydandata-light-theme . [(20190809 1925) nil "A light color theme that is easy on your eyes" tar ((:url . "https://github.com/chkhd/hydandata-light-theme") (:commit . "812ffa4bee3163098ef66ee4506feed45018be4e") (:revdesc . "812ffa4bee31") (:keywords "color-theme" "theme") (:authors ("David Chkhikvadze" . "david@chkhd.net")) (:maintainers ("David Chkhikvadze" . "david@chkhd.net")) (:maintainer "David Chkhikvadze" . "david@chkhd.net"))]) (hyde . [(20160508 308) nil "Major mode to help create and manage Jekyll blogs" tar ((:url . "https://github.com/nibrahim/Hyde") (:commit . "a8cd6ed00ecd8d7de0ded2f4867015b412b15b76") (:revdesc . "a8cd6ed00ecd"))]) (hydra . [(20220910 1206) ((cl-lib (0 5)) (lv (0))) "Make bindings that stick around" tar ((:url . "https://github.com/abo-abo/hydra") (:commit . "317e1de33086637579a7aeb60f77ed0405bf359b") (:revdesc . "317e1de33086") (:keywords "bindings") (:authors ("Oleh Krehel" . "ohwoeowho@gmail.com")) (:maintainers ("Oleh Krehel" . "ohwoeowho@gmail.com")) (:maintainer "Oleh Krehel" . "ohwoeowho@gmail.com"))]) - (hyperbole . [(20241112 1433) ((emacs (27 2))) "GNU Hyperbole: The Everyday Hypertextual Information Manager" tar ((:url . "https://git.savannah.gnu.org/git/hyperbole.git") (:commit . "dea72c9f4511e926726bedc3a84b895972af8270") (:revdesc . "dea72c9f4511") (:keywords "comm" "convenience" "files" "frames" "hypermedia" "languages" "mail" "matching" "mouse" "multimedia" "outlines" "tools" "wp") (:authors ("Robert Weiner" . "rsw@gnu.org")) (:maintainers ("Robert Weiner" . "rsw@gnu.org")) (:maintainer "Robert Weiner" . "rsw@gnu.org"))]) + (hyperbole . [(20241116 2220) ((emacs (27 2))) "GNU Hyperbole: The Everyday Hypertextual Information Manager" tar ((:url . "https://git.savannah.gnu.org/git/hyperbole.git") (:commit . "e6f401027c9a507c96529b77d20e6a280ec7d40e") (:revdesc . "e6f401027c9a") (:keywords "comm" "convenience" "files" "frames" "hypermedia" "languages" "mail" "matching" "mouse" "multimedia" "outlines" "tools" "wp") (:authors ("Robert Weiner" . "rsw@gnu.org")) (:maintainers ("Robert Weiner" . "rsw@gnu.org")) (:maintainer "Robert Weiner" . "rsw@gnu.org"))]) (hyperdrive . [(20241101 2353) ((emacs (28 1)) (map (3 0)) (compat (30 0 0 0)) (org (9 7 6)) (plz (0 9 1)) (persist (0 6 1)) (taxy-magit-section (0 14)) (transient (0 7 7))) "P2P filesystem" tar ((:url . "https://git.sr.ht/~ushin/hyperdrive.el") (:commit . "581752cad8bcd701c863b08a779e4ca982325cae") (:revdesc . "581752cad8bc") (:authors ("Joseph Turner" . "joseph@ushin.org")) (:maintainers ("Joseph Turner" . "~ushin/ushin@lists.sr.ht")) (:maintainer "Joseph Turner" . "~ushin/ushin@lists.sr.ht"))]) (hyperdrive-org-transclusion . [(20241028 427) ((emacs (28 1)) (hyperdrive (0 4 2)) (org-transclusion (1 4 0))) "Tranclude hyperdrive content" tar ((:url . "https://git.sr.ht/~ushin/hyperdrive-org-transclusion") (:commit . "252e2df3fe7a07a122a365a637c47a43b26e179c") (:revdesc . "252e2df3fe7a") (:authors ("Joseph Turner" . "joseph@ushin.org")) (:maintainers ("Joseph Turner" . "~ushin/ushin@lists.sr.ht")) (:maintainer "Joseph Turner" . "~ushin/ushin@lists.sr.ht"))]) (hyperkitty . [(20220226 1951) ((request (0 3 2)) (emacs (25 1))) "Emacs interface for Hyperkitty archives" tar ((:url . "https://github.com/maxking/hyperkitty.el") (:commit . "2c1d22ff017d096c359aa151e6a29f7214a58118") (:revdesc . "2c1d22ff017d") (:keywords "mail" "hyperkitty" "mailman") (:authors ("Abhilash Raj" . "maxking@asynchronous.in")) (:maintainers ("Abhilash Raj" . "maxking@asynchronous.in")) (:maintainer "Abhilash Raj" . "maxking@asynchronous.in"))]) @@ -2712,7 +2713,7 @@ (inform7 . [(20200430 1539) ((emacs (24 3)) (s (1 12 0))) "Major mode for working with Inform 7 files" tar ((:url . "https://github.com/GuiltyDolphin/inform7-mode") (:commit . "a409bbc6f04264f7f00616a995fa6ecf59d33d0d") (:revdesc . "a409bbc6f042") (:keywords "languages") (:authors ("Ben Moon" . "software@guiltydolphin.com")) (:maintainers ("Ben Moon" . "software@guiltydolphin.com")) (:maintainer "Ben Moon" . "software@guiltydolphin.com"))]) (inherit-local . [(20170409 1649) ((emacs (24 3))) "Inherited buffer-local variables" tar ((:url . "https://github.com/shlevy/inherit-local") (:commit . "b1f4ff9c41f9d64e4adaf5adcc280b82f084cdc7") (:revdesc . "b1f4ff9c41f9"))]) (inheritenv . [(20230804 651) ((emacs (24 4))) "Make temp buffers inherit buffer-local environment variables" tar ((:url . "https://github.com/purcell/inheritenv") (:commit . "00106bb208d06e5f1ec25d0c2f41c000cbb25076") (:revdesc . "00106bb208d0") (:keywords "unix") (:authors ("Steve Purcell" . "steve@sanityinc.com")) (:maintainers ("Steve Purcell" . "steve@sanityinc.com")) (:maintainer "Steve Purcell" . "steve@sanityinc.com"))]) - (inhibit-mouse . [(20241113 1936) ((emacs (24 1))) "Deactivate mouse input during editing" tar ((:url . "https://github.com/jamescherti/inhibit-mouse.el") (:commit . "ac22005ea6d057fefaaf0bc51bb1fd0720c730fe") (:revdesc . "ac22005ea6d0") (:keywords "convenience"))]) + (inhibit-mouse . [(20241114 1902) ((emacs (24 1))) "Deactivate mouse input during editing" tar ((:url . "https://github.com/jamescherti/inhibit-mouse.el") (:commit . "ce8180dd631d4aadd8b3c434ecbb77c2f5e31012") (:revdesc . "ce8180dd631d") (:keywords "convenience"))]) (ini . [(20220827 2009) ((emacs (24 4))) "Converting between INI files and association lists" tar ((:url . "https://github.com/EsaLaine/ini.el") (:commit . "d50fe629497d51c6390a56bbded1ad77ce12e5af") (:revdesc . "d50fe629497d"))]) (ini-mode . [(20230211 1512) ((emacs (24 1))) "Major mode for Windows-style ini files" tar ((:url . "https://github.com/Lindydancer/ini-mode") (:commit . "5472abc94e564edc6b469c48d2324519a044a77c") (:revdesc . "5472abc94e56") (:keywords "languages" "faces"))]) (init-dir . [(20240924 150) ((emacs (27 1)) (benchmark-init (1 2))) "Init directory instead of just a single file" tar ((:url . "https://github.com/chaosemer/init-dir") (:commit . "406953deb5f29112ca02850885954f82abb1d334") (:revdesc . "406953deb5f2") (:keywords "extensions" "internal") (:authors ("Jared Finder" . "jared@finder.org")) (:maintainers ("Jared Finder" . "jared@finder.org")) (:maintainer "Jared Finder" . "jared@finder.org"))]) @@ -2910,7 +2911,7 @@ (jupyter . [(20241004 241) ((emacs (26)) (cl-lib (0 5)) (org (9 1 6)) (zmq (0 10 10)) (simple-httpd (1 5 0)) (websocket (1 9))) "Jupyter" tar ((:url . "https://github.com/emacs-jupyter/jupyter") (:commit . "674af0481a94f2ce56c62aa7668a966254ef26ef") (:revdesc . "674af0481a94") (:authors ("Nathaniel Nicandro" . "nathanielnicandro@gmail.com")) (:maintainers ("Nathaniel Nicandro" . "nathanielnicandro@gmail.com")) (:maintainer "Nathaniel Nicandro" . "nathanielnicandro@gmail.com"))]) (just-mode . [(20240424 1809) ((emacs (26 1))) "Justfile editing mode" tar ((:url . "https://github.com/leon-barrett/just-mode.el") (:commit . "4c0df4cc4b8798f1a7e99fb78b79c4bf7eec12c1") (:revdesc . "4c0df4cc4b87") (:keywords "files" "languages" "tools") (:authors ("Leon Barrett" . "(leon@barrettnexus.com)")) (:maintainers ("Leon Barrett" . "(leon@barrettnexus.com)")) (:maintainer "Leon Barrett" . "(leon@barrettnexus.com)"))]) (just-ts-mode . [(20241014 2252) ((emacs (29 1))) "Justfile editing mode" tar ((:url . "https://github.com/leon-barrett/just-ts-mode.el") (:commit . "acb598f1edabae9f679a507c8e22c21b3f2da132") (:revdesc . "acb598f1edab") (:keywords "files" "languages" "tools" "treesitter") (:authors ("Leon Barrett" . "(leon@barrettnexus.com)")) (:maintainers ("Leon Barrett" . "(leon@barrettnexus.com)")) (:maintainer "Leon Barrett" . "(leon@barrettnexus.com)"))]) - (justl . [(20240925 455) ((transient (0 1 0)) (emacs (27 1)) (s (1 2 0)) (f (0 20 0)) (inheritenv (0 2))) "Major mode for driving just files" tar ((:url . "https://github.com/psibi/justl.el") (:commit . "a46b95425c8f55d5ebfa674f09d606a6321e51e9") (:revdesc . "a46b95425c8f") (:keywords "just" "justfile" "tools" "processes"))]) + (justl . [(20241116 530) ((transient (0 1 0)) (emacs (27 1)) (s (1 2 0)) (f (0 20 0)) (inheritenv (0 2))) "Major mode for driving just files" tar ((:url . "https://github.com/psibi/justl.el") (:commit . "82925541b4a36e0e9f95eee0f4a0ea348c750990") (:revdesc . "82925541b4a3") (:keywords "just" "justfile" "tools" "processes"))]) (jvm-mode . [(20150422 708) ((dash (2 6 0)) (emacs (24))) "Monitor and manage your JVMs" tar ((:url . "https://github.com/martintrojer/jvm-mode.el") (:commit . "3355dbaf5b0185aadfbad24160399abb32c5bea0") (:revdesc . "3355dbaf5b01") (:keywords "convenience") (:authors ("Martin Trojer" . "martin.trojer@gmail.com")) (:maintainers ("Martin Trojer" . "martin.trojer@gmail.com")) (:maintainer "Martin Trojer" . "martin.trojer@gmail.com"))]) (jwt . [(20241031 2258) ((emacs (29 1))) "Interact with JSON Web Tokens" tar ((:url . "https://github.com/joshbax189/jwt-el") (:commit . "d7deb62f8c2df58d5cfebf087a147c75207964e8") (:revdesc . "d7deb62f8c2d") (:keywords "tools" "convenience"))]) (k8s-mode . [(20230305 1039) ((emacs (24 3)) (yaml-mode (0 0 10))) "Major mode for Kubernetes configuration file" tar ((:url . "https://github.com/TxGVNN/emacs-k8s-mode") (:commit . "83266cecd6a39cdf57d124270646047860bfb7ab") (:revdesc . "83266cecd6a3") (:authors ("Giap Tran" . "txgvnn@gmail.com")) (:maintainers ("Giap Tran" . "txgvnn@gmail.com")) (:maintainer "Giap Tran" . "txgvnn@gmail.com"))]) @@ -3050,9 +3051,9 @@ (leanote . [(20161223 139) ((emacs (24 4)) (cl-lib (0 5)) (request (0 2)) (let-alist (1 0 3)) (pcache (0 4 0)) (s (1 10 0)) (async (1 9))) "A minor mode writing markdown leanote" tar ((:url . "https://github.com/aborn/leanote-emacs") (:commit . "d499e7b59bb1f1a2fabc0e4c26fb101ed62ebc7b") (:revdesc . "d499e7b59bb1") (:keywords "leanote" "note" "markdown") (:authors ("Aborn Jiang" . "aborn.jiang@gmail.com")) (:maintainers ("Aborn Jiang" . "aborn.jiang@gmail.com")) (:maintainer "Aborn Jiang" . "aborn.jiang@gmail.com"))]) (learn-ocaml . [(20211003 1412) ((emacs (25 1))) "Emacs frontend for learn-ocaml" tar ((:url . "https://github.com/pfitaxel/learn-ocaml.el") (:commit . "abdc263537a6a534152a4eaaa17b2c3e4e10418b") (:revdesc . "abdc263537a6"))]) (ledger-import . [(20230904 1837) ((emacs (25 1))) "Fetch OFX files from bank and push them to Ledger" tar ((:url . "https://github.com/DamienCassou/ledger-import") (:commit . "e47e8508794462986b982d6ce3d05bcd17c19242") (:revdesc . "e47e85087944") (:authors ("Damien Cassou" . "damien@cassou.me")) (:maintainers ("Damien Cassou" . "damien@cassou.me")) (:maintainer "Damien Cassou" . "damien@cassou.me"))]) - (ledger-mode . [(20241007 1655) ((emacs (25 1))) "Helper code for use with the \"ledger\" command-line tool" tar ((:url . "https://github.com/ledger/ledger-mode") (:commit . "9be25db0566d495299eaa8595eb4b6dd6b7a1080") (:revdesc . "9be25db0566d"))]) + (ledger-mode . [(20241114 1751) ((emacs (25 1))) "Helper code for use with the \"ledger\" command-line tool" tar ((:url . "https://github.com/ledger/ledger-mode") (:commit . "15b7d29f2539f9e9671ab3c062bd5165e5b80ae8") (:revdesc . "15b7d29f2539"))]) (leerzeichen . [(20220626 835) nil "Minor mode to display whitespace characters" tar ((:url . "https://github.com/fgeller/leerzeichen.el") (:commit . "9d4126d5f6563569080845a69b0867119a9fd6ea") (:revdesc . "9d4126d5f656") (:keywords "whitespace" "characters") (:authors ("Felix Geller" . "fgeller@gmail.com")) (:maintainers ("Felix Geller" . "fgeller@gmail.com")) (:maintainer "Felix Geller" . "fgeller@gmail.com"))]) - (leetcode . [(20240807 1731) ((emacs (26 1)) (s (1 13 0)) (dash (2 16 0)) (aio (1 0)) (log4e (0 3 3))) "An leetcode client" tar ((:url . "https://github.com/kaiwk/leetcode.el") (:commit . "064a03d3407d67391fd8c0f6494d0e0f0d867edc") (:revdesc . "064a03d3407d") (:keywords "extensions" "tools") (:authors ("Wang Kai" . "kaiwkx@gmail.com")) (:maintainers ("Wang Kai" . "kaiwkx@gmail.com")) (:maintainer "Wang Kai" . "kaiwkx@gmail.com"))]) + (leetcode . [(20241115 527) ((emacs (26 1)) (s (1 13 0)) (aio (1 0)) (log4e (0 3 3))) "An leetcode client" tar ((:url . "https://github.com/kaiwk/leetcode.el") (:commit . "bf259182a18a44c49ccc5449d1353ec4009a9480") (:revdesc . "bf259182a18a") (:keywords "extensions" "tools") (:authors ("Wang Kai" . "kaiwkx@gmail.com")) (:maintainers ("Wang Kai" . "kaiwkx@gmail.com")) (:maintainer "Wang Kai" . "kaiwkx@gmail.com"))]) (legalese . [(20200119 2248) nil "Add legalese to your program files" tar ((:url . "https://github.com/jorgenschaefer/legalese") (:commit . "e465471d2d5a62d35073d93e0f8d40387a82e302") (:revdesc . "e465471d2d5a") (:keywords "convenience") (:authors ("Jorgen Schaefer" . "forcer@forcix.cx")) (:maintainers ("Jorgen Schaefer" . "forcer@forcix.cx")) (:maintainer "Jorgen Schaefer" . "forcer@forcix.cx"))]) (lem . [(20241102 1553) ((emacs (29 1)) (fedi (0 2)) (markdown-mode (2 5))) "A lemmy client" tar ((:url . "https://codeberg.org/martianh/lem.el") (:commit . "79c4b8112be95df0193e7dff99a097ec818b04cb") (:revdesc . "79c4b8112be9") (:keywords "multimedia" "comm" "web" "fediverse") (:authors ("martian hiatus" . "mousebot@disroot.org")) (:maintainers ("martian hiatus" . "mousebot@disroot.org")) (:maintainer "martian hiatus" . "mousebot@disroot.org"))]) (lemon-mode . [(20130216 1304) nil "A major mode for editing lemon grammar files" tar ((:url . "https://github.com/mooz/lemon-mode") (:commit . "155bfced6c9afc8072a0133d3d1baa54c6d67430") (:revdesc . "155bfced6c9a") (:keywords "lemon") (:authors ("mooz" . "stillpedant@gmail.com")) (:maintainers ("mooz" . "stillpedant@gmail.com")) (:maintainer "mooz" . "stillpedant@gmail.com"))]) @@ -3163,7 +3164,7 @@ (lox-ts-mode . [(20240820 345) ((emacs (29 1))) "Major mode for Lox using tree-sitter" tar ((:url . "https://github.com/nverno/lox-ts-mode") (:commit . "3a482f6a96318d617d35683089d5edb405cd0752") (:revdesc . "3a482f6a9631") (:keywords "lox" "tree-sitter" "languages") (:authors ("Noah Peart" . "noah.v.peart@gmail.com")) (:maintainers ("Noah Peart" . "noah.v.peart@gmail.com")) (:maintainer "Noah Peart" . "noah.v.peart@gmail.com"))]) (lpy . [(20231026 1525) ((emacs (25 1)) (lispy (0 27 0))) "A lispy interface to Python" tar ((:url . "https://github.com/abo-abo/lpy") (:commit . "2c086ec162d4456b99a6095c3c335382a8304734") (:revdesc . "2c086ec162d4") (:keywords "python" "lisp") (:authors ("Oleh Krehel" . "ohwoeowho@gmail.com")) (:maintainers ("Oleh Krehel" . "ohwoeowho@gmail.com")) (:maintainer "Oleh Krehel" . "ohwoeowho@gmail.com"))]) (lsp-cfn . [(20240112 921) ((emacs (27 0)) (lsp-mode (8 0 0)) (yaml-mode (0 0 15))) "LSP integration for cfn-lsp-extra" tar ((:url . "https://github.com/LaurenceWarne/lsp-cfn.el") (:commit . "2297533003118ebd9db0116b4d3486a987e98ca9") (:revdesc . "229753300311"))]) - (lsp-dart . [(20240520 1834) ((emacs (27 1)) (lsp-treemacs (0 3)) (lsp-mode (7 0 1)) (dap-mode (0 6)) (f (0 20 0)) (dash (2 14 1)) (dart-mode (1 0 5)) (jsonrpc (1 0 15)) (ht (2 2))) "Dart support lsp-mode" tar ((:url . "https://github.com/emacs-lsp/lsp-dart") (:commit . "1f52e81c9371055ff9188117ace81f009d1c79f2") (:revdesc . "1f52e81c9371") (:keywords "languages" "extensions"))]) + (lsp-dart . [(20241114 2005) ((emacs (27 1)) (lsp-treemacs (0 3)) (lsp-mode (7 0 1)) (dap-mode (0 6)) (f (0 20 0)) (dash (2 14 1)) (dart-mode (1 0 5)) (jsonrpc (1 0 15)) (ht (2 2))) "Dart support lsp-mode" tar ((:url . "https://github.com/emacs-lsp/lsp-dart") (:commit . "7e3d3429418bc42cda7fa7b58e6644a705cf2f89") (:revdesc . "7e3d3429418b") (:keywords "languages" "extensions"))]) (lsp-docker . [(20240419 1428) ((emacs (27 1)) (dash (2 14 1)) (lsp-mode (6 2 1)) (f (0 20 0)) (s (1 13 0)) (yaml (0 2 0)) (ht (2 0))) "LSP Docker integration" tar ((:url . "https://github.com/emacs-lsp/lsp-docker") (:commit . "16a0cfbe06813a1191b19e412445f9d34cd7493f") (:revdesc . "16a0cfbe0681") (:keywords "languages" "langserver") (:authors ("Ivan Yonchovski" . "yyoncho@gmail.com")) (:maintainers ("Ivan Yonchovski" . "yyoncho@gmail.com")) (:maintainer "Ivan Yonchovski" . "yyoncho@gmail.com"))]) (lsp-focus . [(20200906 1917) ((emacs (26 1)) (focus (0 1 1)) (lsp-mode (6 1))) "Focus.el support for lsp-mode" tar ((:url . "https://github.com/emacs-lsp/lsp-focus") (:commit . "d01f0af156e4e78dcb9fa8e080a652cf8f221d30") (:revdesc . "d01f0af156e4") (:keywords "languages" "lsp-mode"))]) (lsp-grammarly . [(20240229 115) ((emacs (27 1)) (lsp-mode (6 1)) (grammarly (0 3 0)) (request (0 3 0)) (s (1 12 0)) (ht (2 3))) "LSP Clients for Grammarly" tar ((:url . "https://github.com/emacs-grammarly/lsp-grammarly") (:commit . "39deb23b282785eaffc6ae17838c92c613a49315") (:revdesc . "39deb23b2827") (:keywords "convenience" "lsp" "grammarly" "checker") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) @@ -3217,7 +3218,7 @@ (magic-filetype . [(20240130 1805) ((emacs (24 3)) (s (1 9 0))) "Enhance filetype major mode" tar ((:url . "https://github.com/emacs-php/magic-filetype.el") (:commit . "3979ddbd8066d7390e31bde2b35f997c5f5f4516") (:revdesc . "3979ddbd8066") (:keywords "emulations" "vim" "ft" "file" "magic-mode") (:authors ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainers ("USAMI Kenta" . "tadsan@zonu.me")) (:maintainer "USAMI Kenta" . "tadsan@zonu.me"))]) (magic-latex-buffer . [(20210306 422) ((cl-lib (0 5)) (emacs (25 1))) "Magically enhance LaTeX-mode font-locking for semi-WYSIWYG editing" tar ((:url . "https://github.com/zk-phi/magic-latex-buffer") (:commit . "903ec91872760e47c0e5715795f8465173615098") (:revdesc . "903ec9187276"))]) (magik-mode . [(20241111 1446) ((emacs (24 4)) (compat (28 1))) "Emacs major mode for Smallworld Magik files" tar ((:url . "https://github.com/roadrunner1776/magik") (:commit . "441389f75bdf6990556b96597979bf4a0b9cbdec") (:revdesc . "441389f75bdf") (:keywords "languages"))]) - (magit . [(20241106 1441) ((emacs (26 1)) (compat (30 0 0 0)) (dash (2 19 1)) (magit-section (4 1 2)) (seq (2 24)) (transient (0 7 8)) (with-editor (3 4 2))) "A Git porcelain inside Emacs" tar ((:url . "https://github.com/magit/magit") (:commit . "1c30bb1f9fb0668ec385fc3fb899b30d5507fad8") (:revdesc . "1c30bb1f9fb0") (:keywords "git" "tools" "vc") (:authors ("Marius Vollmer" . "marius.vollmer@gmail.com") ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") ("Kyle Meyer" . "kyle@kyleam.com")) (:maintainer "Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev"))]) + (magit . [(20241116 1557) ((emacs (26 1)) (compat (30 0 0 0)) (dash (2 19 1)) (magit-section (4 1 2)) (seq (2 24)) (transient (0 7 8)) (with-editor (3 4 2))) "A Git porcelain inside Emacs" tar ((:url . "https://github.com/magit/magit") (:commit . "8cee789f7a61a491d23a78360cbd2d626eda0f06") (:revdesc . "8cee789f7a61") (:keywords "git" "tools" "vc") (:authors ("Marius Vollmer" . "marius.vollmer@gmail.com") ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") ("Kyle Meyer" . "kyle@kyleam.com")) (:maintainer "Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev"))]) (magit-annex . [(20240811 1850) ((emacs (26 1)) (magit (4 0 0))) "Control git-annex from Magit" tar ((:url . "https://github.com/magit/magit-annex") (:commit . "9db0bc61461f222106c7ae3d8cd6d3de1f1b143f") (:revdesc . "9db0bc61461f") (:keywords "vc" "tools") (:authors ("Kyle Meyer" . "kyle@kyleam.com") ("Rémi Vanicat" . "vanicat@debian.org")) (:maintainers ("Kyle Meyer" . "kyle@kyleam.com") ("Rémi Vanicat" . "vanicat@debian.org")) (:maintainer "Kyle Meyer" . "kyle@kyleam.com"))]) (magit-commit-mark . [(20241110 245) ((emacs (29 1)) (magit (3 3 0))) "Support marking commits as read" tar ((:url . "https://codeberg.org/ideasman42/emacs-magit-commit-mark") (:commit . "e468518c7b8f90deda03cc4f0e2616b367cfdee8") (:revdesc . "e468518c7b8f") (:authors ("Campbell Barton" . "ideasman42@gmail.com")) (:maintainers ("Campbell Barton" . "ideasman42@gmail.com")) (:maintainer "Campbell Barton" . "ideasman42@gmail.com"))]) (magit-delta . [(20220125 50) ((emacs (25 1)) (magit (20200426)) (xterm-color (2 0))) "Use Delta when displaying diffs in Magit" tar ((:url . "https://github.com/dandavison/magit-delta") (:commit . "5fc7dbddcfacfe46d3fd876172ad02a9ab6ac616") (:revdesc . "5fc7dbddcfac") (:authors ("Dan Davison" . "dandavison7@gmail.com")) (:maintainers ("Dan Davison" . "dandavison7@gmail.com")) (:maintainer "Dan Davison" . "dandavison7@gmail.com"))]) @@ -3277,7 +3278,7 @@ (mark-tools . [(20130614 1025) nil "Some simple tools to access the mark-ring in Emacs" tar ((:url . "https://github.com/stsquad/emacs-mark-tools") (:commit . "a11b61effa90bd0abc876d12573674d36fc17f0c") (:revdesc . "a11b61effa90") (:authors ("Alex Bennée" . "alex@bennee.com")) (:maintainers ("Alex Bennée" . "alex@bennee.com")) (:maintainer "Alex Bennée" . "alex@bennee.com"))]) (mark-yank . [(20231105 2027) ((emacs (24 4))) "Set region to the last yank" tar ((:url . "https://github.com/mkleehammer/mark-yank") (:commit . "7207aabe9edd0872ec6d506a58b942b43926c122") (:revdesc . "7207aabe9edd") (:authors ("Michael Kleehammer" . "michael@kleehammer.com")) (:maintainers ("Michael Kleehammer" . "michael@kleehammer.com")) (:maintainer "Michael Kleehammer" . "michael@kleehammer.com"))]) (markdown-changelog . [(20230805 1720) ((emacs (26)) (dash (2 13 0))) "Maintain changelog entries" tar ((:url . "https://github.com/plandes/markdown-changelog") (:commit . "403d2cd1cff932ae135692d57062824892e01d13") (:revdesc . "403d2cd1cff9") (:keywords "markdown" "changelog" "files"))]) - (markdown-mode . [(20241107 349) ((emacs (27 1))) "Major mode for Markdown-formatted text" tar ((:url . "https://github.com/jrblevin/markdown-mode") (:commit . "6f59f72ca040f0199aa72f1ae4f6c364de61cac0") (:revdesc . "6f59f72ca040") (:keywords "markdown" "github flavored markdown" "itex") (:authors ("Jason R. Blevins" . "jblevins@xbeta.org")) (:maintainers ("Jason R. Blevins" . "jblevins@xbeta.org")) (:maintainer "Jason R. Blevins" . "jblevins@xbeta.org"))]) + (markdown-mode . [(20241117 307) ((emacs (27 1))) "Major mode for Markdown-formatted text" tar ((:url . "https://github.com/jrblevin/markdown-mode") (:commit . "1716694217bfb802f768d2353cb801459027c294") (:revdesc . "1716694217bf") (:keywords "markdown" "github flavored markdown" "itex") (:authors ("Jason R. Blevins" . "jblevins@xbeta.org")) (:maintainers ("Jason R. Blevins" . "jblevins@xbeta.org")) (:maintainer "Jason R. Blevins" . "jblevins@xbeta.org"))]) (markdown-preview-eww . [(20160111 1502) ((emacs (24 4))) "Realtime preview by eww" tar ((:url . "https://github.com/niku/markdown-preview-eww") (:commit . "5853f836425c877c8a956501f0adda137ef1d3b7") (:revdesc . "5853f836425c") (:authors ("niku" . "niku@niku.name")) (:maintainers ("niku" . "niku@niku.name")) (:maintainer "niku" . "niku@niku.name"))]) (markdown-preview-mode . [(20230707 803) ((emacs (24 4)) (websocket (1 6)) (markdown-mode (2 0)) (cl-lib (0 5)) (web-server (0 1 1))) "Markdown realtime preview minor mode" tar ((:url . "https://github.com/ancane/markdown-preview-mode") (:commit . "68242b3907dc065aa35412bfd928b43d8052d321") (:revdesc . "68242b3907dc") (:keywords "markdown" "gfm" "convenience") (:authors ("Igor Shymko" . "igor.shimko@gmail.com")) (:maintainers ("Igor Shymko" . "igor.shimko@gmail.com")) (:maintainer "Igor Shymko" . "igor.shimko@gmail.com"))]) (markdown-soma . [(20240215 228) ((emacs (25)) (s (1 11 0)) (dash (2 19 1)) (f (0 20 0))) "Live preview for Markdown" tar ((:url . "https://github.com/jasonm23/markdown-soma") (:commit . "ba30e609108d32fe6e1998490548b4631e3e48c3") (:revdesc . "ba30e609108d") (:keywords "wp" "docs" "text" "markdown") (:authors ("Jason Milkins" . "jasonm23@gmail.com")) (:maintainers ("Jason Milkins" . "jasonm23@gmail.com")) (:maintainer "Jason Milkins" . "jasonm23@gmail.com"))]) @@ -3298,7 +3299,7 @@ (math-symbol-lists . [(20220828 2047) nil "Lists of Unicode math symbols and latex commands" tar ((:url . "https://github.com/vspinu/math-symbol-lists") (:commit . "ac3eb053d3b576fcdd192b0ac6ad5090ea3a7079") (:revdesc . "ac3eb053d3b5") (:keywords "unicode" "symbols" "mathematics") (:authors ("Vitalie Spinu" . "spinuvit@gmail.com")) (:maintainers ("Vitalie Spinu" . "spinuvit@gmail.com")) (:maintainer "Vitalie Spinu" . "spinuvit@gmail.com"))]) (math-symbols . [(20201005 2313) nil "Math Symbol Input methods and conversion tools" tar ((:url . "https://github.com/kawabata/math-symbols") (:commit . "091b81cb40ceaff97614999ffe85b572ace182f0") (:revdesc . "091b81cb40ce") (:keywords "i18n" "languages" "tex") (:authors ("Taichi" . "kawabata.taichi_at_gmail.com")) (:maintainers ("Taichi" . "kawabata.taichi_at_gmail.com")) (:maintainer "Taichi" . "kawabata.taichi_at_gmail.com"))]) (math-tex-convert . [(20221210 1937) ((emacs (26 1)) (math-symbol-lists (1 3)) (auctex (12 1))) "Convert LaTeX macros to unicode and back" tar ((:url . "https://github.com/enricoflor/math-tex-convert") (:commit . "8b174d05e8e5269322a1ee90f94cf1ed018d4976") (:revdesc . "8b174d05e8e5") (:authors ("Enrico Flor" . "enrico@eflor.net")) (:maintainers ("Enrico Flor" . "enrico@eflor.net")) (:maintainer "Enrico Flor" . "enrico@eflor.net"))]) - (matlab-mode . [(20241113 1829) ((emacs (27 2))) "Major mode for MATLAB(R) dot-m files" tar ((:url . "https://github.com/mathworks/Emacs-MATLAB-Mode") (:commit . "c4cf0f0dcef89bb8e261e5d8b512ce7b293edbba") (:revdesc . "c4cf0f0dcef8") (:keywords "matlab(r)") (:authors ("Matt Wette" . "mwette@alumni.caltech.edu") ("Eric M. Ludlam" . "eludlam@mathworks.com")) (:maintainers ("Eric M. Ludlam" . "eludlam@mathworks.com")) (:maintainer "Eric M. Ludlam" . "eludlam@mathworks.com"))]) + (matlab-mode . [(20241115 753) ((emacs (27 2))) "Major mode for MATLAB(R) dot-m files" tar ((:url . "https://github.com/mathworks/Emacs-MATLAB-Mode") (:commit . "fd32f4acad18bb6e91b4d8cd39bf5353a6e308f4") (:revdesc . "fd32f4acad18") (:keywords "matlab(r)") (:authors ("Matt Wette" . "mwette@alumni.caltech.edu") ("Eric M. Ludlam" . "eludlam@mathworks.com")) (:maintainers ("Eric M. Ludlam" . "eludlam@mathworks.com")) (:maintainer "Eric M. Ludlam" . "eludlam@mathworks.com"))]) (maude-mode . [(20230504 937) ((emacs (25))) "Emacs mode for the programming language Maude" tar ((:url . "https://github.com/rudi/maude-mode") (:commit . "2e1f68a890493d964f933d6e40b0ede047f70ede") (:revdesc . "2e1f68a89049") (:keywords "languages" "maude") (:authors ("Ellef Gjelstad" . "ellefg+maude*ifi.uio.no")) (:maintainers ("Rudi Schlatte" . "rudi@constantly.at")) (:maintainer "Rudi Schlatte" . "rudi@constantly.at"))]) (maven-test-mode . [(20141220 557) ((s (1 9)) (emacs (24))) "Utilities for navigating test files and running maven test tasks" tar ((:url . "https://github.com/rranelli/maven-test-mode") (:commit . "a19151861df2ad8ae4880a2e7c86ddf848cb569a") (:revdesc . "a19151861df2") (:keywords "java" "maven" "test"))]) (maxframe . [(20170120 1705) nil "Maximize the emacs frame based on display size" tar ((:url . "https://github.com/rmm5t/maxframe.el") (:commit . "13bda6dd9f1d96aa4b9dd9957a26cefd399a7772") (:revdesc . "13bda6dd9f1d") (:keywords "display" "frame" "window" "maximize"))]) @@ -3324,7 +3325,7 @@ (memoize . [(20200103 2036) nil "Memoization functions" tar ((:url . "https://github.com/skeeto/emacs-memoize") (:commit . "51b075935ca7070f62fae1d69fe0ff7d8fa56fdd") (:revdesc . "51b075935ca7") (:authors ("Christopher Wellons" . "mosquitopsu@gmail.com")) (:maintainers ("Christopher Wellons" . "mosquitopsu@gmail.com")) (:maintainer "Christopher Wellons" . "mosquitopsu@gmail.com"))]) (memolist . [(20150804 1721) ((markdown-mode (22 0)) (ag (0 45))) "Memolist.el is Emacs port of memolist.vim" tar ((:url . "https://github.com/mikanfactory/memolist.el") (:commit . "60c296e202a71e9dcf1c3936d47b5c4b95c5839f") (:revdesc . "60c296e202a7") (:keywords "markdown" "memo") (:authors ("mikanfactory" . "k952i4j14x17_at_gmail.com")))]) (mentor . [(20230103 1146) ((emacs (25 1)) (xml-rpc (1 6 15)) (seq (1 11)) (async (1 9 3)) (url-scgi (0 8))) "Frontend for the rTorrent bittorrent client" tar ((:url . "https://github.com/skangas/mentor") (:commit . "f51dd4f3f87c54b7cc92189924b9d873a53f5a75") (:revdesc . "f51dd4f3f87c") (:keywords "comm" "processes" "bittorrent") (:authors ("Stefan Kangas" . "stefankangas@gmail.com")) (:maintainers ("Stefan Kangas" . "stefankangas@gmail.com")) (:maintainer "Stefan Kangas" . "stefankangas@gmail.com"))]) - (meow . [(20241109 2346) ((emacs (27 1))) "Yet Another modal editing" tar ((:url . "https://github.com/meow-edit/meow") (:commit . "574773e487e5f7d1f604e5025f17dea962abeec8") (:revdesc . "574773e487e5") (:keywords "convenience" "modal-editing"))]) + (meow . [(20241117 201) ((emacs (27 1))) "Yet Another modal editing" tar ((:url . "https://github.com/meow-edit/meow") (:commit . "c0985b3531ca14067d96ed3018bec80fe7eeb7db") (:revdesc . "c0985b3531ca") (:keywords "convenience" "modal-editing"))]) (meow-tree-sitter . [(20240701 1422) ((emacs (29 1)) (meow (1 2 0))) "Tree-sitter powered motions for Meow" tar ((:url . "https://github.com/skissue/meow-tree-sitter") (:commit . "d8dce964fac631a6d44b650a733075e14854159c") (:revdesc . "d8dce964fac6") (:keywords "convenience" "files" "languages" "tools") (:authors ("Ad" . "me@skissue.xyz")) (:maintainers ("Ad" . "me@skissue.xyz")) (:maintainer "Ad" . "me@skissue.xyz"))]) (merlin . [(20240925 900) ((emacs (25 1))) "Mode for Merlin, an assistant for OCaml" tar ((:url . "https://github.com/ocaml/merlin") (:commit . "80e919cf32a62acdaee95a5dab9b4bc18a8b4034") (:revdesc . "80e919cf32a6") (:keywords "ocaml" "languages") (:authors ("Frédéric Bour" . "frederic.bourlakaban.net")) (:maintainers ("Frédéric Bour" . "frederic.bourlakaban.net")) (:maintainer "Frédéric Bour" . "frederic.bourlakaban.net"))]) (merlin-ac . [(20221123 1408) ((emacs (25 1)) (merlin (3)) (auto-complete (1 5))) "Merlin and auto-complete integration" tar ((:url . "https://github.com/ocaml/merlin") (:commit . "8bcab034a680f57ddf58092fda6288dc4caddd2a") (:revdesc . "8bcab034a680") (:keywords "ocaml" "languages") (:authors ("Simon Castellan" . "simon.castellaniuwt.fr") ("Frédéric Bour" . "frederic.bourlakaban.net") ("Thomas Refis" . "thomas.refisgmail.com")) (:maintainers ("Simon Castellan" . "simon.castellaniuwt.fr") ("Frédéric Bour" . "frederic.bourlakaban.net") ("Thomas Refis" . "thomas.refisgmail.com")) (:maintainer "Simon Castellan" . "simon.castellaniuwt.fr"))]) @@ -3384,7 +3385,7 @@ (mip-mode . [(20151127 617) nil "Virtual projects for emacs" tar ((:url . "https://gitlab.com/gaudecker/mip-mode") (:commit . "7c88c383b4c7ed0a4c1dc397735f365c1fcb461c") (:revdesc . "7c88c383b4c7") (:keywords "workspaces" "workspace" "project" "projects" "mip-mode") (:authors ("Eeli Reilin" . "gaudecker@fea.st")) (:maintainers ("Eeli Reilin" . "gaudecker@fea.st")) (:maintainer "Eeli Reilin" . "gaudecker@fea.st"))]) (mips-mode . [(20220608 1204) ((emacs (25 1))) "Major-mode for MIPS assembly" tar ((:url . "https://github.com/hlissner/emacs-mips-mode") (:commit . "98795cdc81979821ac35d9f94ce354cd99780c67") (:revdesc . "98795cdc8197") (:keywords "languages" "mips" "assembly") (:authors ("Henrik Lissner" . "http://github/hlissner")) (:maintainers ("Henrik Lissner" . "contact@henrik.io")) (:maintainer "Henrik Lissner" . "contact@henrik.io"))]) (mise . [(20241106 1515) ((emacs (29 1)) (inheritenv (0 2)) (dash (2 19 1))) "Support for `mise' cli" tar ((:url . "https://github.com/liuyinz/mise.el") (:commit . "6e32b3787dd926cc9d8e9202b5aaa82682398261") (:revdesc . "6e32b3787dd9") (:keywords "tools" "processes") (:authors ("liuyinz" . "liuyinz95@gmail.com")) (:maintainers ("Liuyinz" . "liuyinz95@gmail.com")) (:maintainer "Liuyinz" . "liuyinz95@gmail.com"))]) - (mistty . [(20241111 1347) ((emacs (29 1))) "Shell/Comint alternative based on term.el" tar ((:url . "https://github.com/szermatt/mistty") (:commit . "f49dce659be02b999107089aab773044375833f5") (:revdesc . "f49dce659be0") (:keywords "convenience" "unix") (:authors ("Stephane Zermatten" . "szermatt@gmx.net")) (:maintainers ("Stephane Zermatten" . "szermatt@gmx.net")) (:maintainer "Stephane Zermatten" . "szermatt@gmx.net"))]) + (mistty . [(20241115 824) ((emacs (29 1))) "Shell/Comint alternative based on term.el" tar ((:url . "https://github.com/szermatt/mistty") (:commit . "d4732b30bc1757ace0cd0aa6bb2634024d9e5e06") (:revdesc . "d4732b30bc17") (:keywords "convenience" "unix") (:authors ("Stephane Zermatten" . "szermatt@gmx.net")) (:maintainers ("Stephane Zermatten" . "szermatt@gmx.net")) (:maintainer "Stephane Zermatten" . "szermatt@gmx.net"))]) (mix . [(20240122 720) ((emacs (25 1))) "Mix Major Mode. Build Elixir using Mix" tar ((:url . "https://github.com/ayrat555/mix.el") (:commit . "16cc69cbf919769c191b1c49c1cab324fd0682a9") (:revdesc . "16cc69cbf919") (:keywords "tools") (:authors ("Ayrat Badykov" . "ayratin555@gmail.com")) (:maintainers ("Ayrat Badykov" . "ayratin555@gmail.com")) (:maintainer "Ayrat Badykov" . "ayratin555@gmail.com"))]) (mixed-pitch . [(20210304 1900) ((emacs (24 3))) "Use a variable pitch, keeping fixed pitch where it's sensible" tar ((:url . "https://gitlab.com/jabranham/mixed-pitch") (:commit . "519e05f74825abf04b7d2e0e38ec040d013a125a") (:revdesc . "519e05f74825") (:authors ("J. Alexander Branham" . "branham@utexas.edu")) (:maintainers ("J. Alexander Branham" . "branham@utexas.edu")) (:maintainer "J. Alexander Branham" . "branham@utexas.edu"))]) (mkdown . [(20140517 1418) ((markdown-mode (2 0))) "Pretty Markdown previews based on mkdown.com" tar ((:url . "https://github.com/ajtulloch/mkdown.el") (:commit . "8e23de82719af6c5b53b52b3308a02b3a1fb872e") (:revdesc . "8e23de82719a") (:keywords "markdown"))]) @@ -3410,7 +3411,7 @@ (modern-sh . [(20211101 1001) ((emacs (25 1)) (hydra (0 15 0)) (eval-in-repl (0 9 7))) "Minor mode for editing shell script" tar ((:url . "https://github.com/damon-kwok/modern-sh") (:commit . "8ebebe77304aa8170f7af809e7564c79d3bd45da") (:revdesc . "8ebebe77304a") (:keywords "languages" "programming"))]) (modtime-skip-mode . [(20140128 2201) nil "Minor mode for disabling modtime and supersession checks on files" tar ((:url . "https://github.com/jordonbiondo/modtime-skip-mode") (:commit . "c0e49523aa26b2263a8693691ac775988015f592") (:revdesc . "c0e49523aa26") (:authors ("Jordon Biondo" . "biondoj@mail.gvsu.edu")) (:maintainers ("Jordon Biondo" . "biondoj@mail.gvsu.edu")) (:maintainer "Jordon Biondo" . "biondoj@mail.gvsu.edu"))]) (modular-config . [(20210726 1614) ((emacs (25 1))) "Organize your config into small and loadable modules" tar ((:url . "https://github.com/SidharthArya/modular-config.el") (:commit . "043907d96efff70dfaea1e721de90bd35970e8bd") (:revdesc . "043907d96eff") (:keywords "startup" "lisp" "tools") (:authors ("Sidharth Arya" . "sidhartharya10@gmail.com")) (:maintainers ("Sidharth Arya" . "sidhartharya10@gmail.com")) (:maintainer "Sidharth Arya" . "sidhartharya10@gmail.com"))]) - (modus-themes . [(20241107 816) ((emacs (27 1))) "Elegant, highly legible and customizable themes" tar ((:url . "https://github.com/protesilaos/modus-themes") (:commit . "891bd2913c1455bc06674db8c9b4a5f03e9d9e45") (:revdesc . "891bd2913c14") (:keywords "faces" "theme" "accessibility") (:authors ("Protesilaos Stavrou" . "info@protesilaos.com")) (:maintainers ("Protesilaos Stavrou" . "info@protesilaos.com")) (:maintainer "Protesilaos Stavrou" . "info@protesilaos.com"))]) + (modus-themes . [(20241117 743) ((emacs (28 1))) "Elegant, highly legible and customizable themes" tar ((:url . "https://github.com/protesilaos/modus-themes") (:commit . "dc0d606e2a7058485913cbb33f27bad8e66c2d7b") (:revdesc . "dc0d606e2a70") (:keywords "faces" "theme" "accessibility") (:authors ("Protesilaos Stavrou" . "info@protesilaos.com")) (:maintainers ("Protesilaos Stavrou" . "info@protesilaos.com")) (:maintainer "Protesilaos Stavrou" . "info@protesilaos.com"))]) (moe-theme . [(20240716 854) nil "A colorful eye-candy theme. Moe, moe, kyun!" tar ((:url . "https://github.com/kuanyui/moe-theme.el") (:commit . "4b3642157bfe9a9268310d321cfe67c8c236b5e1") (:revdesc . "4b3642157bfe") (:keywords "themes") (:authors ("kuanyui" . "azazabc123@gmail.com")) (:maintainers ("kuanyui" . "azazabc123@gmail.com")) (:maintainer "kuanyui" . "azazabc123@gmail.com"))]) (molar-mass . [(20220922 1752) ((emacs (24 3))) "Calculates molar mass of a molecule" tar ((:url . "https://github.com/sergiruiztrepat/molar-mass") (:commit . "c3b686c4b621b45fa4b17857b4934eb4487d74f5") (:revdesc . "c3b686c4b621") (:keywords "convenience" "chemistry"))]) (molecule . [(20180527 743) ((emacs (25 1))) "Simple wrapper for molecule" tar ((:url . "https://gitlab.com/drymerisnothere/molecule-el") (:commit . "2ef72b81d9aa24ea782b71a061a3abdad6cae162") (:revdesc . "2ef72b81d9aa") (:keywords ":" "languages" "terminals") (:authors ("drymer" . "drymer[AT]autistici.org")) (:maintainers ("drymer" . "drymer[AT]autistici.org")) (:maintainer "drymer" . "drymer[AT]autistici.org"))]) @@ -3804,7 +3805,7 @@ (org-beautify-theme . [(20170908 2218) nil "A sub-theme to make org-mode more beautiful" tar ((:url . "https://github.com/jonnay/org-beautify-theme") (:commit . "df6a1114fda313e1689363e196c8284fbe2a2738") (:revdesc . "df6a1114fda3") (:keywords "org" "theme") (:authors ("Jonathan Arkell" . "jonnay@jonnay.net")) (:maintainers ("Jonathan Arkell" . "jonnay@jonnay.net")) (:maintainer "Jonathan Arkell" . "jonnay@jonnay.net"))]) (org-board . [(20230408 1041) nil "Bookmarking and web archival system for Org mode" tar ((:url . "https://github.com/charlesroelli/org-board") (:commit . "500fe02bc114e5b535a2eb2ab73954d79428168f") (:revdesc . "500fe02bc114") (:keywords "org" "bookmarks" "archives") (:authors ("Charles A. Roelli" . "charles@aurox.ch")) (:maintainers ("Charles A. Roelli" . "charles@aurox.ch")) (:maintainer "Charles A. Roelli" . "charles@aurox.ch"))]) (org-bookmark-heading . [(20240906 521) ((emacs (25 1)) (compat (29 1 4 5))) "Emacs bookmark support for Org mode" tar ((:url . "https://github.com/alphapapa/org-bookmark-heading") (:commit . "bcab006ec42d7e2c92875c7170df193de2ee55f5") (:revdesc . "bcab006ec42d") (:keywords "hypermedia" "outlines") (:authors ("Adam Porter" . "adam@alphapapa.net")) (:maintainers ("Adam Porter" . "adam@alphapapa.net")) (:maintainer "Adam Porter" . "adam@alphapapa.net"))]) - (org-bookmarks . [(20240906 1018) ((emacs (29 1)) (nerd-icons (0 1 0))) "Manage bookmarks in Org mode" tar ((:url . "https://repo.or.cz/org-bookmarks.git") (:commit . "42e1100b0e99bf91b532d7e06d246a2f2660d853") (:revdesc . "42e1100b0e99") (:keywords "outline" "matching" "hypermedia" "org"))]) + (org-bookmarks . [(20241115 1106) ((emacs (29 1)) (nerd-icons (0 1 0))) "Manage bookmarks in Org mode" tar ((:url . "https://repo.or.cz/org-bookmarks.git") (:commit . "22c8d837b01b0967910d731592402b57f6d2a3e9") (:revdesc . "22c8d837b01b") (:keywords "outline" "matching" "hypermedia" "org"))]) (org-bookmarks-extractor . [(20220829 146) ((emacs (25 1))) "Extract bookmarks from Org mode" tar ((:url . "https://github.com/jxq0/org-bookmarks-extractor") (:commit . "26d810d4d58de1f64f0bbd649e13816f96663d73") (:revdesc . "26d810d4d58d") (:keywords "convenience" "org") (:authors ("Xuqing Jia" . "jxq@jxq.me")) (:maintainers ("Xuqing Jia" . "jxq@jxq.me")) (:maintainer "Xuqing Jia" . "jxq@jxq.me"))]) (org-books . [(20210408 1913) ((enlive (0 0 1)) (s (1 11 0)) (helm (2 9 2)) (helm-org (1 0)) (dash (2 14 1)) (org (9 3)) (emacs (25))) "Reading list management with Org mode and helm" tar ((:url . "https://github.com/lepisma/org-books") (:commit . "9f4ec4a981bfc5eebff993c3ad49a4bed26aebd1") (:revdesc . "9f4ec4a981bf") (:keywords "outlines") (:authors ("Abhinav Tushar" . "abhinav@lepisma.xyz")) (:maintainers ("Abhinav Tushar" . "abhinav@lepisma.xyz")) (:maintainer "Abhinav Tushar" . "abhinav@lepisma.xyz"))]) (org-brain . [(20230217 1908) ((emacs (25 1)) (org (9 2))) "Org-mode concept mapping" tar ((:url . "https://github.com/Kungsgeten/org-brain") (:commit . "2bad7732aae1a3051e2a14de2e30f970bbe43c25") (:revdesc . "2bad7732aae1") (:keywords "outlines" "hypermedia") (:authors ("Erik Sjöstrand" . "sjostrand.erik@gmail.com")) (:maintainers ("Erik Sjöstrand" . "sjostrand.erik@gmail.com")) (:maintainer "Erik Sjöstrand" . "sjostrand.erik@gmail.com"))]) @@ -3896,7 +3897,7 @@ (org-multiple-keymap . [(20191017 1920) ((org (8 2 4)) (emacs (24)) (cl-lib (0 5))) "Set keymap to elements, such as timestamp and priority" tar ((:url . "https://github.com/emacsattic/org-multiple-keymap") (:commit . "4eb8aa0aada012b2346cc7f0c55e07783141a2c3") (:revdesc . "4eb8aa0aada0") (:keywords "convenience" "org-mode") (:authors ("myuhe" . "yuhei.maeda_at_gmail.com")))]) (org-newtab . [(20240227 155) ((emacs (27 1)) (websocket (1 14)) (async (1 9 7))) "Supercharge your browser's new tab page" tar ((:url . "https://github.com/Zweihander-Main/org-newtab") (:commit . "eca494a43e242558bd8db24d321ad62a8ec86c02") (:revdesc . "eca494a43e24") (:keywords "outlines") (:authors ("Zweihänder" . "zweidev@zweihander.me")) (:maintainers ("Zweihänder" . "zweidev@zweihander.me")) (:maintainer "Zweihänder" . "zweidev@zweihander.me"))]) (org-nix-shell . [(20240603 859) ((emacs (27 1)) (org (9 4))) "Org local nix-shell" tar ((:url . "https://github.com/AntonHakansson/org-nix-shell") (:commit . "f359d9e1053fadee86dd668f4789ae2e700d8e8a") (:revdesc . "f359d9e1053f") (:keywords "processes" "outlines") (:maintainers ("Anton Hakansson" . "anton@hakanssn.com")) (:maintainer "Anton Hakansson" . "anton@hakanssn.com"))]) - (org-node . [(20241103 2000) ((emacs (28 1)) (compat (30)) (llama (0))) "Link org-id entries into a network" tar ((:url . "https://github.com/meedstrom/org-node") (:commit . "37ea46582bdcc6a3cad627a1e912769545154106") (:revdesc . "37ea46582bdc") (:keywords "org" "hypermedia") (:authors ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainers ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainer "Martin Edström" . "meedstrom91@gmail.com"))]) + (org-node . [(20241116 320) ((emacs (28 1)) (compat (30)) (el-job (0 3 2)) (llama (0))) "Link org-id entries into a network" tar ((:url . "https://github.com/meedstrom/org-node") (:commit . "ba89d1b2c6f4f13a4fac3ca94491ee43116d39d9") (:revdesc . "ba89d1b2c6f4") (:keywords "org" "hypermedia") (:authors ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainers ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainer "Martin Edström" . "meedstrom91@gmail.com"))]) (org-node-fakeroam . [(20241103 2000) ((emacs (28 1)) (compat (30)) (org-node (1 7 0)) (org-roam (2 2 2)) (emacsql (4 0 3))) "Stand-ins for org-roam-autosync-mode" tar ((:url . "https://github.com/meedstrom/org-node-fakeroam") (:commit . "d77d7c4e1570b7d0cda05a944df6ffe9b78630c8") (:revdesc . "d77d7c4e1570") (:keywords "org" "hypermedia") (:authors ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainers ("Martin Edström" . "meedstrom91@gmail.com")) (:maintainer "Martin Edström" . "meedstrom91@gmail.com"))]) (org-notebook . [(20170322 452) ((emacs (24)) (org (8)) (cl-lib (0 5))) "Ease the use of org-mode as a notebook" tar ((:url . "https://github.com/Rahi374/org-notebook") (:commit . "d90c4aeca2442161e6dd89de175561af85aace03") (:revdesc . "d90c4aeca244") (:keywords "convenience" "tools") (:authors ("Paul Elder" . "paul.elder@amanokami.net")) (:maintainers ("Paul Elder" . "paul.elder@amanokami.net")) (:maintainer "Paul Elder" . "paul.elder@amanokami.net"))]) (org-noter . [(20240918 1703) ((emacs (24 4)) (cl-lib (0 6)) (org (9 4))) "A synchronized, Org-mode, document annotator" tar ((:url . "https://github.com/org-noter/org-noter") (:commit . "691efc3ed4a2828d791a148e53851365c2eb380f") (:revdesc . "691efc3ed4a2") (:keywords "lisp" "pdf" "interleave" "annotate" "external" "sync" "notes" "documents" "org-mode") (:authors ("Gonçalo Santos" . "in@bsentia") ("Maintainer Dmitry M" . "dmitrym@gmail.com")) (:maintainers ("Peter Mao" . "peter.mao@gmail.com") ("Dmitry M" . "dmitrym@gmail.com")) (:maintainer "Peter Mao" . "peter.mao@gmail.com"))]) @@ -3934,7 +3935,7 @@ (org-ref-prettify . [(20220507 649) ((emacs (24 3)) (org-ref (3 0)) (bibtex-completion (1 0 0))) "Prettify org-ref citation links" tar ((:url . "https://github.com/alezost/org-ref-prettify.el") (:commit . "0ec3b6e398ee117c8b8a787a0422b95d9e95f7bb") (:revdesc . "0ec3b6e398ee") (:keywords "convenience") (:authors ("Alex Kost" . "alezost@gmail.com") ("Vitus Schäfftlein" . "vitusschaefftlein@live.de")) (:maintainers ("Alex Kost" . "alezost@gmail.com") ("Vitus Schäfftlein" . "vitusschaefftlein@live.de")) (:maintainer "Alex Kost" . "alezost@gmail.com"))]) (org-repo-todo . [(20171228 119) nil "Simple repository todo management with org-mode" tar ((:url . "https://github.com/waymondo/org-repo-todo") (:commit . "f73ebd91399c5760ad52c6ad9033de1066042003") (:revdesc . "f73ebd91399c") (:keywords "convenience") (:authors ("justin talbott" . "justin@waymondo.com")) (:maintainers ("justin talbott" . "justin@waymondo.com")) (:maintainer "justin talbott" . "justin@waymondo.com"))]) (org-reverse-datetree . [(20240802 1519) ((emacs (29 1)) (dash (2 19 1)) (org (9 6))) "Create reverse date trees in org-mode" tar ((:url . "https://github.com/akirak/org-reverse-datetree") (:commit . "d029e2263de23b19ed89f9757ad69b7cb33bda32") (:revdesc . "d029e2263de2") (:keywords "outlines") (:authors ("Akira Komamura" . "akira.komamura@gmail.com")) (:maintainers ("Akira Komamura" . "akira.komamura@gmail.com")) (:maintainer "Akira Komamura" . "akira.komamura@gmail.com"))]) - (org-review . [(20230119 1706) nil "Schedule reviews for Org entries" tar ((:url . "https://github.com/brabalan/org-review") (:commit . "77211e40db8a9558b866f5660c7127922b459e6c") (:revdesc . "77211e40db8a") (:keywords "org" "review") (:authors ("Alan Schmitt" . "alan.schmitt@polytechnique.org")) (:maintainers ("Alan Schmitt" . "alan.schmitt@polytechnique.org")) (:maintainer "Alan Schmitt" . "alan.schmitt@polytechnique.org"))]) + (org-review . [(20241115 701) nil "Schedule reviews for Org entries" tar ((:url . "https://github.com/brabalan/org-review") (:commit . "2d9c04776a58b94cfff790ed80a471a9e5b4873b") (:revdesc . "2d9c04776a58") (:keywords "calendar") (:authors ("Alan Schmitt" . "alan.schmitt@polytechnique.org")) (:maintainers ("Alan Schmitt" . "alan.schmitt@polytechnique.org")) (:maintainer "Alan Schmitt" . "alan.schmitt@polytechnique.org"))]) (org-rich-yank . [(20240302 659) ((emacs (25 1))) "Paste with org-mode markup and link to source" tar ((:url . "https://github.com/unhammer/org-rich-yank") (:commit . "50925a1183a51a6b3a9cf9ce23c425735e622e42") (:revdesc . "50925a1183a5") (:keywords "convenience" "hypermedia" "org") (:authors ("Kevin Brubeck Unhammer" . "unhammer@fsfe.org")) (:maintainers ("Kevin Brubeck Unhammer" . "unhammer@fsfe.org")) (:maintainer "Kevin Brubeck Unhammer" . "unhammer@fsfe.org"))]) (org-roam . [(20241007 1704) ((emacs (26 1)) (dash (2 13)) (org (9 4)) (emacsql (20230228)) (magit-section (3 0 0))) "A database abstraction layer for Org-mode" tar ((:url . "https://github.com/org-roam/org-roam") (:commit . "2a630476b3d49d7106f582e7f62b515c62430714") (:revdesc . "2a630476b3d4") (:keywords "org-mode" "roam" "convenience") (:authors ("Jethro Kuan" . "jethrokuan95@gmail.com")) (:maintainers ("Jethro Kuan" . "jethrokuan95@gmail.com")) (:maintainer "Jethro Kuan" . "jethrokuan95@gmail.com"))]) (org-roam-bibtex . [(20240229 1913) ((emacs (27 1)) (org-roam (2 2 0)) (bibtex-completion (1 0 0))) "Org Roam meets BibTeX" tar ((:url . "https://github.com/org-roam/org-roam-bibtex") (:commit . "d9b8a57cfca832e3e7c7f414bf93060acbf63573") (:revdesc . "d9b8a57cfca8") (:keywords "bib" "hypermedia" "outlines" "wp") (:authors ("Mykhailo Shevchuk" . "mail@mshevchuk.com") ("Leo Vivier" . "leo.vivier+dev@gmail.com")) (:maintainers ("Mykhailo Shevchuk" . "mail@mshevchuk.com") ("Leo Vivier" . "leo.vivier+dev@gmail.com")) (:maintainer "Mykhailo Shevchuk" . "mail@mshevchuk.com"))]) @@ -4036,7 +4037,7 @@ (osx-trash . [(20220913 1736) ((emacs (24 1))) "System trash for OS X" tar ((:url . "https://github.com/emacsorphanage/osx-trash") (:commit . "90f0c99206022fec646206018fcd63d9d2e57325") (:revdesc . "90f0c9920602") (:keywords "files" "convenience" "tools" "unix") (:authors ("Sebastian Wiesner" . "swiesner@lunaryorn.com")) (:maintainers ("Sebastian Wiesner" . "swiesner@lunaryorn.com")) (:maintainer "Sebastian Wiesner" . "swiesner@lunaryorn.com"))]) (otama . [(20160404 1032) nil "Org-table Manipulator" tar ((:url . "https://github.com/yoshinari-nomura/otama") (:commit . "b69e0740846ace7885b0c0717f7abe8d0419eefd") (:revdesc . "b69e0740846a") (:keywords "database" "org-mode") (:authors ("Yoshinari Nomura" . "nom@quickhack.net")) (:maintainers ("Yoshinari Nomura" . "nom@quickhack.net")) (:maintainer "Yoshinari Nomura" . "nom@quickhack.net"))]) (other-emacs-eval . [(20180408 1348) ((emacs (25 1)) (async (1 9 2))) "Evaluate the Emacs Lisp expression in other Emacs" tar ((:url . "https://github.com/xuchunyang/other-emacs-eval") (:commit . "8ace5acafef65daabf0c6619eff60733d7f5d792") (:revdesc . "8ace5acafef6") (:keywords "tools") (:authors ("Xu Chunyang" . "mail@xuchunyang.me")) (:maintainers ("Xu Chunyang" . "mail@xuchunyang.me")) (:maintainer "Xu Chunyang" . "mail@xuchunyang.me"))]) - (otpp . [(20240824 1650) ((emacs (28 1)) (compat (29 1))) "One tab per project, with unique names" tar ((:url . "https://github.com/abougouffa/one-tab-per-project") (:commit . "f515d0636426394af9c671bf58107091f9fac072") (:revdesc . "f515d0636426") (:keywords "convenience") (:authors ("Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")")) (:maintainers ("Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")")) (:maintainer "Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")"))]) + (otpp . [(20241115 2256) ((emacs (28 1)) (compat (29 1))) "One tab per project, with unique names" tar ((:url . "https://github.com/abougouffa/one-tab-per-project") (:commit . "6507da9014b6d4b76925c089cafa62f1cb0b4500") (:revdesc . "6507da9014b6") (:keywords "convenience") (:authors ("Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")")) (:maintainers ("Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")")) (:maintainer "Abdelhak Bougouffa (rot13" . "\"nobhtbhssn@srqbencebwrpg.bet\")"))]) (ouroboros . [(20230606 1150) ((emacs (27 1)) (dash (2 19 0)) (cbor (0 2 5)) (bech32 (0 2 1))) "Ouroboros network mini-protocol" tar ((:url . "https://github.com/Titan-C/cardano.el") (:commit . "cf85424b305e8f89debb756dc67eebc84639f711") (:revdesc . "cf85424b305e") (:authors ("Oscar Najera" . "https://oscarnajera.com")) (:maintainers ("Oscar Najera" . "hi@oscarnajera.com")) (:maintainer "Oscar Najera" . "hi@oscarnajera.com"))]) (outline-indent . [(20241018 1531) ((emacs (26 1))) "Fold text using indentation" tar ((:url . "https://github.com/jamescherti/outline-indent.el") (:commit . "fdfcdf4ee456f0bd58e374de45267305c982526c") (:revdesc . "fdfcdf4ee456") (:keywords "outlines"))]) (outline-magic . [(20180619 1819) nil "Outline mode extensions for Emacs" tar ((:url . "https://github.com/tj64/outline-magic") (:commit . "2a5f07417b696cf7541d435c43bafcc64817636b") (:revdesc . "2a5f07417b69") (:keywords "outlines") (:authors ("Carsten Dominik" . "dominik@science.uva.nl")) (:maintainers ("Thorsten Jolitz" . "tjolitzATgmailDOTcom")) (:maintainer "Thorsten Jolitz" . "tjolitzATgmailDOTcom"))]) @@ -4137,7 +4138,7 @@ (parrot . [(20220101 518) ((emacs (24 1))) "Party Parrot rotates gracefully in mode-line" tar ((:url . "https://github.com/dp12/parrot") (:commit . "1d381f24d74242018e306d1a0c891bed9a465ac3") (:revdesc . "1d381f24d742") (:keywords "party" "parrot" "rotate" "sirocco" "kakapo" "games") (:authors ("Daniel Ting" . "deep.paren.12@gmail.com")) (:maintainers ("Daniel Ting" . "deep.paren.12@gmail.com")) (:maintainer "Daniel Ting" . "deep.paren.12@gmail.com"))]) (parse-csv . [(20160512 1723) nil "Parse strings with CSV fields into s-expressions" tar ((:url . "https://github.com/mrc/el-csv") (:commit . "96bef1ffbc89ea12d13311c9fa239c5c3e864890") (:revdesc . "96bef1ffbc89") (:keywords "csv") (:authors ("Matt Curtis" . "matt.r.curtis@gmail.com")) (:maintainers ("Matt Curtis" . "matt.r.curtis@gmail.com")) (:maintainer "Matt Curtis" . "matt.r.curtis@gmail.com"))]) (parse-it . [(20240101 946) ((emacs (25 1)) (s (1 12 0))) "Basic Parser in Emacs Lisp" tar ((:url . "https://github.com/jcs-elpa/parse-it") (:commit . "cdc4386ef8e94ccdeff3700021d4a944034ae559") (:revdesc . "cdc4386ef8e9") (:keywords "convenience" "parse" "parser" "lex" "lexer" "ast") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) - (parsebib . [(20241112 2030) ((emacs (25 1))) "A library for parsing bib files" tar ((:url . "https://github.com/joostkremers/parsebib") (:commit . "fb48634089b8795fd7695733aba5f06109cb4cf6") (:revdesc . "fb48634089b8") (:keywords "text" "bibtex") (:authors ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainers ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainer "Joost Kremers" . "joostkremers@fastmail.fm"))]) + (parsebib . [(20241115 2225) ((emacs (25 1))) "A library for parsing bib files" tar ((:url . "https://github.com/joostkremers/parsebib") (:commit . "c0ee4d5f10bf801af03f633b6b73ced4a0ffead7") (:revdesc . "c0ee4d5f10bf") (:keywords "text" "bibtex") (:authors ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainers ("Joost Kremers" . "joostkremers@fastmail.fm")) (:maintainer "Joost Kremers" . "joostkremers@fastmail.fm"))]) (parsec . [(20180730 16) ((emacs (24)) (cl-lib (0 5))) "Parser combinator library" tar ((:url . "https://github.com/cute-jumper/parsec.el") (:commit . "2cbbbc2254aa7bcaa4fb5e07c8c1bf2f381dba26") (:revdesc . "2cbbbc2254aa") (:keywords "extensions") (:authors ("Junpeng Qiu" . "qjpchmail@gmail.com")) (:maintainers ("Junpeng Qiu" . "qjpchmail@gmail.com")) (:maintainer "Junpeng Qiu" . "qjpchmail@gmail.com"))]) (parseclj . [(20231203 1905) ((emacs (25))) "Clojure/EDN parser" tar ((:url . "https://github.com/clojure-emacs/parseclj") (:commit . "6af22372e0fe14df882dd300b22b12ba2d7e00b0") (:revdesc . "6af22372e0fe") (:keywords "lisp" "clojure" "edn" "parser") (:authors ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainers ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainer "Arne Brasseur" . "arne@arnebrasseur.net"))]) (parseedn . [(20231203 1909) ((emacs (26)) (parseclj (1 1 1)) (map (2))) "Clojure/EDN parser" tar ((:url . "https://github.com/clojure-emacs/parseedn") (:commit . "3407e4530a367b6c2b857dae261cdbb67a440aaa") (:revdesc . "3407e4530a36") (:keywords "lisp" "clojure" "edn" "parser") (:authors ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainers ("Arne Brasseur" . "arne@arnebrasseur.net")) (:maintainer "Arne Brasseur" . "arne@arnebrasseur.net"))]) @@ -4429,7 +4430,7 @@ (puni . [(20241007 1609) ((emacs (26 1))) "Parentheses Universalistic" tar ((:url . "https://github.com/AmaiKinono/puni") (:commit . "f430f5b0a14c608176e3376058eb380ab0824621") (:revdesc . "f430f5b0a14c") (:keywords "convenience" "lisp" "tools") (:authors ("Hao Wang" . "amaikinono@gmail.com")) (:maintainers ("Hao Wang" . "amaikinono@gmail.com")) (:maintainer "Hao Wang" . "amaikinono@gmail.com"))]) (punpun-themes . [(20240929 2238) ((emacs (24 1))) "A set of bleak themes" tar ((:url . "https://depp.brause.cc/punpun-themes.git") (:commit . "a0b26442293e7afc6fd2ba9be199fc7b4f5138e3") (:revdesc . "a0b26442293e") (:authors ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainers ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainer "Vasilij Schneidermann" . "mail@vasilij.de"))]) (puppet-mode . [(20210305 645) ((emacs (24 1)) (pkg-info (0 4))) "Major mode for Puppet manifests" tar ((:url . "https://github.com/voxpupuli/puppet-mode") (:commit . "ab25cf379236f4e1bd4bc9c1d77a93c95800e9bf") (:revdesc . "ab25cf379236") (:keywords "languages") (:authors ("Vox Pupuli" . "voxpupuli@groups.io") ("Bozhidar Batsov" . "bozhidar@batsov.com") ("Sebastian Wiesner" . "swiesner@lunaryorn.com") ("Russ Allbery" . "rra@stanford.edu")) (:maintainers ("Vox Pupuli" . "voxpupuli@groups.io") ("Bozhidar Batsov" . "bozhidar@batsov.com") ("Sebastian Wiesner" . "swiesner@lunaryorn.com") ("Tim Meusel" . "tim@bastelfreak.de")) (:maintainer "Vox Pupuli" . "voxpupuli@groups.io"))]) - (puppet-ts-mode . [(20241112 1430) ((emacs (29 1))) "Major mode for Puppet using Tree-sitter" tar ((:url . "https://github.com/smoeding/puppet-ts-mode") (:commit . "65c65a32a299c4679fb09e06deeecafe62675794") (:revdesc . "65c65a32a299") (:keywords "languages") (:authors ("Stefan Möding" . "stm@kill-9.net")) (:maintainers ("Stefan Möding" . "stm@kill-9.net")) (:maintainer "Stefan Möding" . "stm@kill-9.net"))]) + (puppet-ts-mode . [(20241116 1119) ((emacs (29 1))) "Major mode for Puppet using Tree-sitter" tar ((:url . "https://github.com/smoeding/puppet-ts-mode") (:commit . "80712560587967eeea5bd891a7d75291d63664e1") (:revdesc . "807125605879") (:keywords "languages") (:authors ("Stefan Möding" . "stm@kill-9.net")) (:maintainers ("Stefan Möding" . "stm@kill-9.net")) (:maintainer "Stefan Möding" . "stm@kill-9.net"))]) (purescript-mode . [(20240930 737) ((emacs (25 1))) "A PureScript editing mode" tar ((:url . "https://github.com/purescript-emacs/purescript-mode") (:commit . "d187b3d4bbb4d9cb36a4c6c55f35d63d159a26e8") (:revdesc . "d187b3d4bbb4") (:keywords "faces" "files" "purescript") (:authors ("1997-1998 Graeme E Moss and" . "gem@cs.york.ac.uk") ("Tommy Thorn" . "thorn@irisa.fr") ("2003 Dave Love" . "fx@gnu.org") ("2014 Tim Dysinger" . "tim@dysinger.net")) (:maintainers ("1997-1998 Graeme E Moss and" . "gem@cs.york.ac.uk") ("Tommy Thorn" . "thorn@irisa.fr") ("2003 Dave Love" . "fx@gnu.org") ("2014 Tim Dysinger" . "tim@dysinger.net")) (:maintainer "1997-1998 Graeme E Moss and" . "gem@cs.york.ac.uk"))]) (purp-theme . [(20210912 1940) nil "A dark color theme with few colors" tar ((:url . "https://github.com/gnuvince/purp") (:commit . "8d3510e1ed995b8323cd5205626ddde6386a76ca") (:revdesc . "8d3510e1ed99") (:keywords "faces") (:authors ("Vincent Foley" . "vfoley@gmail.com")) (:maintainers ("Vincent Foley" . "vfoley@gmail.com")) (:maintainer "Vincent Foley" . "vfoley@gmail.com"))]) (purple-haze-theme . [(20141015 229) ((emacs (24 0))) "An overtly purple color theme for Emacs24" tar ((:url . "https://github.com/emacsfodder/emacs-purple-haze-theme") (:commit . "3e245cbef7cd09e6b3ee124963e372a04e9a6485") (:revdesc . "3e245cbef7cd") (:authors ("Jason Milkins" . "jasonm23@gmail.com")) (:maintainers ("Jason Milkins" . "jasonm23@gmail.com")) (:maintainer "Jason Milkins" . "jasonm23@gmail.com"))]) @@ -4509,7 +4510,7 @@ (qwen-chat-shell . [(20240612 343) ((emacs (27 1)) (shell-maker (0 50 1))) "Qwen-chat shell + buffer insert commands" tar ((:url . "https://github.com/Pavinberg/qwen-chat-shell") (:commit . "2d6562c8a75aebf7a59e554011571ba5883cf4fd") (:revdesc . "2d6562c8a75a") (:authors ("Pavinberg" . "pavin0702@gmail.com")) (:maintainers ("Pavinberg" . "pavin0702@gmail.com")) (:maintainer "Pavinberg" . "pavin0702@gmail.com"))]) (r-autoyas . [(20140101 1510) ((ess (0)) (yasnippet (0 8 0))) "Provides automatically created yasnippets for R function argument lists" tar ((:url . "https://github.com/mattfidler/r-autoyas.el") (:commit . "d321a7da0ef2e94668d53e0807277da7b70ea678") (:revdesc . "d321a7da0ef2") (:keywords "r" "yasnippet"))]) (racer . [(20210307 243) ((emacs (25 1)) (rust-mode (0 2 0)) (dash (2 13 0)) (s (1 10 0)) (f (0 18 2)) (pos-tip (0 4 6))) "Code completion, goto-definition and docs browsing for Rust via racer" tar ((:url . "https://github.com/racer-rust/emacs-racer") (:commit . "1e63e98626737ea9b662d4a9b1ffd6842b1c648c") (:revdesc . "1e63e9862673") (:keywords "abbrev" "convenience" "matching" "rust" "tools"))]) - (racket-mode . [(20241112 1938) ((emacs (25 1))) "Racket editing, REPL, and more" tar ((:url . "https://github.com/greghendershott/racket-mode") (:commit . "5a8fbb6eab46cc8b371fc2d589fb3503f820795d") (:revdesc . "5a8fbb6eab46") (:authors ("Greg Hendershott" . "racket-mode-author@greghendershott.com")))]) + (racket-mode . [(20241116 1700) ((emacs (25 1))) "Racket editing, REPL, and more" tar ((:url . "https://github.com/greghendershott/racket-mode") (:commit . "c5bee6895b2d028820a75356abacc19a5ed11918") (:revdesc . "c5bee6895b2d") (:authors ("Greg Hendershott" . "racket-mode-author@greghendershott.com")))]) (rails-i18n . [(20220126 1643) ((emacs (27 2)) (yaml (0 1 0)) (dash (2 19 1))) "Seach and insert i18n on ruby code" tar ((:url . "https://github.com/otavioschwanck/rails-i18n.el") (:commit . "8e87e4e48e31902b8259ded28a208c2e7efea6e9") (:revdesc . "8e87e4e48e31") (:keywords "tools" "languages") (:authors ("Otávio Schwanck dos Santos" . "otavioschwanck@gmail.com")) (:maintainers ("Otávio Schwanck dos Santos" . "otavioschwanck@gmail.com")) (:maintainer "Otávio Schwanck dos Santos" . "otavioschwanck@gmail.com"))]) (rails-log-mode . [(20140408 425) nil "Major mode for viewing Rails log files" tar ((:url . "https://github.com/ananthakumaran/rails-log-mode") (:commit . "ff440003ad7d47cb0ac3300f2a632f4cfd36a446") (:revdesc . "ff440003ad7d") (:keywords "rails" "log") (:authors ("Anantha kumaran" . "ananthakumaran@gmail.com")) (:maintainers ("Anantha kumaran" . "ananthakumaran@gmail.com")) (:maintainer "Anantha kumaran" . "ananthakumaran@gmail.com"))]) (rails-routes . [(20220126 1631) ((emacs (27 2)) (inflections (1 1))) "Search for and insert rails routes" tar ((:url . "https://github.com/otavioschwanck/rails-routes.el") (:commit . "eab995a9297ca5bd9bd4f4c2737f2fecfc36def0") (:revdesc . "eab995a9297c") (:keywords "tools" "languages") (:authors ("Otávio Schwanck" . "otavioschwanck@gmail.com")) (:maintainers ("Otávio Schwanck" . "otavioschwanck@gmail.com")) (:maintainer "Otávio Schwanck" . "otavioschwanck@gmail.com"))]) @@ -4907,7 +4908,7 @@ (slow-keys . [(20220807 1425) ((emacs (24 1))) "Slow keys mode to avoid RSI" tar ((:url . "https://git.sr.ht/~gitmux/slow-keys") (:commit . "b951ae4bdcea56ced03f227b82b28c3d91d15e61") (:revdesc . "b951ae4bdcea") (:keywords "convenience") (:authors ("Manuel Uberti" . "manuel.uberti@inventati.org")) (:maintainers ("Manuel Uberti" . "manuel.uberti@inventati.org")) (:maintainer "Manuel Uberti" . "manuel.uberti@inventati.org"))]) (slstats . [(20170823 849) ((cl-lib (0 5)) (emacs (24))) "Acquire and display stats about Second Life" tar ((:url . "https://github.com/davep/slstats.el") (:commit . "e9696066abf3f2b7b818a57c062530dfd9377033") (:revdesc . "e9696066abf3") (:keywords "games") (:authors ("Dave Pearson" . "davep@davep.org")) (:maintainers ("Dave Pearson" . "davep@davep.org")) (:maintainer "Dave Pearson" . "davep@davep.org"))]) (slurm-mode . [(20210519 1109) nil "Interaction with the SLURM job scheduling system" tar ((:url . "https://github.com/ffevotte/slurm.el") (:commit . "4e6ac09245313cf4018b8e5784b2fca8604269d7") (:revdesc . "4e6ac0924531"))]) - (slurpbarf . [(20240922 1741) ((emacs (29 1))) "Commands for slurping and barfing" tar ((:url . "https://codeberg.org/vilij/slurpbarf-elcute") (:commit . "98f0a9a124e46dd16683ff54208fee539945db46") (:revdesc . "98f0a9a124e4") (:keywords "convenience"))]) + (slurpbarf . [(20241115 1459) ((emacs (29 1))) "Commands for slurping and barfing" tar ((:url . "https://codeberg.org/vilij/slurpbarf-elcute") (:commit . "c6e7d4b5da6f1116b479c71d9c7fa0aca71d4030") (:revdesc . "c6e7d4b5da6f") (:keywords "convenience"))]) (sly . [(20240809 2119) ((emacs (24 3))) "Sylvester the Cat's Common Lisp IDE" tar ((:url . "https://github.com/joaotavora/sly") (:commit . "742355f7554ab6c46e5c1c9bdb89068f55359eaa") (:revdesc . "742355f7554a") (:keywords "languages" "lisp" "sly"))]) (sly-asdf . [(20221119 2235) ((emacs (24 3)) (sly (1 0 0 -2 2)) (popup (0 5 3))) "ASDF system support for SLY" tar ((:url . "https://github.com/mmgeorge/sly-asdf") (:commit . "6f9d751469bb82530db1673c22e7437ca6c95f45") (:revdesc . "6f9d751469bb") (:keywords "languages" "lisp" "sly" "asdf") (:maintainers ("Matt George" . "mmge93@gmail.com")) (:maintainer "Matt George" . "mmge93@gmail.com"))]) (sly-hello-world . [(20200225 1755) ((sly (1 0 0 -2 2))) "A template SLY contrib" tar ((:url . "https://github.com/joaotavora/sly-hello-world") (:commit . "be257e9ad354db690c7378e89899335597348a0d") (:revdesc . "be257e9ad354") (:keywords "languages" "lisp" "sly") (:authors ("João Távora" . "joaotavora@gmail.com")) (:maintainers ("João Távora" . "joaotavora@gmail.com")) (:maintainer "João Távora" . "joaotavora@gmail.com"))]) @@ -5011,7 +5012,7 @@ (sparkline . [(20150101 1319) ((cl-lib (0 3))) "Make sparkline images from a list of numbers" tar ((:url . "https://github.com/woudshoo/sparkline") (:commit . "a2b5d817d272d6363b67ed8f8cc75499a19fa8d2") (:revdesc . "a2b5d817d272") (:keywords "extensions") (:authors ("Willem Rein Oudshoorn" . "woudshoo@xs4all.nl")) (:maintainers ("Willem Rein Oudshoorn" . "woudshoo@xs4all.nl")) (:maintainer "Willem Rein Oudshoorn" . "woudshoo@xs4all.nl"))]) (sparql-mode . [(20230104 1113) ((cl-lib (0 5)) (emacs (24 3))) "Edit and interactively evaluate SPARQL queries" tar ((:url . "https://github.com/ljos/sparql-mode") (:commit . "1f6196094ec6626722c6e03a13f6844c68f62703") (:revdesc . "1f6196094ec6") (:authors ("Craig Andera" . "canderaatwangderadotcom")) (:maintainers ("Bjarte Johansen" . "BjartedotJohansenatgmaildotcom")) (:maintainer "Bjarte Johansen" . "BjartedotJohansenatgmaildotcom"))]) (spatial-navigate . [(20240421 908) ((emacs (29 1))) "Directional navigation between white-space blocks" tar ((:url . "https://codeberg.org/ideasman42/emacs-spatial-navigate") (:commit . "4f85fe3ae4d240a35d3d7edd8b865612024f9dda") (:revdesc . "4f85fe3ae4d2") (:authors ("Campbell Barton" . "ideasman42@gmail.com")) (:maintainers ("Campbell Barton" . "ideasman42@gmail.com")) (:maintainer "Campbell Barton" . "ideasman42@gmail.com"))]) - (spdx . [(20241112 116) ((emacs (24 4))) "Insert SPDX license and copyright headers" tar ((:url . "https://github.com/condy0919/spdx.el") (:commit . "815cbdf9c6926a39a7f303b33033f6ccaef1ebfd") (:revdesc . "815cbdf9c692") (:keywords "license" "tools") (:authors ("Zhiwei Chen" . "condy0919@gmail.com")) (:maintainers ("Zhiwei Chen" . "condy0919@gmail.com")) (:maintainer "Zhiwei Chen" . "condy0919@gmail.com"))]) + (spdx . [(20241117 126) ((emacs (24 4))) "Insert SPDX license and copyright headers" tar ((:url . "https://github.com/condy0919/spdx.el") (:commit . "c036cfc6e6581b1c23d484d278e278c4d809fc23") (:revdesc . "c036cfc6e658") (:keywords "license" "tools") (:authors ("Zhiwei Chen" . "condy0919@gmail.com")) (:maintainers ("Zhiwei Chen" . "condy0919@gmail.com")) (:maintainer "Zhiwei Chen" . "condy0919@gmail.com"))]) (speech-tagger . [(20170728 1829) ((cl-lib (0 5))) "Tag parts of speech using coreNLP" tar ((:url . "https://github.com/cosmicexplorer/speech-tagger") (:commit . "61955b40d4e8b09e66a3e8033e82893f81657c06") (:revdesc . "61955b40d4e8") (:keywords "speech" "tag" "nlp" "language" "corenlp" "parsing" "natural") (:authors ("Danny McClanahan" . "danieldmcclanahan@gmail.com")) (:maintainers ("Danny McClanahan" . "danieldmcclanahan@gmail.com")) (:maintainer "Danny McClanahan" . "danieldmcclanahan@gmail.com"))]) (speechd-el . [(20240513 1716) nil "Client to speech synthesizers and Braille displays" tar ((:url . "https://github.com/brailcom/speechd-el") (:commit . "ac7497e394bf7d46e0b2c27570f5507f6a50a157") (:revdesc . "ac7497e394bf") (:authors ("Milan Zamazal" . "pdm@zamazal.org")) (:maintainers ("Milan Zamazal" . "pdm@zamazal.org")) (:maintainer "Milan Zamazal" . "pdm@zamazal.org"))]) (speed-type . [(20230926 838) ((emacs (26 1)) (compat (29 1 3))) "Practice touch and speed typing" tar ((:url . "https://github.com/dakra/speed-type") (:commit . "28b8e8c1cc24511758168f30bcac18d8fb93706d") (:revdesc . "28b8e8c1cc24") (:keywords "games") (:maintainers ("Daniel Kraus" . "daniel@kraus.my")) (:maintainer "Daniel Kraus" . "daniel@kraus.my"))]) @@ -5047,7 +5048,7 @@ (sr-speedbar . [(20220705 1231) nil "Same frame speedbar" tar ((:url . "https://github.com/emacsorphanage/sr-speedbar") (:commit . "73ecfc21cf38f0cb1dfbbebebdc3cf573eccf7d2") (:revdesc . "73ecfc21cf38") (:keywords "speedbar" "sr-speedbar.el") (:authors ("Sebastian Rose" . "sebastian_rose@gmx.de")) (:maintainers ("Sebastian Rose" . "sebastian_rose@gmx.de") ("Peter Lunicks" . "plunix@users.sourceforge.net")) (:maintainer "Sebastian Rose" . "sebastian_rose@gmx.de"))]) (srcery-theme . [(20240220 805) ((emacs (24))) "Dark color theme" tar ((:url . "https://github.com/srcery-colors/srcery-emacs") (:commit . "60028633c5722e6b8ea12844618be0e9b31be55a") (:revdesc . "60028633c572") (:keywords "faces"))]) (srefactor . [(20230504 617) ((emacs (24 4))) "A refactoring tool based on Semantic parser framework" tar ((:url . "https://github.com/tuhdo/semantic-refactor") (:commit . "95c70a94b5aad4c85b35569e2f2325047791153a") (:revdesc . "95c70a94b5aa") (:keywords "c" "languages" "tools") (:authors ("Do Hoang" . "tuhdo1710@gmail.com")))]) - (srfi . [(20240924 1924) ((emacs (25 1))) "Scheme Requests for Implementation browser" tar ((:url . "https://github.com/srfi-explorations/emacs-srfi") (:commit . "1dcf802700b39a078d970c2e18fcae91f674b0ff") (:revdesc . "1dcf802700b3") (:keywords "languages" "util") (:authors ("Lassi Kortela" . "lassi@lassi.io")) (:maintainers ("Lassi Kortela" . "lassi@lassi.io")) (:maintainer "Lassi Kortela" . "lassi@lassi.io"))]) + (srfi . [(20241115 2307) ((emacs (25 1))) "Scheme Requests for Implementation browser" tar ((:url . "https://github.com/srfi-explorations/emacs-srfi") (:commit . "72d09e6c34f0809536a668ca7031ead6ba082ded") (:revdesc . "72d09e6c34f0") (:keywords "languages" "util") (:authors ("Lassi Kortela" . "lassi@lassi.io")) (:maintainers ("Lassi Kortela" . "lassi@lassi.io")) (:maintainer "Lassi Kortela" . "lassi@lassi.io"))]) (srv . [(20180715 1959) ((emacs (24 3))) "Perform SRV DNS requests" tar ((:url . "https://github.com/legoscia/srv.el") (:commit . "714387d5a5cf34d8d8cd96bdb1f9cb8ded823ff7") (:revdesc . "714387d5a5cf") (:keywords "comm") (:authors ("Magnus Henoch" . "magnus.henoch@gmail.com")) (:maintainers ("Magnus Henoch" . "magnus.henoch@gmail.com")) (:maintainer "Magnus Henoch" . "magnus.henoch@gmail.com"))]) (ssass-mode . [(20200211 132) ((emacs (24 3))) "Edit Sass without a Turing Machine" tar ((:url . "https://github.com/AdamNiederer/ssass-mode") (:commit . "96f557887ad97a0066a60c54f92b7234b8407016") (:revdesc . "96f557887ad9") (:keywords "languages" "sass") (:authors ("Adam Niederer" . "adam.niederer@gmail.com")) (:maintainers ("Adam Niederer" . "adam.niederer@gmail.com")) (:maintainer "Adam Niederer" . "adam.niederer@gmail.com"))]) (ssh . [(20120904 2042) nil "Support for remote logins using ssh" tar ((:url . "https://codeberg.org/emacs-weirdware-abandoned/ssh") (:commit . "c17cf5b43df8ac4662a0580f85898e1f078df0d1") (:revdesc . "c17cf5b43df8") (:keywords "unix" "comm") (:authors ("Noah Friedman" . "friedman@splode.com")) (:maintainers ("Ian Eure" . "ian.eure@gmail.com")) (:maintainer "Ian Eure" . "ian.eure@gmail.com"))]) @@ -5183,7 +5184,7 @@ (tango-2-theme . [(20120312 2025) nil "Tango 2 color theme for GNU Emacs 24" tar ((:url . "https://gist.github.com/2024464.git") (:commit . "64e44c98e41ebbe3b827d54280e3b9615787daaa") (:revdesc . "64e44c98e41e"))]) (tango-plus-theme . [(20240703 1443) nil "A color theme based on the tango palette" tar ((:url . "https://github.com/tmalsburg/tango-plus-theme") (:commit . "e042de79ba009a55aeebe30aafed01234c925be2") (:revdesc . "e042de79ba00") (:authors ("Titus von der Malsburg" . "malsburg@posteo.de")) (:maintainers ("Titus von der Malsburg" . "malsburg@posteo.de")) (:maintainer "Titus von der Malsburg" . "malsburg@posteo.de"))]) (tangonov-theme . [(20230425 1456) ((emacs (25))) "A 256 color dark theme featuring bright pastels" tar ((:url . "https://git.sr.ht/~trevdev/tangonov-theme") (:commit . "bfeafe22d38877d4064670adec55ba1e8d09d830") (:revdesc . "bfeafe22d388") (:keywords "faces" "theme" "dark" "fringe") (:authors ("Trevor Richards" . "trev@trevdev.ca")) (:maintainers ("Trevor Richards" . "trev@trevdev.ca")) (:maintainer "Trevor Richards" . "trev@trevdev.ca"))]) - (tangotango-theme . [(20220714 2034) nil "Tango Palette color theme for Emacs 24" tar ((:url . "https://github.com/juba/color-theme-tangotango") (:commit . "9036c4978965149ae9837bc0ad691b2ba9269052") (:revdesc . "9036c4978965") (:keywords "tango" "palette" "color" "theme" "emacs") (:authors ("Julien Barnier" . "julien@nozav.org")) (:maintainers ("Julien Barnier" . "julien@nozav.org")) (:maintainer "Julien Barnier" . "julien@nozav.org"))]) + (tangotango-theme . [(20241117 1143) nil "Tango Palette color theme for Emacs 24" tar ((:url . "https://github.com/juba/color-theme-tangotango") (:commit . "897c1643bd2cfd3c0b265a5f7599d1d04de0c304") (:revdesc . "897c1643bd2c") (:keywords "tango" "palette" "color" "theme" "emacs") (:authors ("Julien Barnier" . "julien@nozav.org")) (:maintainers ("Julien Barnier" . "julien@nozav.org")) (:maintainer "Julien Barnier" . "julien@nozav.org"))]) (tao-theme . [(20240615 517) nil "This package provides two parametrized uncoloured color themes for Emacs: tao-yin and tao-yang" tar ((:url . "https://github.com/11111000000/tao-theme-emacs") (:commit . "cd8ac4aee9fff55bc092ce78d93bd40517fa2c2a") (:revdesc . "cd8ac4aee9ff") (:authors ("Peter Kosov" . "11111000000@email.com")) (:maintainers ("Peter Kosov" . "11111000000@email.com")) (:maintainer "Peter Kosov" . "11111000000@email.com"))]) (tardis-theme . [(20230212 2152) ((emacs (25 1))) "Quantum Country Theme" tar ((:url . "https://github.com/antonhibl/tardis-theme") (:commit . "352b1579d13e99cff9367b08208c1e241d76c89e") (:revdesc . "352b1579d13e") (:keywords "convenience") (:authors ("Anton Hibl" . "antonhibl11@gmail.com")) (:maintainers ("Anton Hibl" . "antonhibl11@gmail.com")) (:maintainer "Anton Hibl" . "antonhibl11@gmail.com"))]) (taskpaper-mode . [(20241007 837) ((emacs (25 1))) "Major mode for working with TaskPaper files" tar ((:url . "https://github.com/saf-dmitry/taskpaper-mode") (:commit . "eb3907798188f3117f24eec8f295b9490f6a0953") (:revdesc . "eb3907798188") (:keywords "outlines" "notetaking" "task management" "productivity" "taskpaper") (:authors ("Dmitry Safronov" . "saf.dmitry@gmail.com")) (:maintainers ("Dmitry Safronov" . "saf.dmitry@gmail.com")) (:maintainer "Dmitry Safronov" . "saf.dmitry@gmail.com"))]) @@ -5196,13 +5197,13 @@ (tea-time . [(20120331 820) nil "Simple timer package, useful to make perfect tea" tar ((:url . "https://github.com/konzeptual/tea-time") (:commit . "1f6cf0bdd27c5eb3508989c5095427781f858eca") (:revdesc . "1f6cf0bdd27c") (:keywords "timer" "tea-time") (:authors ("konsty" . "antipin.konstantin@googlemail.com")) (:maintainers ("Gabriel Saldana" . "gsaldana@gmail.com")) (:maintainer "Gabriel Saldana" . "gsaldana@gmail.com"))]) (teacode-expand . [(20181231 640) ((emacs (24 4))) "Expansion of text by TeaCode program" tar ((:url . "https://github.com/raguay/TeaCode-Expand") (:commit . "7df6f9ec95da1fb47bbae489bb3f2c27ed3a9b3a") (:revdesc . "7df6f9ec95da") (:keywords "lisp") (:authors ("Richard Guay" . "raguay@customct.com")) (:maintainers ("Richard Guay" . "raguay@customct.com")) (:maintainer "Richard Guay" . "raguay@customct.com"))]) (teco . [(20200707 2309) nil "Teco interpreter" tar ((:url . "https://github.com/mtk/teco") (:commit . "2529eb0f7f35c526c1b6fca5250399718ff5138a") (:revdesc . "2529eb0f7f35") (:keywords "convenience" "emulations" "files") (:authors ("Dale R. Worley" . "worley@alum.mit.edu")) (:maintainers ("Mark T. Kennedy" . "mtk@acm.org")) (:maintainer "Mark T. Kennedy" . "mtk@acm.org"))]) - (telega . [(20241109 855) ((emacs (27 1)) (visual-fill-column (1 9)) (transient (0 3 0))) "Telegram client (unofficial)" tar ((:url . "https://github.com/zevlg/telega.el") (:commit . "0368bae5646193d421a04130ed5e046fe47946d3") (:revdesc . "0368bae56461") (:keywords "comm") (:authors ("Zajcev Evgeny" . "zevlg@yandex.ru")) (:maintainers ("Zajcev Evgeny" . "zevlg@yandex.ru")) (:maintainer "Zajcev Evgeny" . "zevlg@yandex.ru"))]) + (telega . [(20241115 1854) ((emacs (27 1)) (visual-fill-column (1 9)) (transient (0 3 0))) "Telegram client (unofficial)" tar ((:url . "https://github.com/zevlg/telega.el") (:commit . "6ff8203a2f208c0d0cd070e07f785f62f438aeae") (:revdesc . "6ff8203a2f20") (:keywords "comm") (:authors ("Zajcev Evgeny" . "zevlg@yandex.ru")) (:maintainers ("Zajcev Evgeny" . "zevlg@yandex.ru")) (:maintainer "Zajcev Evgeny" . "zevlg@yandex.ru"))]) (telepathy . [(20131209 1258) nil "Access Telepathy from Emacs" tar ((:url . "https://github.com/NicolasPetton/telepathy.el") (:commit . "211d785b02a29ddc254422fdcc3db45262582f8c") (:revdesc . "211d785b02a2") (:keywords "telepathy" "tools") (:authors ("Nicolas Petton" . "petton.nicolas@gmail.com")) (:maintainers ("Nicolas Petton" . "petton.nicolas@gmail.com")) (:maintainer "Nicolas Petton" . "petton.nicolas@gmail.com"))]) (telephone-line . [(20240109 2021) ((emacs (24 4)) (cl-lib (0 5)) (cl-generic (0 2)) (seq (1 8))) "Rewrite of Powerline" tar ((:url . "https://github.com/dbordak/telephone-line") (:commit . "6016418a5e1e8e006cc202eff50ff28b594eeca4") (:revdesc . "6016418a5e1e") (:keywords "mode-line") (:authors ("Daniel Bordak" . "dbordak@fastmail.fm")) (:maintainers ("Daniel Bordak" . "dbordak@fastmail.fm")) (:maintainer "Daniel Bordak" . "dbordak@fastmail.fm"))]) (teleport . [(20240718 652) ((emacs (28 1)) (dash (2 18 0))) "Integration for tsh (goteleport.com)" tar ((:url . "https://github.com/caramelhooves/teleport.el") (:commit . "929f87990a6ee83dfcb7ebf9f8580828f1281ebb") (:revdesc . "929f87990a6e") (:keywords "tools") (:authors ("Caramel Hooves" . "caramel.hooves@protonmail.com")) (:maintainers ("Caramel Hooves" . "caramel.hooves@protonmail.com")) (:maintainer "Caramel Hooves" . "caramel.hooves@protonmail.com"))]) (teletext . [(20231215 1524) ((emacs (24 3))) "Teletext broadcast viewer" tar ((:url . "https://github.com/lassik/emacs-teletext") (:commit . "d59ae5f9b79007646815a38f31882a114ca8aee0") (:revdesc . "d59ae5f9b790") (:keywords "comm" "help" "hypermedia") (:authors ("Lassi Kortela" . "lassi@lassi.io")) (:maintainers ("Lassi Kortela" . "lassi@lassi.io")) (:maintainer "Lassi Kortela" . "lassi@lassi.io"))]) (teletext-yle . [(20231215 1609) ((emacs (24 3)) (teletext (0 1))) "Teletext provider for Finnish national network YLE" tar ((:url . "https://github.com/lassik/emacs-teletext-yle") (:commit . "59a287c26571db07e191ac86cdf0be312fec1964") (:revdesc . "59a287c26571") (:keywords "comm" "help" "hypermedia") (:authors ("Lassi Kortela" . "lassi@lassi.io")) (:maintainers ("Lassi Kortela" . "lassi@lassi.io")) (:maintainer "Lassi Kortela" . "lassi@lassi.io"))]) - (tempel . [(20240926 925) ((emacs (28 1)) (compat (30))) "Tempo templates/snippets with in-buffer field editing" tar ((:url . "https://github.com/minad/tempel") (:commit . "7414b13cf9986f241f89149ccd2c39f1ec1d110c") (:revdesc . "7414b13cf998") (:keywords "abbrev" "languages" "tools" "text") (:authors ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) + (tempel . [(20241115 656) ((emacs (28 1)) (compat (30))) "Tempo templates/snippets with in-buffer field editing" tar ((:url . "https://github.com/minad/tempel") (:commit . "3659036edbc332746dec556d0dec69ac4c52dcac") (:revdesc . "3659036edbc3") (:keywords "abbrev" "languages" "tools" "text") (:authors ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainers ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Daniel Mendler" . "mail@daniel-mendler.de"))]) (tempel-collection . [(20241107 1417) ((tempel (0 5)) (emacs (29 1))) "Collection of templates for Tempel" tar ((:url . "https://github.com/Crandel/tempel-collection") (:commit . "85f8e1d80963bc717abb8bf160274455093e3b6f") (:revdesc . "85f8e1d80963") (:keywords "tools") (:authors ("Vitalii Drevenchuk" . "cradlemann@gmail.com") ("Max Penet" . "mpenetr@s-exp.com") ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainers ("Vitalii Drevenchuk" . "cradlemann@gmail.com") ("Max Penet" . "mpenetr@s-exp.com") ("Daniel Mendler" . "mail@daniel-mendler.de")) (:maintainer "Vitalii Drevenchuk" . "cradlemann@gmail.com"))]) (templ-ts-mode . [(20240118 338) ((emacs (29 1))) "Major mode for editing Templ files" tar ((:url . "https://github.com/danderson/templ-ts-mode") (:commit . "e43dc22adada160906bd411b03cfa022d787486d") (:revdesc . "e43dc22adada") (:keywords "languages") (:authors ("David Anderson" . "dave@natulte.net")) (:maintainers ("David Anderson" . "dave@natulte.net")) (:maintainer "David Anderson" . "dave@natulte.net"))]) (template-dumper . [(20240630 2236) ((emacs (28 1)) (yasnippet (0 14 0)) (f (0 20 0))) "Create files from yasnippet templates" tar ((:url . "https://github.com/natelastname/template-dumper") (:commit . "92fb170d572f044aaedaa2535990eba556347dfe") (:revdesc . "92fb170d572f") (:keywords "yasnippet" "templating" "convenience" "tools"))]) @@ -5297,7 +5298,7 @@ (toggle-term . [(20241112 635) ((emacs (25 1))) "Quickly toggle persistent term and shell buffers" tar ((:url . "https://github.com/justinlime/toggle-term.el") (:commit . "64f7022d214d5701c6babfe4a975baa60ec999c8") (:revdesc . "64f7022d214d") (:keywords "frames" "convenience" "terminals"))]) (toggle-test . [(20140723 537) nil "Toggle between source and test files in various programming languages" tar ((:url . "https://github.com/rags/toggle-test") (:commit . "a0b64834101c2b8b24da365baea1d36e57b069b5") (:revdesc . "a0b64834101c") (:keywords "tdd" "test" "toggle" "productivity") (:authors ("Raghunandan Rao" . "r.raghunandan@gmail.com")) (:maintainers ("Raghunandan Rao" . "r.raghunandan@gmail.com")) (:maintainer "Raghunandan Rao" . "r.raghunandan@gmail.com"))]) (toggle-window . [(20141207 1548) nil "Toggle current window size between half and full" tar ((:url . "https://github.com/deadghost/toggle-window") (:commit . "e82c60e543933880402ede11e9423e48a17dde53") (:revdesc . "e82c60e54393") (:keywords "hide" "window"))]) - (tok-theme . [(20241030 609) ((emacs (27 0))) "Minimal monochromatic theme for Emacs in the spirit of Zmacs and Smalltalk-80" tar ((:url . "https://github.com/topikettunen/tok-theme") (:commit . "6b6df61e4bc0c3001a45c77e7ad52d8726ac5463") (:revdesc . "6b6df61e4bc0") (:authors ("Topi Kettunen" . "topi@topikettunen.com")) (:maintainers ("Topi Kettunen" . "topi@topikettunen.com")) (:maintainer "Topi Kettunen" . "topi@topikettunen.com"))]) + (tok-theme . [(20241114 1637) ((emacs (27 0))) "Minimal monochromatic theme for Emacs in the spirit of Zmacs and Smalltalk-80" tar ((:url . "https://github.com/topikettunen/tok-theme") (:commit . "fa495ad556079af8efff758d3705dbf22ca64ca1") (:revdesc . "fa495ad55607") (:authors ("Topi Kettunen" . "topi@topikettunen.com")) (:maintainers ("Topi Kettunen" . "topi@topikettunen.com")) (:maintainer "Topi Kettunen" . "topi@topikettunen.com"))]) (tokei . [(20220823 2058) ((emacs (27 1)) (magit-section (3 3 0))) "Display codebase statistics" tar ((:url . "https://github.com/nagy/tokei.el") (:commit . "86fbca422f580a95eb30247e46891184f3ac5c18") (:revdesc . "86fbca422f58") (:authors ("Daniel Nagy" . "https://github.com/nagy")) (:maintainers ("Daniel Nagy" . "danielnagy@posteo.de")) (:maintainer "Daniel Nagy" . "danielnagy@posteo.de"))]) (tomatinho . [(20180621 1748) nil "Simple and beautiful pomodoro timer" tar ((:url . "https://github.com/konr/tomatinho") (:commit . "b53354b9b9f496c0388d6a573b06b7d6fc53d0bd") (:revdesc . "b53354b9b9f4") (:keywords "time" "productivity" "pomodoro technique") (:authors ("Konrad Scorciapino" . "scorciapino@gmail.com")) (:maintainers ("Konrad Scorciapino" . "scorciapino@gmail.com")) (:maintainer "Konrad Scorciapino" . "scorciapino@gmail.com"))]) (toml . [(20230411 1449) nil "TOML (Tom's Obvious, Minimal Language) parser" tar ((:url . "https://github.com/gongo/emacs-toml") (:commit . "ee4a12bfc8c890c5e8b4bfa35837ce672a882967") (:revdesc . "ee4a12bfc8c8") (:keywords "toml" "parser") (:authors ("Wataru MIYAGUNI" . "gonngo@gmail.com")) (:maintainers ("Wataru MIYAGUNI" . "gonngo@gmail.com")) (:maintainer "Wataru MIYAGUNI" . "gonngo@gmail.com"))]) @@ -5327,7 +5328,7 @@ (tramp-term . [(20220725 1441) nil "Automatic setup of directory tracking in ssh sessions" tar ((:url . "https://github.com/cuspymd/tramp-term.el") (:commit . "ed75189122737d301f716a30a8013205aa3736f1") (:revdesc . "ed7518912273") (:keywords "comm" "terminals") (:authors ("Randy Morris" . "randy.morris@archlinux.us")) (:maintainers ("Randy Morris" . "randy.morris@archlinux.us")) (:maintainer "Randy Morris" . "randy.morris@archlinux.us"))]) (transducers . [(20241103 35) ((emacs (28 1))) "Ergonomic, efficient data processing" tar ((:url . "https://github.com/fosskers/transducers.el") (:commit . "f8f46db6ddba6641669160fffb3f98213ab5b213") (:revdesc . "f8f46db6ddba") (:keywords "lisp") (:authors ("Colin Woodbury" . "colin@fosskers.ca")) (:maintainers ("Colin Woodbury" . "colin@fosskers.ca")) (:maintainer "Colin Woodbury" . "colin@fosskers.ca"))]) (transfer-sh . [(20200601 1708) ((emacs (24 3)) (async (1 0))) "Simple interface for sending buffer contents to transfer.sh" tar ((:url . "https://gitlab.com/tuedachu/transfer-sh.el") (:commit . "0621a66d00ec91a209a542c10b158095088bd44d") (:revdesc . "0621a66d00ec") (:keywords "comm" "convenience" "files"))]) - (transient . [(20241111 1438) ((emacs (26 1)) (compat (30 0 0 0)) (seq (2 24))) "Transient commands" tar ((:url . "https://github.com/magit/transient") (:commit . "d90d65b822001fa6f4a85e5fa65b3fddffa43942") (:revdesc . "d90d65b82200") (:keywords "extensions") (:authors ("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev"))]) + (transient . [(20241115 2034) ((emacs (26 1)) (compat (30 0 0 0)) (seq (2 24))) "Transient commands" tar ((:url . "https://github.com/magit/transient") (:commit . "291b86e66de3d7b73384f8751050acbdd2187ddb") (:revdesc . "291b86e66de3") (:keywords "extensions") (:authors ("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) (:maintainers ("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) (:maintainer "Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev"))]) (transient-dwim . [(20221225 1630) ((emacs (26 1)) (transient (0 1))) "Useful preset transient commands" tar ((:url . "https://github.com/conao3/transient-dwim.el") (:commit . "cb5e0d35729fc6448553b7a17fc5c843f00e8c1d") (:revdesc . "cb5e0d35729f") (:keywords "tools") (:authors ("Naoya Yamashita" . "conao3@gmail.com")) (:maintainers ("Naoya Yamashita" . "conao3@gmail.com")) (:maintainer "Naoya Yamashita" . "conao3@gmail.com"))]) (transient-extras . [(20230721 839) ((emacs (28 1))) "Extra features for transient" tar ((:url . "https://github.com/haji-ali/transient-extras") (:commit . "ca0d5c597382615f0ee8300ff8718f54f8214359") (:revdesc . "ca0d5c597382") (:keywords "convenience") (:authors ("Al Haji-Ali" . "abdo.haji.ali@gmail.com") ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainers ("Al Haji-Ali" . "abdo.haji.ali@gmail.com") ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainer "Al Haji-Ali" . "abdo.haji.ali@gmail.com"))]) (transient-extras-a2ps . [(20230303 1511) ((emacs (28 1)) (transient-extras (1 0 0))) "A transient interface to a2ps" tar ((:url . "https://github.com/haji-ali/transient-extras") (:commit . "e91a1cddb1f0cb8b99d2bd30db64d467e5fa7ea8") (:revdesc . "e91a1cddb1f0") (:keywords "convenience") (:authors ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainers ("Samuel W. Flint" . "swflint@flintfam.org")) (:maintainer "Samuel W. Flint" . "swflint@flintfam.org"))]) @@ -5435,7 +5436,7 @@ (unidecode . [(20201213 1449) nil "Transliterate Unicode to ASCII" tar ((:url . "https://github.com/sindikat/unidecode") (:commit . "525b51b38f5b0435642005957740fe22ecb2a53c") (:revdesc . "525b51b38f5b") (:authors ("sindikat" . "sindikatatmail36dotnet")) (:maintainers ("John Mastro" . "john.b.mastro@gmail.com")) (:maintainer "John Mastro" . "john.b.mastro@gmail.com"))]) (unifdef . [(20200517 514) nil "Delete code guarded by processor directives" tar ((:url . "https://github.com/Lindydancer/unifdef") (:commit . "7a4b76f664c4375e3d98e8af0a29270752c13701") (:revdesc . "7a4b76f664c4") (:keywords "convenience" "languages"))]) (unify-opening . [(20230903 844) ((emacs (24 4))) "Unify the mechanism to open files" tar ((:url . "https://github.com/DamienCassou/unify-opening") (:commit . "282ce0e35ecebbe602bec6f8d64f0192d8a18342") (:revdesc . "282ce0e35ece") (:authors ("Damien Cassou" . "damien.cassou@gmail.com")) (:maintainers ("Damien Cassou" . "damien.cassou@gmail.com")) (:maintainer "Damien Cassou" . "damien.cassou@gmail.com"))]) - (uniline . [(20241109 1405) ((emacs (29 1)) (hydra (0 15 0))) "Draw UNICODE lines, boxes, arrows onto existing text" tar ((:url . "https://github.com/tbanel/uniline") (:commit . "48854038e0fda231573ef4c1448594781749f732") (:revdesc . "48854038e0fd") (:keywords "convenience" "text"))]) + (uniline . [(20241116 1149) ((emacs (29 1)) (hydra (0 15 0))) "Draw UNICODE lines, boxes, arrows onto existing text" tar ((:url . "https://github.com/tbanel/uniline") (:commit . "7f94b02530fc7ad4da2f540d8afaddbb963f7eb8") (:revdesc . "7f94b02530fc") (:keywords "convenience" "text"))]) (unipoint . [(20140113 2224) nil "A simple way to insert unicode characters by TeX name" tar ((:url . "https://github.com/apg/unipoint") (:commit . "5da04aebac35a5c9e1d8704f2231808d42f4b36a") (:revdesc . "5da04aebac35") (:authors ("Andrew Gwozdziewycz" . "git@apgwoz.com")) (:maintainers ("Andrew Gwozdziewycz" . "git@apgwoz.com")) (:maintainer "Andrew Gwozdziewycz" . "git@apgwoz.com"))]) (unison . [(20160704 740) ((emacs (24 1))) "Sync with Unison" tar ((:url . "https://github.com/unhammer/unison.el") (:commit . "a78a04c0d1398d00f75a1bd4799622a65bcb0f28") (:revdesc . "a78a04c0d139") (:keywords "sync") (:authors ("Kevin Brubeck Unhammer" . "unhammer@fsfe.org")) (:maintainers ("Kevin Brubeck Unhammer" . "unhammer@fsfe.org")) (:maintainer "Kevin Brubeck Unhammer" . "unhammer@fsfe.org"))]) (unison-mode . [(20160513 1501) nil "Syntax highlighting for unison file synchronization program" tar ((:url . "https://github.com/impaktor/unison-mode") (:commit . "0bd6a65c0d12f87fcf7bdff15fe54444959b93bf") (:revdesc . "0bd6a65c0d12") (:keywords "symchronization" "unison") (:authors ("Karl Fogelmark" . "karlfogel@gmail.com")) (:maintainers ("Karl Fogelmark" . "karlfogel@gmail.com")) (:maintainer "Karl Fogelmark" . "karlfogel@gmail.com"))]) @@ -5460,7 +5461,7 @@ (ursa-ts-mode . [(20240927 1611) ((emacs (29 1))) "Major mode for Ursa, using tree-sitter" tar ((:url . "https://github.com/ursalang/ursa-ts-mode") (:commit . "9d2b4059511979fb9d09b3287b8fc64b510adbd1") (:revdesc . "9d2b40595119") (:keywords "ursalang" "languages" "tree-sitter") (:authors ("Reuben Thomas" . "rrt@sc3d.org")) (:maintainers ("Reuben Thomas" . "rrt@sc3d.org")) (:maintainer "Reuben Thomas" . "rrt@sc3d.org"))]) (urscript-mode . [(20190219 1604) ((emacs (24 4))) "Major mode for editing URScript" tar ((:url . "https://github.com/guidoschmidt/urscript-mode") (:commit . "b341f96b129ead8fb74d680cb4f546985bf110a9") (:revdesc . "b341f96b129e") (:keywords "languages") (:authors ("Guido Schmidt" . "(git@guidoschmidt.cc)")) (:maintainers ("Guido Schmidt" . "(git@guidoschmidt.cc)")) (:maintainer "Guido Schmidt" . "(git@guidoschmidt.cc)"))]) (usage-memo . [(20170926 37) nil "Integration of Emacs help system and memo" tar ((:url . "https://github.com/rubikitch/usage-memo") (:commit . "88e15a9942a3e0a6e36e9c3e51e3edb746067b1a") (:revdesc . "88e15a9942a3") (:keywords "convenience" "languages" "lisp" "help" "tools" "docs") (:authors ("rubikitch" . "rubikitch@ruby-lang.org")) (:maintainers ("rubikitch" . "rubikitch@ruby-lang.org")) (:maintainer "rubikitch" . "rubikitch@ruby-lang.org"))]) - (use-package-chords . [(20221117 1610) ((use-package (2 1)) (bind-key (1 0)) (bind-chord (0 2)) (key-chord (0 6))) "Key-chord keyword for use-package" tar ((:url . "https://github.com/jwiegley/use-package") (:commit . "9090080b15486c3e337be254226efe7e5fde4c99") (:revdesc . "9090080b1548") (:keywords "convenience" "tools" "extensions") (:authors ("Justin Talbott" . "justin@waymondo.com")) (:maintainers ("Justin Talbott" . "justin@waymondo.com")) (:maintainer "Justin Talbott" . "justin@waymondo.com"))]) + (use-package-chords . [(20241115 2228) ((use-package (2 1)) (bind-key (1 0)) (bind-chord (0 2)) (key-chord (0 6))) "Key-chord keyword for use-package" tar ((:url . "https://github.com/waymondo/use-package-chords") (:commit . "a2b16a1e64b19ae9428a6cd8f3e09b8159707a29") (:revdesc . "a2b16a1e64b1") (:keywords "convenience" "tools" "extensions") (:authors ("Justin Talbott" . "justin@waymondo.com")) (:maintainers ("Justin Talbott" . "justin@waymondo.com")) (:maintainer "Justin Talbott" . "justin@waymondo.com"))]) (use-package-hydra . [(20181228 745) ((emacs (24 3)) (use-package (2 4))) "Adds :hydra keyword to use-package macro" tar ((:url . "https://gitlab.com/to1ne/use-package-hydra") (:commit . "8cd55a1128fbdf6327bb38a199d206225896d146") (:revdesc . "8cd55a1128fb") (:keywords "convenience" "extensions" "tools") (:authors ("Toon Claes" . "toon@iotcl.com")) (:maintainers ("Toon Claes" . "toon@iotcl.com")) (:maintainer "Toon Claes" . "toon@iotcl.com"))]) (use-proxy . [(20201209 853) ((exec-path-from-shell (1 12)) (emacs (26 2))) "Enable/Disable proxies respecting your HTTP/HTTPS env" tar ((:url . "https://github.com/rayw000/use-proxy") (:commit . "43499194224483b27628fdf99f6f9ff6e731d844") (:revdesc . "434991942244") (:keywords "proxy" "comm") (:authors ("Ray Wang" . "ray.hackmylife@gmail.com")) (:maintainers ("Ray Wang" . "ray.hackmylife@gmail.com")) (:maintainer "Ray Wang" . "ray.hackmylife@gmail.com"))]) (use-ttf . [(20240401 611) ((emacs (26 1))) "Keep font consistency across different OSs" tar ((:url . "https://github.com/jcs-elpa/use-ttf") (:commit . "694282b9ba7669fcbceb7088808147f68e3ac066") (:revdesc . "694282b9ba76") (:keywords "convenience" "customize" "font" "install" "ttf") (:authors ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainers ("Jen-Chieh" . "jcs090218@gmail.com")) (:maintainer "Jen-Chieh" . "jcs090218@gmail.com"))]) @@ -5695,7 +5696,7 @@ (wwtime . [(20151122 1610) nil "Insert a time of day with appropriate world-wide localization" tar ((:url . "https://github.com/ndw/wwtime") (:commit . "d04d8fa814b5d3644efaeb28f25520ada69acbbd") (:revdesc . "d04d8fa814b5") (:keywords "time") (:authors ("Norman Walsh" . "ndw@nwalsh.com")) (:maintainers ("Norman Walsh" . "ndw@nwalsh.com")) (:maintainer "Norman Walsh" . "ndw@nwalsh.com"))]) (www-synonyms . [(20170128 2251) ((request (0 2 0)) (cl-lib (0 5))) "Insert synonym for a word" tar ((:url . "https://github.com/spebern/www-synonyms") (:commit . "7e37ea35064ff31c9945f0198a653647d408c936") (:revdesc . "7e37ea35064f") (:keywords "lisp") (:authors ("Bernhard Specht" . "bernhard@specht.net")) (:maintainers ("Bernhard Specht" . "bernhard@specht.net")) (:maintainer "Bernhard Specht" . "bernhard@specht.net"))]) (x-path-walker . [(20220714 1056) ((helm-core (3 6 0))) "Navigation feature for JSON/XML/HTML based on path (imenu like)" tar ((:url . "https://github.com/Lompik/x-path-walker") (:commit . "c91deaaba0d5cc9018008a39c96222deacba3868") (:revdesc . "c91deaaba0d5") (:keywords "convenience") (:authors (nil . "lompik@ArchOrion")) (:maintainers (nil . "lompik@ArchOrion")) (:maintainer nil . "lompik@ArchOrion"))]) - (x509-mode . [(20241113 1733) ((emacs (25 1)) (compat (29 1 4 2))) "View certificates, CRLs and keys using OpenSSL" tar ((:url . "https://github.com/jobbflykt/x509-mode") (:commit . "72719e38a98d780d6da4f17ebdc2941c9b734039") (:revdesc . "72719e38a98d") (:authors ("Fredrik Axelsson" . "f.axelsson@gmail.com")) (:maintainers ("Fredrik Axelsson" . "f.axelsson@gmail.com")) (:maintainer "Fredrik Axelsson" . "f.axelsson@gmail.com"))]) + (x509-mode . [(20241116 1230) ((emacs (25 1)) (compat (29 1 4 2))) "View certificates, CRLs and keys using OpenSSL" tar ((:url . "https://github.com/jobbflykt/x509-mode") (:commit . "b30bc5e91b28ade6802d80513954a7ec4f025db2") (:revdesc . "b30bc5e91b28") (:authors ("Fredrik Axelsson" . "f.axelsson@gmail.com")) (:maintainers ("Fredrik Axelsson" . "f.axelsson@gmail.com")) (:maintainer "Fredrik Axelsson" . "f.axelsson@gmail.com"))]) (x86-lookup . [(20240823 1135) ((emacs (24 3)) (cl-lib (0 3))) "Jump to x86 instruction documentation" tar ((:url . "https://github.com/skeeto/x86-lookup") (:commit . "0a6e4faceb3c313c3ee0ac4b086326a7553c1d8b") (:revdesc . "0a6e4faceb3c") (:authors ("Christopher Wellons" . "wellons@nullprogram.com")) (:maintainers ("Christopher Wellons" . "wellons@nullprogram.com")) (:maintainer "Christopher Wellons" . "wellons@nullprogram.com"))]) (xbm-life . [(20210508 1640) ((emacs (24 1))) "A XBM version of Conway's Game of Life" tar ((:url . "https://depp.brause.cc/xbm-life.git") (:commit . "ec6abb0182068294a379cb49ad5346b1d757457d") (:revdesc . "ec6abb018206") (:keywords "games") (:authors ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainers ("Vasilij Schneidermann" . "mail@vasilij.de")) (:maintainer "Vasilij Schneidermann" . "mail@vasilij.de"))]) (xcode-mode . [(20160907 1208) ((emacs (24 4)) (s (1 10 0)) (dash (2 11 0)) (multiple-cursors (1 0 0))) "A minor mode for emacs to perform Xcode like actions" tar ((:url . "https://github.com/nicklanasa/xcode-mode") (:commit . "5b5f0a4f505d44840a4924b24e3ef73b8528d98b") (:revdesc . "5b5f0a4f505d") (:keywords "conveniences") (:authors ("Nickolas Lanasa" . "nick@nytekproductions.com")) (:maintainers ("Nickolas Lanasa" . "nick@nytekproductions.com")) (:maintainer "Nickolas Lanasa" . "nick@nytekproductions.com"))]) diff --git a/emacs/elpa/archives/nongnu/archive-contents b/emacs/elpa/archives/nongnu/archive-contents @@ -2015,7 +2015,7 @@ ("David Christiansen" . "david@davidchristiansen.dk")) (:commit . "1edda80e2e32b72e77f4f16ae5b83c312c68ee95"))]) (racket-mode . - [(1 0 20241112 143851) + [(1 0 20241116 120019) ((emacs (25 1))) "Racket editing, REPL, and more" tar @@ -2262,14 +2262,14 @@ ("John Olsson" . "john@cryon.se")) (:commit . "2d5acd143a153e16372d59000e57d76291ab81dd"))]) (subed . - [(1 2 18) + [(1 2 19) ((emacs (25 1))) "A major mode for editing subtitles" tar ((:url . "https://github.com/sachac/subed") (:keywords "convenience" "files" "hypermedia" "multimedia") (:maintainer "Sacha Chua" . "sacha@sachachua.com") - (:commit . "98c431e8789789273ca476091f15e53247f86a03"))]) + (:commit . "a8b755bbfd6f0bbffcff361531cd36bc842dd733"))]) (sweeprolog . [(0 27 6) ((emacs diff --git a/emacs/elpa/archives/nongnu/archive-contents.signed b/emacs/elpa/archives/nongnu/archive-contents.signed @@ -1 +1 @@ -Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) <elpasign@elpa.gnu.org> (trust undefined) created at 2024-11-13T22:05:09+0000 using EDDSA -\ No newline at end of file +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) <elpasign@elpa.gnu.org> (trust undefined) created at 2024-11-17T10:05:05+0000 using EDDSA +\ No newline at end of file diff --git a/emacs/elpa/consult-20241105.2133/consult-org.elc b/emacs/elpa/consult-20241105.2133/consult-org.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-pkg.el b/emacs/elpa/consult-20241105.2133/consult-pkg.el @@ -1,10 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "consult" "20241105.2133" - "Consulting completing-read." - '((emacs "28.1") - (compat "30")) - :url "https://github.com/minad/consult" - :commit "7a7af8dcdda02b9aa4a680a228b3f3a5cfa95334" - :revdesc "7a7af8dcdda0" - :keywords '("matching" "files" "completion") - :maintainers '(("Daniel Mendler" . "mail@daniel-mendler.de"))) diff --git a/emacs/elpa/consult-20241105.2133/consult.el b/emacs/elpa/consult-20241105.2133/consult.el @@ -1,5248 +0,0 @@ -;;; consult.el --- Consulting completing-read -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2024 Free Software Foundation, Inc. - -;; Author: Daniel Mendler and Consult contributors -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2020 -;; Package-Version: 20241105.2133 -;; Package-Revision: 7a7af8dcdda0 -;; Package-Requires: ((emacs "28.1") (compat "30")) -;; URL: https://github.com/minad/consult -;; Keywords: matching, files, completion - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Consult implements a set of `consult-<thing>' commands, which aim to -;; improve the way you use Emacs. The commands are founded on -;; `completing-read', which selects from a list of candidate strings. -;; Consult provides an enhanced buffer switcher `consult-buffer' and -;; search and navigation commands like `consult-imenu' and -;; `consult-line'. Searching through multiple files is supported by the -;; asynchronous `consult-grep' command. Many Consult commands support -;; previewing candidates. If a candidate is selected in the completion -;; view, the buffer shows the candidate immediately. - -;; The Consult commands are compatible with multiple completion systems -;; based on the Emacs `completing-read' API, including the default -;; completion system, Vertico, Mct and Icomplete. - -;; See the README for an overview of the available Consult commands and -;; the documentation of the configuration and installation of the -;; package. - -;; The full list of contributors can be found in the acknowledgments -;; section of the README. - -;;; Code: - -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) -(require 'compat) -(require 'bookmark) - -(defgroup consult nil - "Consulting `completing-read'." - :link '(info-link :tag "Info Manual" "(consult)") - :link '(url-link :tag "Website" "https://github.com/minad/consult") - :link '(url-link :tag "Wiki" "https://github.com/minad/consult/wiki") - :link '(emacs-library-link :tag "Library Source" "consult.el") - :group 'files - :group 'outlines - :group 'minibuffer - :prefix "consult-") - -;;;; Customization - -(defcustom consult-narrow-key nil - "Prefix key for narrowing during completion. - -Good choices for this key are \"<\" and \"C-+\" for example. The -key must be a string accepted by `key-valid-p'." - :type '(choice key (const :tag "None" nil))) - -(defcustom consult-widen-key nil - "Key used for widening during completion. - -If this key is unset, defaults to twice the `consult-narrow-key'. -The key must be a string accepted by `key-valid-p'." - :type '(choice key (const :tag "None" nil))) - -(defcustom consult-project-function - #'consult--default-project-function - "Function which returns project root directory. -The function takes one boolean argument MAY-PROMPT. If -MAY-PROMPT is non-nil, the function may ask the prompt the user -for a project directory. The root directory is used by -`consult-buffer' and `consult-grep'." - :type `(choice - (const :tag "Default project function" ,#'consult--default-project-function) - (function :tag "Custom function") - (const :tag "No project integration" nil))) - -(defcustom consult-async-refresh-delay 0.2 - "Refreshing delay of the completion UI for asynchronous commands. - -The completion UI is only updated every -`consult-async-refresh-delay' seconds. This applies to -asynchronous commands like for example `consult-grep'." - :type '(float :tag "Delay in seconds")) - -(defcustom consult-async-input-throttle 0.5 - "Input throttle for asynchronous commands. - -The asynchronous process is started only every -`consult-async-input-throttle' seconds. This applies to asynchronous -commands, e.g., `consult-grep'." - :type '(float :tag "Delay in seconds")) - -(defcustom consult-async-input-debounce 0.2 - "Input debounce for asynchronous commands. - -The asynchronous process is started only when there has not been new -input for `consult-async-input-debounce' seconds. This applies to -asynchronous commands, e.g., `consult-grep'." - :type '(float :tag "Delay in seconds")) - -(defcustom consult-async-min-input 3 - "Minimum number of characters needed, before asynchronous process is called. - -This applies to asynchronous commands, e.g., `consult-grep'." - :type '(natnum :tag "Number of characters")) - -(defcustom consult-async-split-style 'perl - "Async splitting style, see `consult-async-split-styles-alist'." - :type '(choice (const :tag "No splitting" nil) - (const :tag "Comma" comma) - (const :tag "Semicolon" semicolon) - (const :tag "Perl" perl))) - -(defcustom consult-async-split-styles-alist - `((nil :function ,#'consult--split-nil) - (comma :separator ?, :function ,#'consult--split-separator) - (semicolon :separator ?\; :function ,#'consult--split-separator) - (perl :initial "#" :function ,#'consult--split-perl)) - "Async splitting styles." - :type '(alist :key-type symbol :value-type plist)) - -(defcustom consult-mode-histories - '((eshell-mode eshell-history-ring eshell-history-index eshell-bol) - (comint-mode comint-input-ring comint-input-ring-index comint-bol) - (term-mode term-input-ring term-input-ring-index term-bol)) - "Alist of mode histories (mode history index bol). -The histories can be rings or lists. Index, if provided, is a -variable to set to the index of the selection within the ring or -list. Bol, if provided is a function which jumps to the beginning -of the line after the prompt." - :type '(alist :key-type symbol - :value-type (group :tag "Include Index" - (symbol :tag "List/Ring") - (symbol :tag "Index Variable") - (symbol :tag "Bol Function")))) - -(defcustom consult-themes nil - "List of themes (symbols or regexps) to be presented for selection. -nil shows all `custom-available-themes'." - :type '(repeat (choice symbol regexp))) - -(defcustom consult-after-jump-hook (list #'recenter) - "Function called after jumping to a location. - -Commonly used functions for this hook are `recenter' and -`reposition-window'. You may want to add a function which pulses the -current line, e.g., `pulse-momentary-highlight-one-line'. The hook -called during preview and for the jump after selection." - :type 'hook) - -(defcustom consult-line-start-from-top nil - "Start search from the top if non-nil. -Otherwise start the search at the current line and wrap around." - :type 'boolean) - -(defcustom consult-point-placement 'match-beginning - "Where to leave point when jumping to a match. -This setting affects the command `consult-line' and the `consult-grep' variants." - :type '(choice (const :tag "Beginning of the line" line-beginning) - (const :tag "Beginning of the match" match-beginning) - (const :tag "End of the match" match-end))) - -(defcustom consult-line-numbers-widen t - "Show absolute line numbers when narrowing is active. - -See also `display-line-numbers-widen'." - :type 'boolean) - -(defcustom consult-goto-line-numbers t - "Show line numbers for `consult-goto-line'." - :type 'boolean) - -(defcustom consult-fontify-preserve t - "Preserve fontification for line-based commands." - :type 'boolean) - -(defcustom consult-fontify-max-size 1048576 - "Buffers larger than this byte limit are not fontified. - -This is necessary in order to prevent a large startup time -for navigation commands like `consult-line'." - :type '(natnum :tag "Buffer size in bytes")) - -(defcustom consult-buffer-filter - '("\\` " - "\\`\\*Completions\\*\\'" - "\\`\\*Flymake log\\*\\'" - "\\`\\*Semantic SymRef\\*\\'" - "\\`\\*vc\\*\\'" - "\\`newsrc-dribble\\'" ;; Gnus - "\\`\\*tramp/.*\\*\\'") - "Filter regexps for `consult-buffer'. - -The default setting is to filter ephemeral buffer names beginning -with a space character, the *Completions* buffer and a few log -buffers. The regular expressions are matched case sensitively." - :type '(repeat regexp)) - -(defcustom consult-buffer-sources - '(consult--source-hidden-buffer - consult--source-modified-buffer - consult--source-buffer - consult--source-recent-file - consult--source-file-register - consult--source-bookmark - consult--source-project-buffer-hidden - consult--source-project-recent-file-hidden) - "Sources used by `consult-buffer'. -See also `consult-project-buffer-sources'. -See `consult--multi' for a description of the source data structure." - :type '(repeat symbol)) - -(defcustom consult-project-buffer-sources - '(consult--source-project-buffer - consult--source-project-recent-file) - "Sources used by `consult-project-buffer'. -See also `consult-buffer-sources'. -See `consult--multi' for a description of the source data structure." - :type '(repeat symbol)) - -(defcustom consult-mode-command-filter - '(;; Filter commands - "-mode\\'" "--" - ;; Filter whole features - simple mwheel time so-long recentf tab-bar tab-line) - "Filter commands for `consult-mode-command'." - :type '(repeat (choice symbol regexp))) - -(defcustom consult-grep-max-columns 300 - "Maximal number of columns of grep output. -If set to nil, do not truncate candidates. This can have negative -performance implications but helps if you want to export long lines via -`embark-export'." - :type '(choice natnum (const nil))) - -(defconst consult--grep-match-regexp - "\\`\\(?:\\./\\)?\\([^\n\0]+\\)\0\\([0-9]+\\)\\([-:\0]\\)" - "Regexp used to match file and line of grep output.") - -(defcustom consult-grep-args - '("grep" (consult--grep-exclude-args) - "--null --line-buffered --color=never --ignore-case\ - --with-filename --line-number -I -r") - "Command line arguments for grep, see `consult-grep'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-git-grep-args - "git --no-pager grep --null --color=never --ignore-case\ - --extended-regexp --line-number -I" - "Command line arguments for git-grep, see `consult-git-grep'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-ripgrep-args - "rg --null --line-buffered --color=never --max-columns=1000 --path-separator /\ - --smart-case --no-heading --with-filename --line-number --search-zip" - "Command line arguments for ripgrep, see `consult-ripgrep'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-find-args - "find . -not ( -path */.[A-Za-z]* -prune )" - "Command line arguments for find, see `consult-find'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-fd-args - '((if (executable-find "fdfind" 'remote) "fdfind" "fd") - "--full-path --color=never") - "Command line arguments for fd, see `consult-fd'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-locate-args - "locate --ignore-case" ;; --existing not supported by Debian plocate - "Command line arguments for locate, see `consult-locate'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-man-args - "man -k" - "Command line arguments for man, see `consult-man'. -The dynamically computed arguments are appended. -Can be either a string, or a list of strings or expressions." - :type '(choice string (repeat (choice string sexp)))) - -(defcustom consult-preview-key 'any - "Preview trigger keys, can be nil, `any', a single key or a list of keys. -Debouncing can be specified via the `:debounce' attribute. The -individual keys must be strings accepted by `key-valid-p'." - :type '(choice (const :tag "Any key" any) - (list :tag "Debounced" - (const :debounce) - (float :tag "Seconds" 0.1) - (const any)) - (const :tag "No preview" nil) - (key :tag "Key") - (repeat :tag "List of keys" key))) - -(defcustom consult-preview-partial-size 1048576 - "Files larger than this byte limit are previewed partially." - :type '(natnum :tag "File size in bytes")) - -(defcustom consult-preview-partial-chunk 102400 - "Partial preview chunk size in bytes. -If a file is larger than `consult-preview-partial-size' only the -chunk from the beginning of the file is previewed." - :type '(natnum :tag "Chunk size in bytes")) - -(defcustom consult-preview-max-count 10 - "Number of file buffers to keep open temporarily during preview." - :type '(natnum :tag "Number of buffers")) - -(defcustom consult-preview-excluded-buffers nil - "Buffers excluded from preview. -The value should conform to the predicate format demanded by the -function `buffer-match-p'." - :type 'sexp) - -(defcustom consult-preview-excluded-files - '("\\`/[^/|:]+:") ;; Do not preview remote files - "List of regexps matched against names of files, which are not previewed." - :type '(repeat regexp)) - -(defcustom consult-preview-allowed-hooks - '(global-font-lock-mode - save-place-find-file-hook) - "List of hooks, which should be executed during file preview. -This variable applies to `find-file-hook', `change-major-mode-hook' and -mode hooks, e.g., `prog-mode-hook'." - :type '(repeat symbol)) - -(defcustom consult-preview-variables - '((inhibit-message . t) - (enable-dir-local-variables . nil) - (enable-local-variables . :safe) - (non-essential . t) - (delay-mode-hooks . t)) - "Variables which are bound for file preview." - :type '(alist :key-type symbol)) - -(defcustom consult-bookmark-narrow - `((?f "File" bookmark-default-handler) - (?h "Help" help-bookmark-jump Info-bookmark-jump - Man-bookmark-jump woman-bookmark-jump) - (?p "Picture" image-bookmark-jump) - (?d "Docview" doc-view-bookmark-jump) - (?m "Mail" gnus-summary-bookmark-jump) - (?s "Eshell" eshell-bookmark-jump) - (?w "Web" eww-bookmark-jump xwidget-webkit-bookmark-jump-handler) - (?v "VC Directory" vc-dir-bookmark-jump) - (nil "Other")) - "Bookmark narrowing configuration. - -Each element of the list must have the form (char name handlers...)." - :type '(alist :key-type character :value-type (cons string (repeat function)))) - -(define-obsolete-variable-alias - 'consult-yank-rotate 'yank-from-kill-ring-rotate "1.8") - -;;;; Faces - -(defgroup consult-faces nil - "Faces used by Consult." - :group 'consult - :group 'faces) - -(defface consult-preview-line - '((t :inherit consult-preview-insertion :extend t)) - "Face used for line previews.") - -(defface consult-highlight-match - '((t :inherit match)) - "Face used to highlight matches in the completion candidates. -Used for example by `consult-grep'.") - -(defface consult-highlight-mark - '((t :inherit consult-highlight-match)) - "Face used for mark positions in completion candidates. -Used for example by `consult-mark'. The face should be different -than the `cursor' face to avoid confusion.") - -(defface consult-preview-match - '((t :inherit isearch)) - "Face used for match previews, e.g., in `consult-line'.") - -(defface consult-preview-insertion - '((t :inherit region)) - "Face used for previews of text to be inserted. -Used by `consult-completion-in-region', `consult-yank' and `consult-history'.") - -(defface consult-narrow-indicator - '((t :inherit warning)) - "Face used for the narrowing indicator.") - -(defface consult-async-running - '((t :inherit consult-narrow-indicator)) - "Face used if asynchronous process is running.") - -(defface consult-async-finished - '((t :inherit success)) - "Face used if asynchronous process has finished.") - -(defface consult-async-failed - '((t :inherit error)) - "Face used if asynchronous process has failed.") - -(defface consult-async-split - '((t :inherit font-lock-negation-char-face)) - "Face used to highlight punctuation character.") - -(defface consult-help - '((t :inherit shadow)) - "Face used to highlight help, e.g., in `consult-register-store'.") - -(defface consult-key - '((t :inherit font-lock-keyword-face)) - "Face used to highlight keys, e.g., in `consult-register'.") - -(defface consult-line-number - '((t :inherit consult-key)) - "Face used to highlight location line in `consult-global-mark'.") - -(defface consult-file - '((t :inherit font-lock-function-name-face)) - "Face used to highlight files in `consult-buffer'.") - -(defface consult-grep-context - '((t :inherit shadow)) - "Face used to highlight grep context in `consult-grep'.") - -(defface consult-bookmark - '((t :inherit font-lock-constant-face)) - "Face used to highlight bookmarks in `consult-buffer'.") - -(defface consult-buffer - '((t)) - "Face used to highlight buffers in `consult-buffer'.") - -(defface consult-line-number-prefix - '((t :inherit line-number)) - "Face used to highlight line number prefixes.") - -(defface consult-line-number-wrapped - '((t :inherit consult-line-number-prefix :inherit font-lock-warning-face)) - "Face used to highlight line number prefixes after wrap around.") - -(defface consult-separator - '((((class color) (min-colors 88) (background light)) - :foreground "#ccc") - (((class color) (min-colors 88) (background dark)) - :foreground "#333")) - "Face used for thin line separators in `consult-register-window'.") - -;;;; Input history variables - -(defvar consult--path-history nil) -(defvar consult--grep-history nil) -(defvar consult--find-history nil) -(defvar consult--man-history nil) -(defvar consult--line-history nil) -(defvar consult--line-multi-history nil) -(defvar consult--theme-history nil) -(defvar consult--minor-mode-menu-history nil) -(defvar consult--buffer-history nil) - -;;;; Internal variables - -(defvar consult--regexp-compiler - #'consult--default-regexp-compiler - "Regular expression compiler used by `consult-grep' and other commands. -The function must return a list of regular expressions and a highlighter -function.") - -(defvar consult--customize-alist - ;; Disable preview in frames, since `consult--jump-preview' does not properly - ;; clean up. See gh:minad/consult#593. This issue should better be fixed in - ;; `consult--jump-preview'. - `((,#'consult-buffer-other-frame :preview-key nil) - (,#'consult-buffer-other-tab :preview-key nil)) - "Command configuration alist for fine-grained configuration. - -Each element of the list must have the form (command-name plist...). The -options set here will be evaluated and passed to `consult--read', when -called from the corresponding command. Note that the options depend on -the private `consult--read' API and should not be considered as stable -as the public API.") - -(defvar consult--buffer-display #'switch-to-buffer - "Buffer display function.") - -(defvar consult--completion-candidate-hook - (list #'consult--default-completion-minibuffer-candidate - #'consult--default-completion-list-candidate) - "Get candidate from completion system.") - -(defvar consult--completion-refresh-hook nil - "Refresh completion system.") - -(defvar-local consult--preview-function nil - "Minibuffer-local variable which exposes the current preview function. -This function can be called by custom completion systems from -outside the minibuffer.") - -(defvar consult--annotate-align-step 10 - "Round candidate width.") - -(defvar consult--annotate-align-width 0 - "Maximum candidate width used for annotation alignment.") - -(defconst consult--tofu-char #x200000 - "Special character used to encode line prefixes for disambiguation. -We use invalid characters outside the Unicode range.") - -(defconst consult--tofu-range #x100000 - "Special character range.") - -(defvar-local consult--narrow nil - "Current narrowing key.") - -(defvar-local consult--narrow-keys nil - "Narrowing prefixes of the current completion.") - -(defvar-local consult--narrow-predicate nil - "Narrowing predicate of the current completion.") - -(defvar-local consult--narrow-overlay nil - "Narrowing indicator overlay.") - -(defvar consult--gc-threshold (* 64 1024 1024) - "Large GC threshold for temporary increase.") - -(defvar consult--gc-percentage 0.5 - "Large GC percentage for temporary increase.") - -(defvar consult--process-chunk (* 1024 1024) - "Increase process output chunk size.") - -(defvar consult--async-log - " *consult-async*" - "Buffer for async logging output used by `consult--async-process'.") - -(defvar-local consult--focus-lines-overlays nil - "Overlays used by `consult-focus-lines'.") - -(defvar-local consult--org-fold-regions nil - "Stored regions for the org-fold API.") - -;;;; Miscellaneous helper functions - -(defun consult--key-parse (key) - "Parse KEY or signal error if invalid." - (unless (key-valid-p key) - (error "%S is not a valid key definition; see `key-valid-p'" key)) - (key-parse key)) - -(defun consult--in-buffer (fun &optional buffer) - "Ensure that FUN is executed inside BUFFER." - (unless buffer (setq buffer (current-buffer))) - (lambda (&rest args) - (with-current-buffer buffer - (apply fun args)))) - -(defun consult--completion-table-in-buffer (table &optional buffer) - "Ensure that completion TABLE is executed inside BUFFER." - (if (functionp table) - (consult--in-buffer - (lambda (str pred action) - (let ((result (funcall table str pred action))) - (pcase action - ('metadata - (setq result - (mapcar - (lambda (x) - (if (and (string-suffix-p "-function" (symbol-name (car-safe x))) (cdr x)) - (cons (car x) (consult--in-buffer (cdr x))) - x)) - result))) - ((and 'completion--unquote (guard (functionp (cadr result)))) - (cl-callf consult--in-buffer (cadr result) buffer) - (cl-callf consult--in-buffer (cadddr result) buffer))) - result)) - buffer) - table)) - -(defun consult--build-args (arg) - "Return ARG as a flat list of split strings. - -Turn ARG into a list, and for each element either: -- split it if it a string. -- eval it if it is an expression." - (seq-mapcat (lambda (x) - (if (stringp x) - (split-string-and-unquote x) - (ensure-list (eval x 'lexical)))) - (ensure-list arg))) - -(defun consult--command-split (str) - "Return command argument and options list given input STR." - (save-match-data - (let ((opts (when (string-match " +--\\( +\\|\\'\\)" str) - (prog1 (substring str (match-end 0)) - (setq str (substring str 0 (match-beginning 0))))))) - ;; split-string-and-unquote fails if the quotes are invalid. Ignore it. - (cons str (and opts (ignore-errors (split-string-and-unquote opts))))))) - -(defmacro consult--keep! (list form) - "Evaluate FORM for every element of LIST and keep the non-nil results." - (declare (indent 1)) - (cl-with-gensyms (head prev result) - `(let* ((,head (cons nil ,list)) - (,prev ,head)) - (while (cdr ,prev) - (if-let (,result (let ((it (cadr ,prev))) ,form)) - (progn - (pop ,prev) - (setcar ,prev ,result)) - (setcdr ,prev (cddr ,prev)))) - (setq ,list (cdr ,head)) - nil))) - -(defun consult--completion-filter (pattern cands category _highlight) - "Filter CANDS with PATTERN. - -CATEGORY is the completion category, used to find the completion style via -`completion-category-defaults' and `completion-category-overrides'. -HIGHLIGHT must be non-nil if the resulting strings should be highlighted." - ;; completion-all-completions returns an improper list - ;; where the last link is not necessarily nil. - (nconc (completion-all-completions pattern cands nil (length pattern) - `(metadata (category . ,category))) - nil)) - -(defun consult--completion-filter-complement (pattern cands category _highlight) - "Filter CANDS with complement of PATTERN. -See `consult--completion-filter' for the arguments CATEGORY and HIGHLIGHT." - (let ((ht (consult--string-hash (consult--completion-filter pattern cands category nil)))) - (seq-remove (lambda (x) (gethash x ht)) cands))) - -(defun consult--completion-filter-dispatch (pattern cands category highlight) - "Filter CANDS with PATTERN with optional complement. -Either using `consult--completion-filter' or -`consult--completion-filter-complement', depending on if the pattern starts -with a bang. See `consult--completion-filter' for the arguments CATEGORY and -HIGHLIGHT." - (cond - ((string-match-p "\\`!? ?\\'" pattern) cands) ;; empty pattern - ((string-prefix-p "! " pattern) (consult--completion-filter-complement - (substring pattern 2) cands category nil)) - (t (consult--completion-filter pattern cands category highlight)))) - -(defmacro consult--each-line (beg end &rest body) - "Iterate over each line. - -The line beginning/ending BEG/END is bound in BODY." - (declare (indent 2)) - (cl-with-gensyms (max) - `(save-excursion - (let ((,beg (point-min)) (,max (point-max)) ,end) - (while (< ,beg ,max) - (goto-char ,beg) - (setq ,end (pos-eol)) - ,@body - (setq ,beg (1+ ,end))))))) - -(defun consult--display-width (string) - "Compute width of STRING taking display and invisible properties into account." - (let ((pos 0) (width 0) (end (length string))) - (while (< pos end) - (let ((nextd (next-single-property-change pos 'display string end)) - (display (get-text-property pos 'display string))) - (if (stringp display) - (setq width (+ width (string-width display)) - pos nextd) - (while (< pos nextd) - (let ((nexti (next-single-property-change pos 'invisible string nextd))) - (unless (get-text-property pos 'invisible string) - (setq width (+ width (string-width string pos nexti)))) - (setq pos nexti)))))) - width)) - -(defun consult--string-hash (strings) - "Create hash table from STRINGS." - (let ((ht (make-hash-table :test #'equal :size (length strings)))) - (dolist (str strings) - (puthash str t ht)) - ht)) - -(defmacro consult--local-let (binds &rest body) - "Buffer local let BINDS of dynamic variables in BODY." - (declare (indent 1)) - (let ((buffer (gensym "buffer")) - (local (mapcar (lambda (x) (cons (gensym "local") (car x))) binds))) - `(let ((,buffer (current-buffer)) - ,@(mapcar (lambda (x) `(,(car x) (local-variable-p ',(cdr x)))) local)) - (unwind-protect - (progn - ,@(mapcar (lambda (x) `(make-local-variable ',(car x))) binds) - (let (,@binds) - ,@body)) - (when (buffer-live-p ,buffer) - (with-current-buffer ,buffer - ,@(mapcar (lambda (x) - `(unless ,(car x) - (kill-local-variable ',(cdr x)))) - local))))))) - -(defvar consult--fast-abbreviate-file-name nil) -(defun consult--fast-abbreviate-file-name (name) - "Return abbreviate file NAME. -This function is a pure variant of `abbreviate-file-name', which -does not access the file system. This is important if we require -that the operation is fast, even for remote paths or paths on -network file systems." - (save-match-data - (let (case-fold-search) ;; Assume that file system is case sensitive. - (setq name (directory-abbrev-apply name)) - (if (string-match (with-memoization consult--fast-abbreviate-file-name - (directory-abbrev-make-regexp (expand-file-name "~"))) - name) - (concat "~" (substring name (match-beginning 1))) - name)))) - -(defun consult--left-truncate-file (file) - "Return abbreviated file name of FILE for use in `completing-read' prompt." - (save-match-data - (let ((file (directory-file-name (abbreviate-file-name file))) - (prefix nil)) - (when (string-match "\\`/\\([^/|:]+:\\)" file) - (setq prefix (propertize (match-string 1 file) 'face 'error) - file (substring file (match-end 0)))) - (when (and (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" file) - (< (- (match-end 0) (match-beginning 0) -3) (length file))) - (setq file (format "…/%s/%s" (match-string 1 file) (match-string 2 file)))) - (concat prefix file)))) - -(defun consult--directory-prompt (prompt dir) - "Return prompt, paths and default directory. - -PROMPT is the prompt prefix. The directory is appended to the -prompt prefix. For projects only the project name is shown. The -`default-directory' is not shown. Other directories are -abbreviated and only the last two path components are shown. - -If DIR is a string, it is returned as default directory. If DIR -is a list of strings, the list is returned as search paths. If -DIR is nil the `consult-project-function' is tried to retrieve -the default directory. If no project is found the -`default-directory' is returned as is. Otherwise the user is -asked for the directories or files to search via -`completing-read-multiple'." - (let* ((paths nil) - (dir - (pcase dir - ((pred stringp) dir) - ((or 'nil '(16)) (or (consult--project-root dir) default-directory)) - (_ - (pcase (if (stringp (car-safe dir)) - dir - ;; Preserve this-command across `completing-read-multiple' call, - ;; such that `consult-customize' continues to work. - (let ((this-command this-command) - (def (abbreviate-file-name default-directory)) - ;; TODO: `minibuffer-completing-file-name' is - ;; mostly deprecated, but still in use. Packages - ;; should instead use the completion metadata. - (minibuffer-completing-file-name t) - (ignore-case read-file-name-completion-ignore-case)) - (minibuffer-with-setup-hook - (lambda () - (setq-local completion-ignore-case ignore-case) - (set-syntax-table minibuffer-local-filename-syntax)) - (completing-read-multiple "Directories or files: " - #'completion-file-name-table - nil t def 'consult--path-history def)))) - ((and `(,p) (guard (file-directory-p p))) p) - (ps (setq paths (mapcar (lambda (p) - (file-relative-name (expand-file-name p))) - ps)) - default-directory))))) - (edir (file-name-as-directory (expand-file-name dir))) - (pdir (let ((default-directory edir)) - ;; Bind default-directory in order to find the project - (consult--project-root)))) - (list - (format "%s (%s): " prompt - (pcase paths - ((guard (<= 1 (length paths) 2)) - (string-join (mapcar #'consult--left-truncate-file paths) ", ")) - (`(,p . ,_) - (format "%d paths, %s, …" (length paths) (consult--left-truncate-file p))) - ((guard (equal edir pdir)) (concat "Project " (consult--project-name pdir))) - (_ (consult--left-truncate-file edir)))) - (or paths '(".")) - edir))) - -(declare-function project-current "project") -(declare-function project-root "project") - -(defun consult--default-project-function (may-prompt) - "Return project root directory. -When no project is found and MAY-PROMPT is non-nil ask the user." - (when-let (proj (project-current may-prompt)) - (project-root proj))) - -(defun consult--project-root (&optional may-prompt) - "Return project root as absolute path. -When no project is found and MAY-PROMPT is non-nil ask the user." - ;; Preserve this-command across project selection, - ;; such that `consult-customize' continues to work. - (let ((this-command this-command)) - (when-let (root (and consult-project-function - (funcall consult-project-function may-prompt))) - (expand-file-name root)))) - -(defun consult--project-name (dir) - "Return the project name for DIR." - (if (string-match "/\\([^/]+\\)/\\'" dir) - (propertize (match-string 1 dir) 'help-echo (abbreviate-file-name dir)) - dir)) - -(defun consult--format-file-line-match (file line match) - "Format string FILE:LINE:MATCH with faces." - (setq line (number-to-string line) - match (concat file ":" line ":" match) - file (length file)) - (put-text-property 0 file 'face 'consult-file match) - (put-text-property (1+ file) (+ 1 file (length line)) 'face 'consult-line-number match) - match) - -(defun consult--make-overlay (beg end &rest props) - "Make consult overlay between BEG and END with PROPS." - (let ((ov (make-overlay beg end))) - (while props - (overlay-put ov (car props) (cadr props)) - (setq props (cddr props))) - ov)) - -(defun consult--remove-dups (list) - "Remove duplicate strings from LIST." - (delete-dups (copy-sequence list))) - -(defsubst consult--in-range-p (pos) - "Return t if position POS lies in range `point-min' to `point-max'." - (<= (point-min) pos (point-max))) - -(defun consult--completion-window-p () - "Return non-nil if the selected window belongs to the completion UI." - (or (eq (selected-window) (active-minibuffer-window)) - (eq #'completion-list-mode (buffer-local-value 'major-mode (window-buffer))))) - -(defun consult--original-window () - "Return window which was just selected just before the minibuffer was entered. -In contrast to `minibuffer-selected-window' never return nil and -always return an appropriate non-minibuffer window." - (or (minibuffer-selected-window) - (if (window-minibuffer-p (selected-window)) - (next-window) - (selected-window)))) - -(defun consult--forbid-minibuffer () - "Raise an error if executed from the minibuffer." - (when (minibufferp) - (user-error "`%s' called inside the minibuffer" this-command))) - -(defun consult--require-minibuffer () - "Raise an error if executed outside the minibuffer." - (unless (minibufferp) - (user-error "`%s' must be called inside the minibuffer" this-command))) - -(defun consult--fontify-all () - "Ensure that the whole buffer is fontified." - ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the line - ;; is not font-locked. We would observe this if consulting an unfontified - ;; line. Therefore we have to enforce font-locking now, which is slow. In - ;; order to prevent is hang-up we check the buffer size against - ;; `consult-fontify-max-size'. - (when (and consult-fontify-preserve jit-lock-mode - (< (buffer-size) consult-fontify-max-size)) - (jit-lock-fontify-now))) - -(defun consult--fontify-region (start end) - "Ensure that region between START and END is fontified." - (when (and consult-fontify-preserve jit-lock-mode) - (jit-lock-fontify-now start end))) - -(defmacro consult--with-increased-gc (&rest body) - "Temporarily increase the GC limit in BODY to optimize for throughput." - (cl-with-gensyms (overwrite) - `(let* ((,overwrite (> consult--gc-threshold gc-cons-threshold)) - (gc-cons-threshold (if ,overwrite consult--gc-threshold gc-cons-threshold)) - (gc-cons-percentage (if ,overwrite consult--gc-percentage gc-cons-percentage))) - ,@body))) - -(defmacro consult--slow-operation (message &rest body) - "Show delayed MESSAGE if BODY takes too long. -Also temporarily increase the GC limit via `consult--with-increased-gc'." - (declare (indent 1)) - `(with-delayed-message (1 ,message) - (consult--with-increased-gc ,@body))) - -(defun consult--count-lines (pos) - "Move to position POS and return number of lines." - (let ((line 1)) - (while (< (point) pos) - (forward-line) - (when (<= (point) pos) - (cl-incf line))) - (goto-char pos) - line)) - -(defun consult--marker-from-line-column (buffer line column) - "Get marker in BUFFER from LINE and COLUMN." - (when (buffer-live-p buffer) - (with-current-buffer buffer - (save-excursion - (without-restriction - (goto-char (point-min)) - ;; Location data might be invalid by now! - (ignore-errors - (forward-line (1- line)) - (goto-char (min (+ (point) column) (pos-eol)))) - (point-marker)))))) - -(defun consult--line-prefix (&optional curr-line) - "Annotate `consult-location' candidates with line numbers. -CURR-LINE is the current line number." - (setq curr-line (or curr-line -1)) - (let* ((width (length (number-to-string (line-number-at-pos - (point-max) - consult-line-numbers-widen)))) - (before (format #("%%%dd " 0 6 (face consult-line-number-wrapped)) width)) - (after (format #("%%%dd " 0 6 (face consult-line-number-prefix)) width))) - (lambda (cand) - (let ((line (cdr (get-text-property 0 'consult-location cand)))) - (list cand (format (if (< line curr-line) before after) line) ""))))) - -(defsubst consult--location-candidate (cand marker line tofu &rest props) - "Add MARKER and LINE as `consult-location' text property to CAND. -Furthermore add the additional text properties PROPS, and append -TOFU suffix for disambiguation." - (setq cand (concat cand (consult--tofu-encode tofu))) - (add-text-properties 0 1 `(consult-location (,marker . ,line) ,@props) cand) - cand) - -;; There is a similar variable `yank-excluded-properties'. Unfortunately -;; we cannot use it here since it excludes too much (e.g., invisible) -;; and at the same time not enough (e.g., cursor-sensor-functions). -(defconst consult--remove-text-properties - '(category cursor cursor-intangible cursor-sensor-functions field follow-link - fontified front-sticky help-echo insert-behind-hooks insert-in-front-hooks - intangible keymap local-map modification-hooks mouse-face pointer read-only - rear-nonsticky yank-handler) - "List of text properties to remove from buffer strings.") - -(defsubst consult--buffer-substring (beg end &optional fontify) - "Return buffer substring between BEG and END. -If FONTIFY and `consult-fontify-preserve' are non-nil, first ensure that the -region has been fontified." - (if consult-fontify-preserve - (let (str) - (when fontify (consult--fontify-region beg end)) - (setq str (buffer-substring beg end)) - ;; TODO Propose the upstream addition of a function - ;; `preserve-list-of-text-properties', which should be as efficient as - ;; `remove-list-of-text-properties'. - (remove-list-of-text-properties - 0 (- end beg) consult--remove-text-properties str) - str) - (buffer-substring-no-properties beg end))) - -(defun consult--line-with-mark (marker) - "Current line string where the MARKER position is highlighted." - (let* ((beg (pos-bol)) - (end (pos-eol)) - (str (consult--buffer-substring beg end 'fontify))) - (if (>= marker end) - (concat str #(" " 0 1 (face consult-highlight-mark))) - (put-text-property (- marker beg) (- (1+ marker) beg) - 'face 'consult-highlight-mark str) - str))) - -;;;; Tofu cooks - -(defsubst consult--tofu-p (char) - "Return non-nil if CHAR is a tofu." - (<= consult--tofu-char char (+ consult--tofu-char consult--tofu-range -1))) - -(defun consult--tofu-hide (str) - "Hide the tofus in STR." - (let* ((max (length str)) - (end max)) - (while (and (> end 0) (consult--tofu-p (aref str (1- end)))) - (cl-decf end)) - (when (< end max) - (setq str (copy-sequence str)) - (put-text-property end max 'invisible t str)) - str)) - -(defsubst consult--tofu-append (cand id) - "Append tofu-encoded ID to CAND. -The ID must fit within a single character. It must be smaller -than `consult--tofu-range'." - (setq id (char-to-string (+ consult--tofu-char id))) - (add-text-properties 0 1 '(invisible t consult-strip t) id) - (concat cand id)) - -(defsubst consult--tofu-get (cand) - "Extract tofu-encoded ID from CAND. -See `consult--tofu-append'." - (- (aref cand (1- (length cand))) consult--tofu-char)) - -;; We must disambiguate the lines by adding a prefix such that two lines with -;; the same text can be distinguished. In order to avoid matching the line -;; number, such that the user can search for numbers with `consult-line', we -;; encode the line number as characters outside the Unicode range. By doing -;; that, no accidental matching can occur. -(defun consult--tofu-encode (n) - "Return tofu-encoded number N as a string. -Large numbers are encoded as multiple tofu characters." - (let (str tofu) - (while (progn - (setq tofu (char-to-string - (+ consult--tofu-char (% n consult--tofu-range))) - str (if str (concat tofu str) tofu)) - (and (>= n consult--tofu-range) - (setq n (/ n consult--tofu-range))))) - (add-text-properties 0 (length str) '(invisible t consult-strip t) str) - str)) - -;;;; Regexp utilities - -(defun consult--find-highlights (str start &rest ignored-faces) - "Find highlighted regions in STR from position START. -Highlighted regions have a non-nil face property. -IGNORED-FACES are ignored when searching for matches." - (let (highlights - (end (length str)) - (beg start)) - (while (< beg end) - (let ((next (next-single-property-change beg 'face str end)) - (val (get-text-property beg 'face str))) - (when (and val - (not (memq val ignored-faces)) - (not (and (consp val) - (seq-some (lambda (x) (memq x ignored-faces)) val)))) - (push (cons (- beg start) (- next start)) highlights)) - (setq beg next))) - (nreverse highlights))) - -(defun consult--point-placement (str start &rest ignored-faces) - "Compute point placement from STR with START offset. -IGNORED-FACES are ignored when searching for matches. -Return cons of point position and a list of match begin/end pairs." - (let* ((matches (apply #'consult--find-highlights str start ignored-faces)) - (pos (pcase-exhaustive consult-point-placement - ('match-beginning (or (caar matches) 0)) - ('match-end (or (cdar (last matches)) 0)) - ('line-beginning 0)))) - (dolist (match matches) - (cl-decf (car match) pos) - (cl-decf (cdr match) pos)) - (cons pos matches))) - -(defun consult--highlight-regexps (regexps ignore-case str) - "Highlight REGEXPS in STR. -If a regular expression contains capturing groups, only these are highlighted. -If no capturing groups are used highlight the whole match. Case is ignored -if IGNORE-CASE is non-nil." - (dolist (re regexps) - (let ((i 0)) - (while (and (let ((case-fold-search ignore-case)) - (string-match re str i)) - ;; Ensure that regexp search made progress (edge case for .*) - (> (match-end 0) i)) - ;; Unfortunately there is no way to avoid the allocation of the match - ;; data, since the number of capturing groups is unknown. - (let ((m (match-data))) - (setq i (cadr m) m (or (cddr m) m)) - (while m - (when (car m) - (add-face-text-property (car m) (cadr m) - 'consult-highlight-match nil str)) - (setq m (cddr m))))))) - str) - -(defconst consult--convert-regexp-table - (append - ;; For simplicity, treat word beginning/end as word boundaries, - ;; since PCRE does not make this distinction. Usually the - ;; context determines if \b is the beginning or the end. - '(("\\<" . "\\b") ("\\>" . "\\b") - ("\\_<" . "\\b") ("\\_>" . "\\b")) - ;; Treat \` and \' as beginning and end of line. This is more - ;; widely supported and makes sense for line-based commands. - '(("\\`" . "^") ("\\'" . "$")) - ;; Historical: Unescaped *, +, ? are supported at the beginning - (mapcan (lambda (x) - (mapcar (lambda (y) - (cons (concat x y) - (concat (string-remove-prefix "\\" x) "\\" y))) - '("*" "+" "?"))) - '("" "\\(" "\\(?:" "\\|" "^")) - ;; Different escaping - (mapcan (lambda (x) `(,x (,(cdr x) . ,(car x)))) - '(("\\|" . "|") - ("\\(" . "(") ("\\)" . ")") - ("\\{" . "{") ("\\}" . "}")))) - "Regexp conversion table.") - -(defun consult--convert-regexp (regexp type) - "Convert Emacs REGEXP to regexp syntax TYPE." - (if (memq type '(emacs basic)) - regexp - ;; Support for Emacs regular expressions is fairly complete for basic - ;; usage. There are a few unsupported Emacs regexp features: - ;; - \= point matching - ;; - Syntax classes \sx \Sx - ;; - Character classes \cx \Cx - ;; - Explicitly numbered groups (?3:group) - (replace-regexp-in-string - (rx (or "\\\\" "\\^" ;; Pass through - (seq (or "\\(?:" "\\|") (any "*+?")) ;; Historical: \|+ or \(?:* etc - (seq "\\(" (any "*+")) ;; Historical: \(* or \(+ - (seq (or bos "^") (any "*+?")) ;; Historical: + or * at the beginning - (seq (opt "\\") (any "(){|}")) ;; Escape parens/braces/pipe - (seq "\\" (any "'<>`")) ;; Special escapes - (seq "\\_" (any "<>")))) ;; Beginning or end of symbol - (lambda (x) (or (cdr (assoc x consult--convert-regexp-table)) x)) - regexp 'fixedcase 'literal))) - -(defun consult--default-regexp-compiler (input type ignore-case) - "Compile the INPUT string to a list of regular expressions. -The function should return a pair, the list of regular expressions and a -highlight function. The highlight function should take a single -argument, the string to highlight given the INPUT. TYPE is the desired -type of regular expression, which can be `basic', `extended', `emacs' or -`pcre'. If IGNORE-CASE is non-nil return a highlight function which -matches case insensitively." - (setq input (consult--split-escaped input)) - (cons (mapcar (lambda (x) (consult--convert-regexp x type)) input) - (when-let (regexps (seq-filter #'consult--valid-regexp-p input)) - (apply-partially #'consult--highlight-regexps regexps ignore-case)))) - -(defun consult--split-escaped (str) - "Split STR at spaces, which can be escaped with backslash." - (mapcar - (lambda (x) (string-replace "\0" " " x)) - (split-string (replace-regexp-in-string - "\\\\\\\\\\|\\\\ " - (lambda (x) (if (equal x "\\ ") "\0" x)) - str 'fixedcase 'literal) - " +" t))) - -(defun consult--join-regexps (regexps type) - "Join REGEXPS of TYPE." - ;; Add look-ahead wrapper only if there is more than one regular expression - (cond - ((and (eq type 'pcre) (cdr regexps)) - (concat "^" (mapconcat (lambda (x) (format "(?=.*%s)" x)) - regexps ""))) - ((eq type 'basic) - (string-join regexps ".*")) - (t - (when (length> regexps 3) - (message "Too many regexps, %S ignored. Use post-filtering!" - (string-join (seq-drop regexps 3) " ")) - (setq regexps (seq-take regexps 3))) - (consult--join-regexps-permutations regexps (and (eq type 'emacs) "\\"))))) - -(defun consult--join-regexps-permutations (regexps esc) - "Join all permutations of REGEXPS. -ESC is the escaping string for choice and groups." - (pcase regexps - ('nil "") - (`(,r) r) - (_ (mapconcat - (lambda (r) - (concat esc "(" r esc ").*" esc "(" - (consult--join-regexps-permutations (remove r regexps) esc) - esc ")")) - regexps (concat esc "|"))))) - -(defun consult--valid-regexp-p (re) - "Return t if regexp RE is valid." - (condition-case nil - (progn (string-match-p re "") t) - (invalid-regexp nil))) - -(defun consult--regexp-filter (regexps) - "Create filter regexp from REGEXPS." - (if (stringp regexps) - regexps - (mapconcat (lambda (x) (concat "\\(?:" x "\\)")) regexps "\\|"))) - -;;;; Lookup functions - -(defun consult--lookup-member (selected candidates &rest _) - "Lookup SELECTED in CANDIDATES list, return original element." - (car (member selected candidates))) - -(defun consult--lookup-cons (selected candidates &rest _) - "Lookup SELECTED in CANDIDATES alist, return cons." - (assoc selected candidates)) - -(defun consult--lookup-cdr (selected candidates &rest _) - "Lookup SELECTED in CANDIDATES alist, return `cdr' of element." - (cdr (assoc selected candidates))) - -(defun consult--lookup-location (selected candidates &rest _) - "Lookup SELECTED in CANDIDATES list of `consult-location' category. -Return the location marker." - (when-let (found (member selected candidates)) - (setq found (car (consult--get-location (car found)))) - ;; Check that marker is alive - (and (or (not (markerp found)) (marker-buffer found)) found))) - -(defun consult--lookup-prop (prop selected candidates &rest _) - "Lookup SELECTED in CANDIDATES list and return PROP value." - (when-let (found (member selected candidates)) - (get-text-property 0 prop (car found)))) - -(defun consult--lookup-candidate (selected candidates &rest _) - "Lookup SELECTED in CANDIDATES list and return property `consult--candidate'." - (consult--lookup-prop 'consult--candidate selected candidates)) - -;;;; Preview support - -(defun consult--preview-allowed-p (fun) - "Return non-nil if FUN is an allowed preview mode hook." - (or (memq fun consult-preview-allowed-hooks) - (when-let (((symbolp fun)) - (name (symbol-name fun)) - ;; Global modes in Emacs 29 are activated via a - ;; `find-file-hook' ending with `-check-buffers'. This has been - ;; changed in Emacs 30. Now a `change-major-mode-hook' is used - ;; instead with the suffix `-check-buffers'. - (suffix (static-if (>= emacs-major-version 30) - "-enable-in-buffer" - "-check-buffers")) - ((string-suffix-p suffix name))) - (memq (intern (string-remove-suffix suffix name)) - consult-preview-allowed-hooks)))) - -(defun consult--filter-find-file-hook (orig &rest hooks) - "Filter `find-file-hook' by `consult-preview-allowed-hooks'. -This function is an advice for `run-hooks'. -ORIG is the original function, HOOKS the arguments." - (if (memq 'find-file-hook hooks) - (cl-letf* (((default-value 'find-file-hook) - (seq-filter #'consult--preview-allowed-p - (default-value 'find-file-hook))) - (find-file-hook (default-value 'find-file-hook))) - (apply orig hooks)) - (apply orig hooks))) - -(defun consult--find-file-temporarily-1 (name) - "Open file NAME, helper function for `consult--find-file-temporarily'." - (when-let (((not (seq-find (lambda (x) (string-match-p x name)) - consult-preview-excluded-files))) - ;; file-attributes may throw permission denied error - (attrs (ignore-errors (file-attributes name))) - (size (file-attribute-size attrs))) - (let* ((partial (>= size consult-preview-partial-size)) - (buffer (if partial - (generate-new-buffer (format "consult-partial-preview-%s" name)) - (find-file-noselect name 'nowarn))) - (success nil)) - (unwind-protect - (with-current-buffer buffer - (if (not partial) - (when (or (eq major-mode 'hexl-mode) - (and (eq major-mode 'fundamental-mode) - (save-excursion (search-forward "\0" nil 'noerror)))) - (error "No preview of binary file `%s'" - (file-name-nondirectory name))) - (with-silent-modifications - (setq buffer-read-only t) - (insert-file-contents name nil 0 consult-preview-partial-chunk) - (goto-char (point-max)) - (insert "\nFile truncated. End of partial preview.\n") - (goto-char (point-min))) - (when (save-excursion (search-forward "\0" nil 'noerror)) - (error "No partial preview of binary file `%s'" - (file-name-nondirectory name))) - ;; Auto detect major mode and hope for the best, given that the - ;; file is only previewed partially. If an error is thrown the - ;; buffer will be killed and preview is aborted. - (set-auto-mode) - (font-lock-mode 1)) - (when (bound-and-true-p so-long-detected-p) - (error "No preview of file `%s' with long lines" - (file-name-nondirectory name))) - ;; Run delayed hooks listed in `consult-preview-allowed-hooks'. - (dolist (hook (reverse (cons 'after-change-major-mode-hook delayed-mode-hooks))) - (run-hook-wrapped hook (lambda (fun) - (when (consult--preview-allowed-p fun) - (funcall fun)) - nil))) - (setq success (current-buffer))) - (unless success - (kill-buffer buffer)))))) - -(defun consult--find-file-temporarily (name) - "Open file NAME temporarily for preview." - (let ((vars (delq nil - (mapcar - (pcase-lambda (`(,k . ,v)) - (if (boundp k) - (list k v (default-value k) (symbol-value k)) - (message "consult-preview-variables: The variable `%s' is not bound" k) - nil)) - consult-preview-variables)))) - (condition-case err - (unwind-protect - (progn - (advice-add #'run-hooks :around #'consult--filter-find-file-hook) - (pcase-dolist (`(,k ,v . ,_) vars) - (set-default k v) - (set k v)) - (consult--find-file-temporarily-1 name)) - (advice-remove #'run-hooks #'consult--filter-find-file-hook) - (pcase-dolist (`(,k ,_ ,d ,v) vars) - (set-default k d) - (set k v))) - (error - (message "%s" (error-message-string err)) - nil)))) - -(defun consult--temporary-files () - "Return a function to open files temporarily for preview." - (let ((dir default-directory) - (hook (make-symbol "consult--temporary-files-upgrade-hook")) - (orig-buffers (buffer-list)) - temporary-buffers) - (fset hook - (lambda (_) - ;; Fully initialize previewed files and keep them alive. - (unless (consult--completion-window-p) - (let (live-files) - (pcase-dolist (`(,file . ,buf) temporary-buffers) - (when-let (wins (and (buffer-live-p buf) - (get-buffer-window-list buf))) - (push (cons file (mapcar - (lambda (win) - (cons win (window-state-get win t))) - wins)) - live-files))) - (pcase-dolist (`(,_ . ,buf) temporary-buffers) - (kill-buffer buf)) - (setq temporary-buffers nil) - (pcase-dolist (`(,file . ,wins) live-files) - (when-let (buf (consult--file-action file)) - (push buf orig-buffers) - (pcase-dolist (`(,win . ,state) wins) - (setf (car (alist-get 'buffer state)) buf) - (window-state-put state win)))))))) - (lambda (&optional name) - (if name - (let ((default-directory dir)) - (setq name (abbreviate-file-name (expand-file-name name))) - (or - ;; Find existing fully initialized buffer (non-previewed). We have - ;; to check for fully initialized buffer before accessing the - ;; previewed buffers, since `embark-act' can open a buffer which is - ;; currently previewed, such that we end up with two buffers for - ;; the same file - one previewed and only partially initialized and - ;; one fully initialized. In this case we prefer the fully - ;; initialized buffer. For directories `get-file-buffer' returns nil, - ;; therefore we have to special case Dired. - (if (and (fboundp 'dired-find-buffer-nocreate) (file-directory-p name)) - (dired-find-buffer-nocreate name) - (get-file-buffer name)) - ;; Find existing previewed buffer. Previewed buffers are not fully - ;; initialized (hooks are delayed) in order to ensure fast preview. - (cdr (assoc name temporary-buffers)) - ;; Finally, if no existing buffer has been found, open the file for - ;; preview. - (when-let (buf (consult--find-file-temporarily name)) - ;; Only add new buffer if not already in the list - (unless (or (rassq buf temporary-buffers) (memq buf orig-buffers)) - (add-hook 'window-selection-change-functions hook) - (push (cons name buf) temporary-buffers) - ;; Disassociate buffer from file by setting `buffer-file-name' - ;; and `dired-directory' to nil and rename the buffer. This - ;; lets us open an already previewed buffer with the Embark - ;; default action C-. RET. - (with-current-buffer buf - (rename-buffer - (format " Preview:%s" - (file-name-nondirectory (directory-file-name name))) - 'unique)) - ;; The buffer disassociation is delayed to avoid breaking modes - ;; like `pdf-view-mode' or `doc-view-mode' which rely on - ;; `buffer-file-name'. Executing (set-visited-file-name nil) - ;; early also prevents the major mode initialization. - (let ((hook (make-symbol "consult--temporary-files-disassociate-hook"))) - (fset hook (lambda () - (when (buffer-live-p buf) - (with-current-buffer buf - (remove-hook 'pre-command-hook hook) - (setq-local buffer-read-only t - dired-directory nil - buffer-file-name nil))))) - (add-hook 'pre-command-hook hook)) - ;; Only keep a few buffers alive - (while (length> temporary-buffers consult-preview-max-count) - (kill-buffer (cdar (last temporary-buffers))) - (setq temporary-buffers (nbutlast temporary-buffers)))) - buf))) - (remove-hook 'window-selection-change-functions hook) - (pcase-dolist (`(,_ . ,buf) temporary-buffers) - (kill-buffer buf)) - (setq temporary-buffers nil))))) - -(defun consult--invisible-open-permanently () - "Open overlays which hide the current line. -See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." - (if (and (derived-mode-p 'org-mode) (fboundp 'org-fold-show-set-visibility)) - ;; New Org 9.6 fold-core API - (let ((inhibit-redisplay t)) ;; HACK: Prevent flicker due to premature redisplay - (org-fold-show-set-visibility 'canonical)) - (dolist (ov (overlays-in (pos-bol) (pos-eol))) - (when-let (fun (overlay-get ov 'isearch-open-invisible)) - (when (invisible-p (overlay-get ov 'invisible)) - (funcall fun ov)))))) - -(defun consult--invisible-open-temporarily () - "Temporarily open overlays which hide the current line. -See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." - (if (and (derived-mode-p 'org-mode) - (fboundp 'org-fold-show-set-visibility) - (fboundp 'org-fold-core-get-regions) - (fboundp 'org-fold-core-region)) - ;; New Org 9.6 fold-core API - ;; TODO The provided Org API `org-fold-show-set-visibility' cannot be used - ;; efficiently. We obtain all regions in the whole buffer in order to - ;; restore them. A better show API would return all the applied - ;; modifications such that we can restore the ones which got modified. - (progn - (unless consult--org-fold-regions - (setq consult--org-fold-regions - (delq nil (org-fold-core-get-regions - :with-markers t :from (point-min) :to (point-max)))) - (when consult--org-fold-regions - (let ((hook (make-symbol "consult--invisible-open-temporarily-cleanup-hook")) - (buffer (current-buffer)) - (depth (recursion-depth))) - (fset hook - (lambda () - (when (= (recursion-depth) depth) - (remove-hook 'minibuffer-exit-hook hook) - (run-at-time - 0 nil - (lambda () - (when (buffer-live-p buffer) - (with-current-buffer buffer - (pcase-dolist (`(,beg ,end ,_) consult--org-fold-regions) - (when (markerp beg) (set-marker beg nil)) - (when (markerp end) (set-marker end nil))) - (kill-local-variable 'consult--org-fold-regions)))))))) - (add-hook 'minibuffer-exit-hook hook)))) - (let ((inhibit-redisplay t)) ;; HACK: Prevent flicker due to premature redisplay - (org-fold-show-set-visibility 'canonical)) - (list (lambda () - (pcase-dolist (`(,beg ,end ,spec) consult--org-fold-regions) - (org-fold-core-region beg end t spec))))) - (let (restore) - (dolist (ov (overlays-in (pos-bol) (pos-eol))) - (let ((inv (overlay-get ov 'invisible))) - (when (and (invisible-p inv) (overlay-get ov 'isearch-open-invisible)) - (push (if-let (fun (overlay-get ov 'isearch-open-invisible-temporary)) - (progn - (funcall fun ov nil) - (lambda () (funcall fun ov t))) - (overlay-put ov 'invisible nil) - (lambda () (overlay-put ov 'invisible inv))) - restore)))) - restore))) - -(defun consult--jump-ensure-buffer (pos) - "Ensure that buffer of marker POS is displayed, return t if successful." - (or (not (markerp pos)) - ;; Switch to buffer if it is not visible - (when-let ((buf (marker-buffer pos))) - (or (and (eq (current-buffer) buf) (eq (window-buffer) buf)) - (consult--buffer-action buf 'norecord) - t)))) - -(defun consult--jump (pos) - "Jump to POS. -First push current position to mark ring, then move to new -position and run `consult-after-jump-hook'." - (when pos - ;; Extract marker from list with with overlay positions, see `consult--line-match' - (when (consp pos) (setq pos (car pos))) - ;; When the marker is in the same buffer, record previous location - ;; such that the user can jump back quickly. - (when (or (not (markerp pos)) (eq (current-buffer) (marker-buffer pos))) - ;; push-mark mutates markers in the mark-ring and the mark-marker. - ;; Therefore we transform the marker to a number to be safe. - ;; We all love side effects! - (setq pos (+ pos 0)) - (push-mark (point) t)) - (when (consult--jump-ensure-buffer pos) - (unless (= (goto-char pos) (point)) ;; Widen if jump failed - (widen) - (goto-char pos)) - (consult--invisible-open-permanently) - (run-hooks 'consult-after-jump-hook))) - nil) - -(defun consult--jump-preview () - "The preview function used if selecting from a list of candidate positions. -The function can be used as the `:state' argument of `consult--read'." - (let (restore) - (lambda (action cand) - (when (eq action 'preview) - (mapc #'funcall restore) - (setq restore nil) - ;; TODO Better buffer preview support - ;; 1. Use consult--buffer-preview instead of consult--jump-ensure-buffer - ;; 2. Remove function consult--jump-ensure-buffer - ;; 3. Remove consult-buffer-other-* from consult-customize-alist - (when-let ((pos (or (car-safe cand) cand)) ;; Candidate can be previewed - ((consult--jump-ensure-buffer pos))) - (let ((saved-min (point-min-marker)) - (saved-max (point-max-marker)) - (saved-pos (point-marker))) - (set-marker-insertion-type saved-max t) ;; Grow when text is inserted - (push (lambda () - (when-let ((buf (marker-buffer saved-pos))) - (with-current-buffer buf - (narrow-to-region saved-min saved-max) - (goto-char saved-pos) - (set-marker saved-pos nil) - (set-marker saved-min nil) - (set-marker saved-max nil)))) - restore)) - (unless (= (goto-char pos) (point)) ;; Widen if jump failed - (widen) - (goto-char pos)) - (setq restore (nconc (consult--invisible-open-temporarily) restore)) - ;; Ensure that cursor is properly previewed (gh:minad/consult#764) - (unless (eq cursor-in-non-selected-windows 'box) - (let ((orig cursor-in-non-selected-windows) - (buf (current-buffer))) - (push - (if (local-variable-p 'cursor-in-non-selected-windows) - (lambda () - (when (buffer-live-p buf) - (with-current-buffer buf - (setq-local cursor-in-non-selected-windows orig)))) - (lambda () - (when (buffer-live-p buf) - (with-current-buffer buf - (kill-local-variable 'cursor-in-non-selected-windows))))) - restore) - (setq-local cursor-in-non-selected-windows 'box))) - ;; Match previews - (let ((overlays - (list (save-excursion - (let ((vbeg (progn (beginning-of-visual-line) (point))) - (vend (progn (end-of-visual-line) (point))) - (end (pos-eol))) - (consult--make-overlay vbeg (if (= vend end) (1+ end) vend) - 'face 'consult-preview-line - 'window (selected-window) - 'priority 1)))))) - (dolist (match (cdr-safe cand)) - (push (consult--make-overlay (+ (point) (car match)) - (+ (point) (cdr match)) - 'face 'consult-preview-match - 'window (selected-window) - 'priority 2) - overlays)) - (push (lambda () (mapc #'delete-overlay overlays)) restore)) - (run-hooks 'consult-after-jump-hook)))))) - -(defun consult--jump-state () - "The state function used if selecting from a list of candidate positions." - (consult--state-with-return (consult--jump-preview) #'consult--jump)) - -(defun consult--get-location (cand) - "Return location from CAND." - (let ((loc (get-text-property 0 'consult-location cand))) - (when (consp (car loc)) - ;; Transform cheap marker to real marker - (setcar loc (set-marker (make-marker) (cdar loc) (caar loc)))) - loc)) - -(defun consult--location-state (candidates) - "Location state function. -The cheap location markers from CANDIDATES are upgraded on window -selection change to full Emacs markers." - (let ((jump (consult--jump-state)) - (hook (make-symbol "consult--location-upgrade-hook"))) - (fset hook - (lambda (_) - (unless (consult--completion-window-p) - (remove-hook 'window-selection-change-functions hook) - (mapc #'consult--get-location - (if (functionp candidates) (funcall candidates) candidates))))) - (lambda (action cand) - (pcase action - ('setup (add-hook 'window-selection-change-functions hook)) - ('exit (remove-hook 'window-selection-change-functions hook))) - (funcall jump action cand)))) - -(defun consult--state-with-return (state return) - "Compose STATE function with RETURN function." - (lambda (action cand) - (funcall state action cand) - (when (and cand (eq action 'return)) - (funcall return cand)))) - -(defmacro consult--define-state (type) - "Define state function for TYPE." - `(defun ,(intern (format "consult--%s-state" type)) () - ,(format "State function for %ss with preview. -The result can be passed as :state argument to `consult--read'." type) - (consult--state-with-return (,(intern (format "consult--%s-preview" type))) - #',(intern (format "consult--%s-action" type))))) - -(defun consult--preview-key-normalize (preview-key) - "Normalize PREVIEW-KEY, return alist of keys and debounce times." - (let ((keys) - (debounce 0)) - (setq preview-key (ensure-list preview-key)) - (while preview-key - (if (eq (car preview-key) :debounce) - (setq debounce (cadr preview-key) - preview-key (cddr preview-key)) - (let ((key (car preview-key))) - (unless (eq key 'any) - (setq key (consult--key-parse key))) - (push (cons key debounce) keys)) - (pop preview-key))) - keys)) - -(defun consult--preview-key-debounce (preview-key cand) - "Return debounce value of PREVIEW-KEY given the current candidate CAND." - (when (and (consp preview-key) (memq :keys preview-key)) - (setq preview-key (funcall (plist-get preview-key :predicate) cand))) - (let ((map (make-sparse-keymap)) - (keys (this-single-command-keys)) - any) - (pcase-dolist (`(,k . ,d) (consult--preview-key-normalize preview-key)) - (if (eq k 'any) - (setq any d) - (define-key map k `(lambda () ,d)))) - (setq keys (lookup-key map keys)) - (if (functionp keys) (funcall keys) any))) - -(defun consult--preview-append-local-pch (fun) - "Append FUN to local `post-command-hook' list." - ;; Symbol indirection because of bug#46407. - (let ((hook (make-symbol "consult--preview-post-command-hook"))) - (fset hook fun) - ;; TODO Emacs 28 has a bug, where the hook--depth-alist is not cleaned up properly - ;; Do not use the broken add-hook here. - ;;(add-hook 'post-command-hook hook 'append 'local) - (setq-local post-command-hook - (append - (remove t post-command-hook) - (list hook) - (and (memq t post-command-hook) '(t)))))) - -(defun consult--with-preview-1 (preview-key state transform candidate save-input fun) - "Add preview support for FUN. -See `consult--with-preview' for the arguments -PREVIEW-KEY, STATE, TRANSFORM, CANDIDATE and SAVE-INPUT." - (let ((mb-input "") mb-narrow selected timer previewed) - (minibuffer-with-setup-hook - (if (and state preview-key) - (lambda () - (let ((hook (make-symbol "consult--preview-minibuffer-exit-hook")) - (depth (recursion-depth))) - (fset hook - (lambda () - (when (= (recursion-depth) depth) - (remove-hook 'minibuffer-exit-hook hook) - (when timer - (cancel-timer timer) - (setq timer nil)) - (with-selected-window (consult--original-window) - ;; STEP 3: Reset preview - (when previewed - (funcall state 'preview nil)) - ;; STEP 4: Notify the preview function of the minibuffer exit - (funcall state 'exit nil))))) - (add-hook 'minibuffer-exit-hook hook)) - ;; STEP 1: Setup the preview function - (with-selected-window (consult--original-window) - (funcall state 'setup nil)) - (setq consult--preview-function - (lambda () - (when-let ((cand (funcall candidate))) - ;; Drop properties to prevent bugs regarding candidate - ;; lookup, which must handle candidates without - ;; properties. Otherwise the arguments passed to the - ;; lookup function are confusing, since during preview - ;; the candidate has properties but for the final lookup - ;; after completion it does not. - (setq cand (substring-no-properties cand)) - (with-selected-window (active-minibuffer-window) - (let ((input (minibuffer-contents-no-properties)) - (narrow consult--narrow) - (win (consult--original-window))) - (with-selected-window win - (when-let ((transformed (funcall transform narrow input cand)) - (debounce (consult--preview-key-debounce preview-key transformed))) - (when timer - (cancel-timer timer) - (setq timer nil)) - ;; The transformed candidate may have text - ;; properties, which change the preview display. - ;; This matters for example for `consult-grep', - ;; where the current candidate and input may - ;; stay equal, but the highlighting of the - ;; candidate changes while the candidates list - ;; is lagging a bit behind and updates - ;; asynchronously. - ;; - ;; In older Consult versions we instead compared - ;; the input without properties, since I worried - ;; that comparing the transformed candidates - ;; could be potentially expensive. However - ;; comparing the transformed candidates is more - ;; correct. The transformed candidate is the - ;; thing which is actually previewed. - (unless (equal-including-properties previewed transformed) - (if (> debounce 0) - (setq timer - (run-at-time - debounce nil - (lambda () - ;; Preview only when a completion - ;; window is selected and when - ;; the preview window is alive. - (when (and (consult--completion-window-p) - (window-live-p win)) - (with-selected-window win - ;; STEP 2: Preview candidate - (funcall state 'preview (setq previewed transformed))))))) - ;; STEP 2: Preview candidate - (funcall state 'preview (setq previewed transformed))))))))))) - (consult--preview-append-local-pch - (lambda () - (setq mb-input (minibuffer-contents-no-properties) - mb-narrow consult--narrow) - (funcall consult--preview-function)))) - (lambda () - (consult--preview-append-local-pch - (lambda () - (setq mb-input (minibuffer-contents-no-properties) - mb-narrow consult--narrow))))) - (unwind-protect - (setq selected (when-let (result (funcall fun)) - (when-let ((save-input) - (list (symbol-value save-input)) - ((equal (car list) result))) - (set save-input (cdr list))) - (funcall transform mb-narrow mb-input result))) - (when save-input - (add-to-history save-input mb-input)) - (when state - ;; STEP 5: The preview function should perform its final action - (funcall state 'return selected)))))) - -(defmacro consult--with-preview (preview-key state transform candidate save-input &rest body) - "Add preview support to BODY. - -STATE is the state function. -TRANSFORM is the transformation function. -CANDIDATE is the function returning the current candidate. -PREVIEW-KEY are the keys which triggers the preview. -SAVE-INPUT can be a history variable symbol to save the input. - -The state function takes two arguments, an action argument and the -selected candidate. The candidate argument can be nil if no candidate is -selected or if the selection was aborted. The function is called in -sequence with the following arguments: - - 1. \\='setup nil After entering the mb (minibuffer-setup-hook). -⎧ 2. \\='preview CAND/nil Preview candidate CAND or reset if CAND is nil. -⎪ \\='preview CAND/nil -⎪ \\='preview CAND/nil -⎪ ... -⎩ 3. \\='preview nil Reset preview. - 4. \\='exit nil Before exiting the mb (minibuffer-exit-hook). - 5. \\='return CAND/nil After leaving the mb, CAND has been selected. - -The state function is always executed with the original window selected, -see `consult--original-window'. The state function is called once in -the beginning of the minibuffer setup with the `setup' argument. This is -useful in order to perform certain setup operations which require that -the minibuffer is initialized. During completion candidates are -previewed. Then the function is called with the `preview' argument and a -candidate CAND or nil if no candidate is selected. Furthermore if nil is -passed for CAND, then the preview must be undone and the original state -must be restored. The call with the `exit' argument happens once at the -end of the completion process, just before exiting the minibuffer. The -minibuffer is still alive at that point. Both `setup' and `exit' are -only useful for setup and cleanup operations. They don't receive a -candidate as argument. After leaving the minibuffer, the selected -candidate or nil is passed to the state function with the action -argument `return'. At this point the state function can perform the -actual action on the candidate. The state function with the `return' -argument is the continuation of `consult--read'. Via `unwind-protect' it -is guaranteed, that if the `setup' action of a state function is -invoked, the state function will also be called with `exit' and -`return'." - (declare (indent 5)) - `(consult--with-preview-1 ,preview-key ,state ,transform ,candidate ,save-input (lambda () ,@body))) - -;;;; Narrowing and grouping - -(defun consult--prefix-group (cand transform) - "Return title for CAND or TRANSFORM the candidate. -The candidate must have a `consult--prefix-group' property." - (if transform - (substring cand (1+ (length (get-text-property 0 'consult--prefix-group cand)))) - (get-text-property 0 'consult--prefix-group cand))) - -(defun consult--type-group (types) - "Return group function for TYPES." - (lambda (cand transform) - (if transform cand - (alist-get (get-text-property 0 'consult--type cand) types)))) - -(defun consult--type-narrow (types) - "Return narrowing configuration from TYPES." - (list :predicate - (lambda (cand) (eq (get-text-property 0 'consult--type cand) consult--narrow)) - :keys types)) - -(defun consult--widen-key () - "Return widening key, if `consult-widen-key' is not set. -The default is twice the `consult-narrow-key'." - (cond - (consult-widen-key - (consult--key-parse consult-widen-key)) - (consult-narrow-key - (let ((key (consult--key-parse consult-narrow-key))) - (vconcat key key))))) - -(defun consult-narrow (key) - "Narrow current completion with KEY. - -This command is used internally by the narrowing system of `consult--read'." - (declare (completion ignore)) - (interactive - (list (unless (equal (this-single-command-keys) (consult--widen-key)) - last-command-event))) - (consult--require-minibuffer) - (setq consult--narrow key) - (when consult--narrow-predicate - (setq minibuffer-completion-predicate (and consult--narrow consult--narrow-predicate))) - (when consult--narrow-overlay - (delete-overlay consult--narrow-overlay)) - (when consult--narrow - (setq consult--narrow-overlay - (consult--make-overlay - (1- (minibuffer-prompt-end)) (minibuffer-prompt-end) - 'before-string - (propertize (format " [%s]" (alist-get consult--narrow - consult--narrow-keys)) - 'face 'consult-narrow-indicator)))) - (run-hooks 'consult--completion-refresh-hook)) - -(defconst consult--narrow-delete - `(menu-item - "" nil :filter - ,(lambda (&optional _) - (when (equal (minibuffer-contents-no-properties) "") - (lambda () - (interactive) - (consult-narrow nil)))))) - -(defconst consult--narrow-space - `(menu-item - "" nil :filter - ,(lambda (&optional _) - (let ((str (minibuffer-contents-no-properties))) - (when-let (pair (or (and (length= str 1) - (assoc (aref str 0) consult--narrow-keys)) - (and (equal str "") - (assoc ?\s consult--narrow-keys)))) - (lambda () - (interactive) - (delete-minibuffer-contents) - (consult-narrow (car pair)))))))) - -(defun consult-narrow-help () - "Print narrowing help as a `minibuffer-message'. - -This command can be bound to a key in `consult-narrow-map', -to make it available for commands with narrowing." - (declare (completion ignore)) - (interactive) - (consult--require-minibuffer) - (let ((minibuffer-message-timeout 1000000)) - (minibuffer-message - (mapconcat (lambda (x) - (concat - (propertize (key-description (list (car x))) 'face 'consult-key) - " " - (propertize (cdr x) 'face 'consult-help))) - consult--narrow-keys - " ")))) - -(defun consult--narrow-setup (settings map) - "Setup narrowing with SETTINGS and keymap MAP." - (if (memq :keys settings) - (setq consult--narrow-predicate (plist-get settings :predicate) - consult--narrow-keys (plist-get settings :keys)) - (setq consult--narrow-predicate nil - consult--narrow-keys settings)) - (when-let ((key consult-narrow-key)) - (setq key (consult--key-parse key)) - (dolist (pair consult--narrow-keys) - (define-key map (vconcat key (vector (car pair))) - (cons (cdr pair) #'consult-narrow)))) - (when-let ((widen (consult--widen-key))) - (define-key map widen (cons "All" #'consult-narrow))) - (when-let ((init (and (memq :keys settings) (plist-get settings :initial)))) - (consult-narrow init))) - -;;;; Splitting completion style - -(defun consult--split-perl (str &optional _plist) - "Split input STR in async input and filtering part. - -The function returns a list with three elements: The async -string, the start position of the completion filter string and a -force flag. If the first character is a punctuation character it -determines the separator. Examples: \"/async/filter\", -\"#async#filter\"." - (if (string-match-p "^[[:punct:]]" str) - (save-match-data - (let ((q (regexp-quote (substring str 0 1)))) - (string-match (concat "^" q "\\([^" q "]*\\)\\(" q "\\)?") str) - `(,(match-string 1 str) - ,(match-end 0) - ;; Force update it two punctuation characters are entered. - ,(match-end 2) - ;; List of highlights - (0 . ,(match-beginning 1)) - ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))))) - `(,str ,(length str)))) - -(defun consult--split-nil (str &optional _plist) - "Treat the complete input STR as async input." - `(,str ,(length str))) - -(defun consult--split-separator (str plist) - "Split input STR in async input and filtering part at first separator. -PLIST is the splitter configuration, including the separator." - (let ((sep (regexp-quote (char-to-string (plist-get plist :separator))))) - (save-match-data - (if (string-match (format "^\\([^%s]+\\)\\(%s\\)?" sep sep) str) - `(,(match-string 1 str) - ,(match-end 0) - ;; Force update it space is entered. - ,(match-end 2) - ;; List of highlights - ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))) - `(,str ,(length str)))))) - -(defun consult--split-setup (split) - "Setup splitting completion style with splitter function SPLIT." - (let* ((styles completion-styles) - (catdef completion-category-defaults) - (catovr completion-category-overrides) - (try (lambda (str table pred point) - (let ((completion-styles styles) - (completion-category-defaults catdef) - (completion-category-overrides catovr) - (pos (cadr (funcall split str)))) - (pcase (completion-try-completion (substring str pos) table pred - (max 0 (- point pos))) - ('t t) - (`(,newstr . ,newpt) - (cons (concat (substring str 0 pos) newstr) - (+ pos newpt))))))) - (all (lambda (str table pred point) - (let ((completion-styles styles) - (completion-category-defaults catdef) - (completion-category-overrides catovr) - (pos (cadr (funcall split str)))) - (completion-all-completions (substring str pos) table pred - (max 0 (- point pos))))))) - (setq-local completion-styles-alist (cons `(consult--split ,try ,all "") - completion-styles-alist) - completion-styles '(consult--split) - completion-category-defaults nil - completion-category-overrides nil))) - -;;;; Asynchronous filtering functions - -(defun consult--async-p (fun) - "Return t if FUN is an asynchronous completion function." - (and (functionp fun) - (condition-case nil - (progn (funcall fun "" nil 'metadata) nil) - (wrong-number-of-arguments t)))) - -(defmacro consult--with-async (bind &rest body) - "Setup asynchronous completion in BODY. - -BIND is the asynchronous function binding." - (declare (indent 1)) - (let ((async (car bind))) - `(let ((,async ,@(cdr bind)) - (new-chunk (max read-process-output-max consult--process-chunk)) - orig-chunk) - (minibuffer-with-setup-hook - ;; Append such that we overwrite the completion style setting of - ;; `fido-mode'. See `consult--async-split' and - ;; `consult--split-setup'. - (:append - (lambda () - (when (consult--async-p ,async) - (setq orig-chunk read-process-output-max - read-process-output-max new-chunk) - (funcall ,async 'setup) - (let* ((mb (current-buffer)) - (fun (lambda () - (when-let (win (active-minibuffer-window)) - (when (eq (window-buffer win) mb) - (with-current-buffer mb - (let ((inhibit-modification-hooks t)) - ;; Push input string to request refresh. - (funcall ,async (minibuffer-contents-no-properties)))))))) - ;; We use a symbol in order to avoid adding lambdas to - ;; the hook variable. Symbol indirection because of - ;; bug#46407. - (hook (make-symbol "consult--async-after-change-hook"))) - ;; Delay modification hook to ensure that minibuffer is still - ;; alive after the change, such that we don't restart a new - ;; asynchronous search right before exiting the minibuffer. - (fset hook (lambda (&rest _) (run-at-time 0 nil fun))) - (add-hook 'after-change-functions hook nil 'local) - (funcall hook))))) - (let ((,async (if (consult--async-p ,async) ,async (lambda (_) ,async)))) - (unwind-protect - ,(macroexp-progn body) - (funcall ,async 'destroy) - (when (and orig-chunk (eq read-process-output-max new-chunk)) - (setq read-process-output-max orig-chunk)))))))) - -(defun consult--async-sink () - "Create ASYNC sink function. - -An async function must accept a single action argument. For the -\\='setup action it is guaranteed that the call originates from -the minibuffer. For the other actions no assumption about the -context can be made. - -\\='setup Setup the internal closure state. Return nil. -\\='destroy Destroy the internal closure state. Return nil. -\\='flush Flush the list of candidates. Return nil. -\\='refresh Request UI refresh. Return nil. -nil Return the list of candidates. -list Append the list to the already existing candidates list and return it. -string Update with the current user input string. Return nil." - (let (candidates last buffer) - (lambda (action) - (pcase-exhaustive action - ('setup - (setq buffer (current-buffer)) - nil) - ((or (pred stringp) 'destroy) nil) - ('flush (setq candidates nil last nil)) - ('refresh - ;; Refresh the UI when the current minibuffer window belongs - ;; to the current asynchronous completion session. - (when-let (win (active-minibuffer-window)) - (when (eq (window-buffer win) buffer) - (with-selected-window win - (run-hooks 'consult--completion-refresh-hook) - ;; Interaction between asynchronous completion functions and - ;; preview: We have to trigger preview immediately when - ;; candidates arrive (gh:minad/consult#436). - (when (and consult--preview-function candidates) - (funcall consult--preview-function))))) - nil) - ('nil candidates) - ((pred consp) - (setq last (last (if last (setcdr last action) (setq candidates action)))) - candidates))))) - -(defun consult--async-split-style () - "Return the async splitting style function and initial string." - (or (alist-get consult-async-split-style consult-async-split-styles-alist) - (user-error "Splitting style `%s' not found" consult-async-split-style))) - -(defun consult--async-split-initial (initial) - "Return initial string for async command. -INITIAL is the additional initial string." - (concat (plist-get (consult--async-split-style) :initial) initial)) - -(defun consult--async-split-thingatpt (thing) - "Return THING at point with async initial prefix." - (when-let (str (thing-at-point thing)) - (consult--async-split-initial str))) - -(defun consult--async-split (async &optional split) - "Create async function, which splits the input string. -ASYNC is the async sink. -SPLIT is the splitting function." - (unless split - (let* ((style (consult--async-split-style)) - (fn (plist-get style :function))) - (setq split (lambda (str) (funcall fn str style))))) - (lambda (action) - (pcase action - ('setup - (consult--split-setup split) - (funcall async 'setup)) - ((pred stringp) - (pcase-let* ((`(,async-str ,_ ,force . ,highlights) - (funcall split action)) - (async-len (length async-str)) - (input-len (length action)) - (end (minibuffer-prompt-end))) - ;; Highlight punctuation characters - (remove-list-of-text-properties end (+ end input-len) '(face)) - (dolist (hl highlights) - (put-text-property (+ end (car hl)) (+ end (cdr hl)) - 'face 'consult-async-split)) - (funcall async - ;; Pass through if the input is long enough! - (if (or force (>= async-len consult-async-min-input)) - async-str - ;; Pretend that there is no input - "")))) - (_ (funcall async action))))) - -(defun consult--async-indicator (async) - "Create async function with a state indicator overlay. -ASYNC is the async sink." - (let (ov) - (lambda (action &optional state) - (pcase action - ('indicator - (overlay-put ov 'display - (pcase-exhaustive state - ('running #("*" 0 1 (face consult-async-running))) - ('finished #(":" 0 1 (face consult-async-finished))) - ('killed #(";" 0 1 (face consult-async-failed))) - ('failed #("!" 0 1 (face consult-async-failed)))))) - ('setup - (setq ov (make-overlay (- (minibuffer-prompt-end) 2) - (- (minibuffer-prompt-end) 1))) - (funcall async 'setup)) - ('destroy - (delete-overlay ov) - (funcall async 'destroy)) - (_ (funcall async action)))))) - -(defun consult--async-log (formatted &rest args) - "Log FORMATTED ARGS to variable `consult--async-log'." - (with-current-buffer (get-buffer-create consult--async-log) - (goto-char (point-max)) - (insert (apply #'format formatted args)))) - -(defun consult--async-process (async builder &rest props) - "Create process source async function. - -ASYNC is the async function which receives the candidates. -BUILDER is the command line builder function. -PROPS are optional properties passed to `make-process'." - (setq async (consult--async-indicator async)) - (let (proc proc-buf last-args count) - (lambda (action) - (pcase action - ("" ;; If no input is provided kill current process - (when proc - (delete-process proc) - (kill-buffer proc-buf) - (setq proc nil proc-buf nil)) - (setq last-args nil)) - ((pred stringp) - (funcall async action) - (let* ((args (funcall builder action))) - (unless (stringp (car args)) - (setq args (car args))) - (unless (equal args last-args) - (setq last-args args) - (when proc - (delete-process proc) - (kill-buffer proc-buf) - (setq proc nil proc-buf nil)) - (when args - (let* ((flush t) - (rest "") - (proc-filter - (lambda (_ out) - (when flush - (setq flush nil) - (funcall async 'flush)) - (let ((lines (split-string out "[\r\n]+"))) - (if (not (cdr lines)) - (setq rest (concat rest (car lines))) - (setcar lines (concat rest (car lines))) - (let* ((len (length lines)) - (last (nthcdr (- len 2) lines))) - (setq rest (cadr last) - count (+ count len -1)) - (setcdr last nil) - (funcall async lines)))))) - (proc-sentinel - (lambda (_ event) - (when flush - (setq flush nil) - (funcall async 'flush)) - (funcall async 'indicator - (cond - ((string-prefix-p "killed" event) 'killed) - ((string-prefix-p "finished" event) 'finished) - (t 'failed))) - (when (and (string-prefix-p "finished" event) (not (equal rest ""))) - (cl-incf count) - (funcall async (list rest))) - (consult--async-log - "consult--async-process sentinel: event=%s lines=%d\n" - (string-trim event) count) - (when (> (buffer-size proc-buf) 0) - (with-current-buffer (get-buffer-create consult--async-log) - (goto-char (point-max)) - (insert ">>>>> stderr >>>>>\n") - (let ((beg (point))) - (insert-buffer-substring proc-buf) - (save-excursion - (goto-char beg) - (message #("%s" 0 2 (face error)) - (buffer-substring-no-properties (pos-bol) (pos-eol))))) - (insert "<<<<< stderr <<<<<\n"))))) - (process-adaptive-read-buffering nil)) - (funcall async 'indicator 'running) - (consult--async-log "consult--async-process started: args=%S default-directory=%S\n" - args default-directory) - (setq count 0 - proc-buf (generate-new-buffer " *consult-async-stderr*") - proc (apply #'make-process - `(,@props - :connection-type pipe - :name ,(car args) - ;;; XXX tramp bug, the stderr buffer must be empty - :stderr ,proc-buf - :noquery t - :command ,args - :filter ,proc-filter - :sentinel ,proc-sentinel))))))) - nil) - ('destroy - (when proc - (delete-process proc) - (kill-buffer proc-buf) - (setq proc nil proc-buf nil)) - (funcall async 'destroy)) - (_ (funcall async action)))))) - -(defun consult--async-highlight (async builder) - "Return a new ASYNC function with candidate highlighting. -BUILDER is the command line builder function." - (let (highlight) - (lambda (action) - (cond - ((stringp action) - (setq highlight (cdr (funcall builder action))) - (funcall async action)) - ((and (consp action) highlight) - (dolist (str action) - (funcall highlight str)) - (funcall async action)) - (t (funcall async action)))))) - -(defun consult--async-throttle (async &optional throttle debounce) - "Create async function from ASYNC which throttles input. - -The THROTTLE delay defaults to `consult-async-input-throttle'. -The DEBOUNCE delay defaults to `consult-async-input-debounce'." - (setq throttle (or throttle consult-async-input-throttle) - debounce (or debounce consult-async-input-debounce)) - (let* ((input "") (timer (timer-create)) (last 0)) - (lambda (action) - (pcase action - ((pred stringp) - (unless (equal action input) - (cancel-timer timer) - (funcall async "") ;; cancel running process - (setq input action) - (unless (equal action "") - (timer-set-function timer (lambda () - (setq last (float-time)) - (funcall async action))) - (timer-set-time - timer - (timer-relative-time - nil (max debounce (- (+ last throttle) (float-time))))) - (timer-activate timer))) - nil) - ('destroy - (cancel-timer timer) - (funcall async 'destroy)) - (_ (funcall async action)))))) - -(defun consult--async-refresh-immediate (async) - "Create async function from ASYNC, which refreshes the display. - -The refresh happens immediately when candidates are pushed." - (lambda (action) - (pcase action - ((or (pred consp) 'flush) - (prog1 (funcall async action) - (funcall async 'refresh))) - (_ (funcall async action))))) - -(defun consult--async-refresh-timer (async &optional delay) - "Create async function from ASYNC, which refreshes the display. - -The refresh happens after a DELAY, defaulting to `consult-async-refresh-delay'." - (let ((delay (or delay consult-async-refresh-delay)) - (timer (timer-create))) - (timer-set-function timer async '(refresh)) - (lambda (action) - (prog1 (funcall async action) - (pcase action - ((or (pred consp) 'flush) - (unless (memq timer timer-list) - (timer-set-time timer (timer-relative-time nil delay)) - (timer-activate timer))) - ('destroy - (cancel-timer timer))))))) - -(defmacro consult--async-command (builder &rest args) - "Asynchronous command pipeline. -ARGS is a list of `make-process' properties and transforms. -BUILDER is the command line builder function, which takes the -input string and must either return a list of command line -arguments or a pair of the command line argument list and a -highlighting function." - (declare (indent 1)) - `(thread-first - (consult--async-sink) - (consult--async-refresh-timer) - ,@(seq-take-while (lambda (x) (not (keywordp x))) args) - (consult--async-process - ,builder - ,@(seq-drop-while (lambda (x) (not (keywordp x))) args)) - (consult--async-throttle) - (consult--async-split))) - -(defmacro consult--async-transform (async &rest transform) - "Use FUN to TRANSFORM candidates of ASYNC." - (cl-with-gensyms (async-var action-var) - `(let ((,async-var ,async)) - (lambda (,action-var) - (funcall ,async-var (if (consp ,action-var) (,@transform ,action-var) ,action-var)))))) - -(defun consult--async-map (async fun) - "Map candidates of ASYNC by FUN." - (consult--async-transform async mapcar fun)) - -(defun consult--async-filter (async fun) - "Filter candidates of ASYNC by FUN." - (consult--async-transform async seq-filter fun)) - -;;;; Dynamic collections based - -(defun consult--dynamic-compute (async fun &optional debounce) - "Dynamic computation of candidates. -ASYNC is the sink. -FUN computes the candidates given the input. -DEBOUNCE is the time after which an interrupted computation -should be restarted." - (setq debounce (or debounce consult-async-input-debounce)) - (setq async (consult--async-indicator async)) - (let* ((request) (current) (timer) - (cancel (lambda () (when timer (cancel-timer timer) (setq timer nil)))) - (start (lambda (req) (setq request req) (funcall async 'refresh)))) - (lambda (action) - (pcase action - ((and 'nil (guard (not request))) - (funcall async nil)) - ('nil - (funcall cancel) - (let ((state 'killed)) - (unwind-protect - (progn - (funcall async 'indicator 'running) - (redisplay) - ;; Run computation - (let ((response (funcall fun request))) - ;; Flush and update candidate list - (funcall async 'flush) - (setq state 'finished current request) - (funcall async response))) - (funcall async 'indicator state) - ;; If the computation was killed, restart it after some time. - (when (eq state 'killed) - (setq timer (run-at-time debounce nil start request))) - (setq request nil)))) - ((pred stringp) - (funcall cancel) - (if (or (equal action "") (equal action current)) - (funcall async 'indicator 'finished) - (funcall start action))) - ('destroy - (funcall cancel) - (funcall async 'destroy)) - (_ (funcall async action)))))) - -(defun consult--dynamic-collection (fun) - "Dynamic collection with input splitting. -FUN computes the candidates given the input." - (thread-first - (consult--async-sink) - (consult--dynamic-compute fun) - (consult--async-throttle) - (consult--async-split))) - -;;;; Special keymaps - -(defvar-keymap consult-async-map - :doc "Keymap added for commands with asynchronous candidates." - ;; Overwriting some unusable defaults of default minibuffer completion. - "<remap> <minibuffer-complete-word>" #'self-insert-command - ;; Remap Emacs 29 history and default completion for now - ;; (gh:minad/consult#613). - "<remap> <minibuffer-complete-defaults>" #'ignore - "<remap> <minibuffer-complete-history>" #'consult-history) - -(defvar-keymap consult-narrow-map - :doc "Narrowing keymap which is added to the local minibuffer map. -Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically." - "SPC" consult--narrow-space - "DEL" consult--narrow-delete) - -;;;; Internal API: consult--read - -(defun consult--annotate-align (cand ann) - "Align annotation ANN by computing the maximum CAND width." - (setq consult--annotate-align-width - (max consult--annotate-align-width - (* (ceiling (consult--display-width cand) - consult--annotate-align-step) - consult--annotate-align-step))) - (when ann - (concat - #(" " 0 1 (display (space :align-to (+ left consult--annotate-align-width)))) - ann))) - -(defun consult--add-history (async items) - "Add ITEMS to the minibuffer future history. -ASYNC must be non-nil for async completion functions." - (delete-dups - (append - ;; the defaults are at the beginning of the future history - (ensure-list minibuffer-default) - ;; then our custom items - (remove "" (remq nil (ensure-list items))) - ;; Add all the completions for non-async commands. For async commands this - ;; feature is not useful, since if one selects a completion candidate, the - ;; async search is restarted using that candidate string. This usually does - ;; not yield a desired result since the async input uses a special format, - ;; e.g., `#grep#filter'. - (unless async - (all-completions "" - minibuffer-completion-table - minibuffer-completion-predicate))))) - -(defun consult--setup-keymap (keymap async narrow preview-key) - "Setup minibuffer keymap. - -KEYMAP is a command-specific keymap. -ASYNC must be non-nil for async completion functions. -NARROW are the narrow settings. -PREVIEW-KEY are the preview keys." - (let ((old-map (current-local-map)) - (map (make-sparse-keymap))) - - ;; Add narrow keys - (when narrow - (consult--narrow-setup narrow map)) - - ;; Preview trigger keys - (when (and (consp preview-key) (memq :keys preview-key)) - (setq preview-key (plist-get preview-key :keys))) - (setq preview-key (mapcar #'car (consult--preview-key-normalize preview-key))) - (when preview-key - (dolist (key preview-key) - (unless (or (eq key 'any) (lookup-key old-map key)) - (define-key map key #'ignore)))) - - ;; Put the keymap together - (use-local-map - (make-composed-keymap - (delq nil (list keymap - (and async consult-async-map) - (and narrow consult-narrow-map) - map)) - old-map)))) - -(defun consult--tofu-hide-in-minibuffer (&rest _) - "Hide the tofus in the minibuffer." - (let* ((min (minibuffer-prompt-end)) - (max (point-max)) - (pos max)) - (while (and (> pos min) (consult--tofu-p (char-before pos))) - (cl-decf pos)) - (when (< pos max) - (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t))))) - -(defun consult--read-annotate (fun cand) - "Annotate CAND with annotation function FUN." - (pcase (funcall fun cand) - (`(,_ ,_ ,suffix) suffix) - (ann ann))) - -(defun consult--read-affixate (fun cands) - "Affixate CANDS with annotation function FUN." - (mapcar (lambda (cand) - (let ((ann (funcall fun cand))) - (if (consp ann) - ann - (setq ann (or ann "")) - (list cand "" - ;; The default completion UI adds the - ;; `completions-annotations' face if no other faces are - ;; present. - (if (text-property-not-all 0 (length ann) 'face nil ann) - ann - (propertize ann 'face 'completions-annotations)))))) - cands)) - -(cl-defun consult--read-1 (table &key - prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - "See `consult--read' for the documentation of the arguments." - (minibuffer-with-setup-hook - (:append (lambda () - (add-hook 'after-change-functions #'consult--tofu-hide-in-minibuffer nil 'local) - (consult--setup-keymap keymap (consult--async-p table) narrow preview-key) - (setq-local minibuffer-default-add-function - (apply-partially #'consult--add-history (consult--async-p table) add-history)))) - (consult--with-async (async table) - (consult--with-preview - preview-key state - (lambda (narrow input cand) - (funcall lookup cand (funcall async nil) input narrow)) - (apply-partially #'run-hook-with-args-until-success - 'consult--completion-candidate-hook) - (pcase-exhaustive history - (`(:input ,var) var) - ((pred symbolp))) - ;; Do not unnecessarily let-bind the lambdas to avoid over-capturing in - ;; the interpreter. This will make closures and the lambda string - ;; representation larger, which makes debugging much worse. Fortunately - ;; the over-capturing problem does not affect the bytecode interpreter - ;; which does a proper scope analysis. - (let* ((metadata `(metadata - ,@(when category `((category . ,category))) - ,@(when group `((group-function . ,group))) - ,@(when annotate - `((affixation-function - . ,(apply-partially #'consult--read-affixate annotate)) - (annotation-function - . ,(apply-partially #'consult--read-annotate annotate)))) - ,@(unless sort '((cycle-sort-function . identity) - (display-sort-function . identity))))) - (consult--annotate-align-width 0) - (selected - (completing-read - prompt - (lambda (str pred action) - (let ((result (complete-with-action action (funcall async nil) str pred))) - (if (eq action 'metadata) - (if (and (eq (car result) 'metadata) (cdr result)) - ;; Merge metadata - `(metadata ,@(cdr metadata) ,@(cdr result)) - metadata) - result))) - predicate require-match initial - (if (symbolp history) history (cadr history)) - default - inherit-input-method))) - ;; Repair the null completion semantics. `completing-read' may return - ;; an empty string even if REQUIRE-MATCH is non-nil. One can always - ;; opt-in to null completion by passing the empty string for DEFAULT. - (when (and (eq require-match t) (not default) (equal selected "")) - (user-error "No selection")) - selected))))) - -(cl-defun consult--read (table &rest options &key - prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - "Enhanced completing read function to select from TABLE. - -The function is a thin wrapper around `completing-read'. Keyword -arguments are used instead of positional arguments for code -clarity. On top of `completing-read' it additionally supports -computing the candidate list asynchronously, candidate preview -and narrowing. You should use `completing-read' instead of -`consult--read' if you don't use asynchronous candidate -computation or candidate preview. - -Keyword OPTIONS: - -PROMPT is the string which is shown as prompt in the minibuffer. -PREDICATE is a filter function called for each candidate, returns -nil or t. -REQUIRE-MATCH equals t means that an exact match is required. -HISTORY is the symbol of the history variable. -DEFAULT is the default selected value. -ADD-HISTORY is a list of items to add to the history. -CATEGORY is the completion category symbol. -SORT should be set to nil if the candidates are already sorted. -This will disable sorting in the completion UI. -LOOKUP is a lookup function passed the selected candidate string, -the list of candidates, the current input string and the current -narrowing value. -ANNOTATE is a function passed a candidate string. The function -should either return an annotation string or a list of three -strings (candidate prefix postfix). -INITIAL is the initial input string. -STATE is the state function, see `consult--with-preview'. -GROUP is a completion metadata `group-function' as documented in -the Elisp manual. -PREVIEW-KEY are the preview keys. Can be nil, `any', a single -key or a list of keys. -NARROW is an alist of narrowing prefix strings and description. -KEYMAP is a command-specific keymap. -INHERIT-INPUT-METHOD, if non-nil the minibuffer inherits the -input method." - ;; supported types - (cl-assert (or (functionp table) ;; dynamic table or asynchronous function - (obarrayp table) ;; obarray - (hash-table-p table) ;; hash table - (not table) ;; empty list - (stringp (car table)) ;; string list - (and (consp (car table)) (stringp (caar table))) ;; string alist - (and (consp (car table)) (symbolp (caar table))))) ;; symbol alist - (ignore prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - (apply #'consult--read-1 table - (append - (consult--customize-get) - options - (list :prompt "Select: " - :preview-key consult-preview-key - :sort t - :lookup (lambda (selected &rest _) selected))))) - -;;;; Internal API: consult--prompt - -(cl-defun consult--prompt-1 (&key prompt history add-history initial default - keymap state preview-key transform inherit-input-method) - "See `consult--prompt' for documentation." - (minibuffer-with-setup-hook - (:append (lambda () - (consult--setup-keymap keymap nil nil preview-key) - (setq-local minibuffer-default-add-function - (apply-partially #'consult--add-history nil add-history)))) - (consult--with-preview - preview-key state - (lambda (_narrow inp _cand) (funcall transform inp)) - (lambda () "") - history - (read-from-minibuffer prompt initial nil nil history default inherit-input-method)))) - -(cl-defun consult--prompt (&rest options &key prompt history add-history initial default - keymap state preview-key transform inherit-input-method) - "Read from minibuffer. - -Keyword OPTIONS: - -PROMPT is the string to prompt with. -TRANSFORM is a function which is applied to the current input string. -HISTORY is the symbol of the history variable. -INITIAL is initial input. -DEFAULT is the default selected value. -ADD-HISTORY is a list of items to add to the history. -STATE is the state function, see `consult--with-preview'. -PREVIEW-KEY are the preview keys (nil, `any', a single key or a list of keys). -KEYMAP is a command-specific keymap." - (ignore prompt history add-history initial default - keymap state preview-key transform inherit-input-method) - (apply #'consult--prompt-1 - (append - (consult--customize-get) - options - (list :prompt "Input: " - :preview-key consult-preview-key - :transform #'identity)))) - -;;;; Internal API: consult--multi - -(defsubst consult--multi-source (sources cand) - "Lookup source for CAND in SOURCES list." - (aref sources (consult--tofu-get cand))) - -(defun consult--multi-predicate (sources cand) - "Predicate function called for each candidate CAND given SOURCES." - (let* ((src (consult--multi-source sources cand)) - (narrow (plist-get src :narrow)) - (type (or (car-safe narrow) narrow -1))) - (or (eq consult--narrow type) - (not (or consult--narrow (plist-get src :hidden)))))) - -(defun consult--multi-narrow (sources) - "Return narrow list from SOURCES." - (thread-last sources - (mapcar (lambda (src) - (when-let (narrow (plist-get src :narrow)) - (if (consp narrow) - narrow - (when-let (name (plist-get src :name)) - (cons narrow name)))))) - (delq nil) - (delete-dups))) - -(defun consult--multi-annotate (sources cand) - "Annotate candidate CAND from multi SOURCES." - (consult--annotate-align - cand - (let ((src (consult--multi-source sources cand))) - (if-let ((fun (plist-get src :annotate))) - (funcall fun (cdr (get-text-property 0 'multi-category cand))) - (plist-get src :name))))) - -(defun consult--multi-group (sources cand transform) - "Return title of candidate CAND or TRANSFORM the candidate given SOURCES." - (if transform cand - (plist-get (consult--multi-source sources cand) :name))) - -(defun consult--multi-preview-key (sources) - "Return preview keys from SOURCES." - (list :predicate - (lambda (cand) - (if (plist-member (cdr cand) :preview-key) - (plist-get (cdr cand) :preview-key) - consult-preview-key)) - :keys - (delete-dups - (seq-filter (lambda (k) (or (eq k 'any) (stringp k))) - (seq-mapcat (lambda (src) - (ensure-list - (if (plist-member src :preview-key) - (plist-get src :preview-key) - consult-preview-key))) - sources))))) - -(defun consult--multi-lookup (sources selected candidates _input narrow &rest _) - "Lookup SELECTED in CANDIDATES given SOURCES, with potential NARROW." - (if (or (string-blank-p selected) - (not (consult--tofu-p (aref selected (1- (length selected)))))) - ;; Non-existing candidate without Tofu or default submitted (empty string) - (let* ((src (cond - (narrow (seq-find (lambda (src) - (let ((n (plist-get src :narrow))) - (eq (or (car-safe n) n -1) narrow))) - sources)) - ((seq-find (lambda (src) (plist-get src :default)) sources)) - ((seq-find (lambda (src) (not (plist-get src :hidden))) sources)) - ((aref sources 0)))) - (idx (seq-position sources src)) - (def (and (string-blank-p selected) ;; default candidate - (seq-find (lambda (cand) (eq idx (consult--tofu-get cand))) candidates)))) - (if def - (cons (cdr (get-text-property 0 'multi-category def)) src) - `(,selected :match nil ,@src))) - (if-let (found (member selected candidates)) - ;; Existing candidate submitted - (cons (cdr (get-text-property 0 'multi-category (car found))) - (consult--multi-source sources selected)) - ;; Non-existing Tofu'ed candidate submitted, e.g., via Embark - `(,(substring selected 0 -1) :match nil ,@(consult--multi-source sources selected))))) - -(defun consult--multi-candidates (sources) - "Return `consult--multi' candidates from SOURCES." - (let ((idx 0) candidates) - (seq-doseq (src sources) - (let* ((face (and (plist-member src :face) `(face ,(plist-get src :face)))) - (cat (plist-get src :category)) - (items (plist-get src :items)) - (items (if (functionp items) (funcall items) items))) - (dolist (item items) - (let* ((str (or (car-safe item) item)) - (cand (consult--tofu-append str idx))) - ;; Preserve existing `multi-category' datum of the candidate. - (if (and (eq str item) (get-text-property 0 'multi-category str)) - (when face (add-text-properties 0 (length str) face cand)) - ;; Attach `multi-category' datum and face. - (add-text-properties - 0 (length str) - `(multi-category (,cat . ,(or (cdr-safe item) item)) ,@face) cand)) - (push cand candidates)))) - (cl-incf idx)) - (nreverse candidates))) - -(defun consult--multi-enabled-sources (sources) - "Return vector of enabled SOURCES." - (vconcat - (seq-filter (lambda (src) - (if-let (pred (plist-get src :enabled)) - (funcall pred) - t)) - (mapcar (lambda (src) - (if (symbolp src) (symbol-value src) src)) - sources)))) - -(defun consult--multi-state (sources) - "State function given SOURCES." - (when-let (states (delq nil (mapcar (lambda (src) - (when-let (fun (plist-get src :state)) - (cons src (funcall fun)))) - sources))) - (let (last-fun) - (pcase-lambda (action `(,cand . ,src)) - (pcase action - ('setup - (pcase-dolist (`(,_ . ,fun) states) - (funcall fun 'setup nil))) - ('exit - (pcase-dolist (`(,_ . ,fun) states) - (funcall fun 'exit nil))) - ('preview - (let ((selected-fun (cdr (assq src states)))) - ;; If the candidate source changed during preview communicate to - ;; the last source, that none of its candidates is previewed anymore. - (when (and last-fun (not (eq last-fun selected-fun))) - (funcall last-fun 'preview nil)) - (setq last-fun selected-fun) - (when selected-fun - (funcall selected-fun 'preview cand)))) - ('return - (let ((selected-fun (cdr (assq src states)))) - ;; Finish all the sources, except the selected one. - (pcase-dolist (`(,_ . ,fun) states) - (unless (eq fun selected-fun) - (funcall fun 'return nil))) - ;; Finish the source with the selected candidate - (when selected-fun - (funcall selected-fun 'return cand))))))))) - -(defun consult--multi (sources &rest options) - "Select from candidates taken from a list of SOURCES. - -OPTIONS is the plist of options passed to `consult--read'. The following -options are supported: :require-match, :history, :keymap, :initial, -:add-history, :sort and :inherit-input-method. The other options of -`consult--read' are used by the implementation of `consult--multi' and -should not be overwritten, except in in special scenarios. - -The function returns the selected candidate in the form (cons candidate -source-plist). The plist has the key :match with a value nil if the -candidate does not exist, t if the candidate exists and `new' if the -candidate has been created. The sources of the source list can either be -symbols of source variables or source values. Source values must be -plists with fields from the following list. - -Required source fields: -* :category - Completion category symbol. -* :items - List of strings to select from or function returning - list of strings. Note that the strings can use text properties - to carry metadata, which is then available to the :annotate, - :action and :state functions. - -Optional source fields: -* :name - Name of the source as a string, used for narrowing, - group titles and annotations. -* :narrow - Narrowing character or (character . string) pair. -* :enabled - Function which must return t if the source is enabled. -* :hidden - When t candidates of this source are hidden by default. -* :face - Face used for highlighting the candidates. -* :annotate - Annotation function called for each candidate, returns string. -* :history - Name of history variable to add selected candidate. -* :default - Must be t if the first item of the source is the default value. -* :action - Function called with the selected candidate. -* :new - Function called with new candidate name, only if :require-match is nil. -* :state - State constructor for the source, must return the - state function. The state function is informed about state - changes of the UI and can be used to implement preview. -* Other custom source fields can be added depending on the use - case. Note that the source is returned by `consult--multi' - together with the selected candidate." - (let* ((sources (consult--multi-enabled-sources sources)) - (candidates (consult--with-increased-gc - (consult--multi-candidates sources))) - (selected - (apply #'consult--read - candidates - (append - options - (list - :category 'multi-category - :predicate (apply-partially #'consult--multi-predicate sources) - :annotate (apply-partially #'consult--multi-annotate sources) - :group (apply-partially #'consult--multi-group sources) - :lookup (apply-partially #'consult--multi-lookup sources) - :preview-key (consult--multi-preview-key sources) - :narrow (consult--multi-narrow sources) - :state (consult--multi-state sources)))))) - (when-let (history (plist-get (cdr selected) :history)) - (add-to-history history (car selected))) - (if (plist-member (cdr selected) :match) - (when-let (fun (plist-get (cdr selected) :new)) - (funcall fun (car selected)) - (plist-put (cdr selected) :match 'new)) - (when-let (fun (plist-get (cdr selected) :action)) - (funcall fun (car selected))) - (setq selected `(,(car selected) :match t ,@(cdr selected)))) - selected)) - -;;;; Customization macro - -(defun consult--customize-put (cmds prop form) - "Set property PROP to FORM of commands CMDS." - (dolist (cmd cmds) - (cond - ((and (boundp cmd) (consp (symbol-value cmd))) - (setf (plist-get (symbol-value cmd) prop) (eval form 'lexical))) - ((functionp cmd) - (setf (plist-get (alist-get cmd consult--customize-alist) prop) form)) - (t (user-error "%s is neither a Command command nor a source" cmd)))) - nil) - -(defmacro consult-customize (&rest args) - "Set properties of commands or sources. -ARGS is a list of commands or sources followed by the list of -keyword-value pairs. For `consult-customize' to succeed, the -customized sources and commands must exist. When a command is -invoked, the value of `this-command' is used to lookup the -corresponding customization options." - (let (setter) - (while args - (let ((cmds (seq-take-while (lambda (x) (not (keywordp x))) args))) - (setq args (seq-drop-while (lambda (x) (not (keywordp x))) args)) - (while (keywordp (car args)) - (push `(consult--customize-put ',cmds ,(car args) ',(cadr args)) setter) - (setq args (cddr args))))) - (macroexp-progn setter))) - -(defun consult--customize-get () - "Get configuration from `consult--customize-alist' for `this-command'." - (mapcar (lambda (x) (eval x 'lexical)) - (alist-get this-command consult--customize-alist))) - -;;;; Commands - -;;;;; Command: consult-completion-in-region - -(defun consult--insertion-preview (start end) - "State function for previewing a candidate in a specific region. -The candidates are previewed in the region from START to END. This function is -used as the `:state' argument for `consult--read' in the `consult-yank' family -of functions and in `consult-completion-in-region'." - (unless (or (minibufferp) - ;; Disable preview if anything odd is going on with the markers. - ;; Otherwise we get "Marker points into wrong buffer errors". See - ;; gh:minad/consult#375, where Org mode source blocks are - ;; completed in a different buffer than the original buffer. This - ;; completion is probably also problematic in my Corfu completion - ;; package. - (not (eq (window-buffer) (current-buffer))) - (and (markerp start) (not (eq (marker-buffer start) (current-buffer)))) - (and (markerp end) (not (eq (marker-buffer end) (current-buffer))))) - (let (ov) - (lambda (action cand) - (cond - ((and (not cand) ov) - (delete-overlay ov) - (setq ov nil)) - ((and (eq action 'preview) cand) - (unless ov - (setq ov (consult--make-overlay start end - 'invisible t - 'window (selected-window)))) - ;; Use `add-face-text-property' on a copy of "cand in order to merge face properties - (setq cand (copy-sequence cand)) - (add-face-text-property 0 (length cand) 'consult-preview-insertion t cand) - ;; Use the `before-string' property since the overlay might be empty. - (overlay-put ov 'before-string cand))))))) - -;;;###autoload -(defun consult-completion-in-region (start end collection &optional predicate) - "Use minibuffer completion as the UI for `completion-at-point'. - -The function is called with 4 arguments: START END COLLECTION -PREDICATE. The arguments and expected return value are as -specified for `completion-in-region'. Use this function as a -value for `completion-in-region-function'." - (barf-if-buffer-read-only) - (let* ((initial (buffer-substring-no-properties start end)) - (metadata (completion-metadata initial collection predicate)) - ;; TODO: `minibuffer-completing-file-name' is mostly deprecated, but - ;; still in use. Packages should instead use the completion metadata. - (minibuffer-completing-file-name - (eq 'file (completion-metadata-get metadata 'category))) - (threshold (completion--cycle-threshold metadata)) - (all (completion-all-completions initial collection predicate (length initial))) - ;; Wrap all annotation functions to ensure that they are executed - ;; in the original buffer. - (exit-fun (plist-get completion-extra-properties :exit-function)) - (ann-fun (plist-get completion-extra-properties :annotation-function)) - (aff-fun (plist-get completion-extra-properties :affixation-function)) - (docsig-fun (plist-get completion-extra-properties :company-docsig)) - (completion-extra-properties - `(,@(and ann-fun (list :annotation-function (consult--in-buffer ann-fun))) - ,@(and aff-fun (list :affixation-function (consult--in-buffer aff-fun))) - ;; Provide `:annotation-function' if `:company-docsig' is specified. - ,@(and docsig-fun (not ann-fun) (not aff-fun) - (list :annotation-function - (consult--in-buffer - (lambda (cand) - (concat (propertize " " 'display '(space :align-to center)) - (funcall docsig-fun cand))))))))) - ;; error if `threshold' is t or the improper list `all' is too short - (if (and threshold - (or (not (consp (ignore-errors (nthcdr threshold all)))) - (and completion-cycling completion-all-sorted-completions))) - (completion--in-region start end collection predicate) - (let* ((limit (car (completion-boundaries initial collection predicate ""))) - (this-command #'consult-completion-in-region) - (completion - (cond - ((atom all) nil) - ((and (consp all) (atom (cdr all))) - (concat (substring initial 0 limit) (car all))) - (t - (consult--local-let ((enable-recursive-minibuffers t)) - ;; Evaluate completion table in the original buffer. - ;; This is a reasonable thing to do and required by - ;; some completion tables in particular by lsp-mode. - ;; See gh:minad/vertico#61. - (consult--read (consult--completion-table-in-buffer collection) - :prompt "Completion: " - :state (consult--insertion-preview start end) - :predicate predicate - :initial initial)))))) - (if completion - (progn - ;; bug#55205: completion--replace removes properties! - (completion--replace start end (setq completion (concat completion))) - (when exit-fun - (funcall exit-fun completion - ;; If completion is finished and cannot be further - ;; completed, return `finished'. Otherwise return - ;; `exact'. - (if (eq (try-completion completion collection predicate) t) - 'finished 'exact))) - t) - (message "No completion") - nil))))) - -;;;;; Command: consult-outline - -(defun consult--outline-candidates () - "Return alist of outline headings and positions." - (consult--forbid-minibuffer) - (let* ((line (line-number-at-pos (point-min) consult-line-numbers-widen)) - (heading-regexp (concat "^\\(?:" - ;; default definition from outline.el - (or (bound-and-true-p outline-regexp) "[*\^L]+") - "\\)")) - (heading-alist (bound-and-true-p outline-heading-alist)) - (level-fun (or (bound-and-true-p outline-level) - (lambda () ;; as in the default from outline.el - (or (cdr (assoc (match-string 0) heading-alist)) - (- (match-end 0) (match-beginning 0)))))) - (buffer (current-buffer)) - candidates) - (save-excursion - (goto-char (point-min)) - (while (save-excursion - (if-let (fun (bound-and-true-p outline-search-function)) - (funcall fun) - (re-search-forward heading-regexp nil t))) - (cl-incf line (consult--count-lines (match-beginning 0))) - (push (consult--location-candidate - (consult--buffer-substring (pos-bol) (pos-eol) 'fontify) - (cons buffer (point)) (1- line) (1- line) - 'consult--outline-level (funcall level-fun)) - candidates) - (goto-char (1+ (pos-eol))))) - (unless candidates - (user-error "No headings")) - (nreverse candidates))) - -;;;###autoload -(defun consult-outline (&optional level) - "Jump to an outline heading, obtained by matching against `outline-regexp'. - -This command supports narrowing to a heading level and candidate -preview. The initial narrowing LEVEL can be given as prefix -argument. The symbol at point is added to the future history." - (interactive - (list (and current-prefix-arg (prefix-numeric-value current-prefix-arg)))) - (let* ((candidates (consult--slow-operation - "Collecting headings..." - (consult--outline-candidates))) - (min-level (- (cl-loop for cand in candidates minimize - (get-text-property 0 'consult--outline-level cand)) - ?1)) - (narrow-pred (lambda (cand) - (<= (get-text-property 0 'consult--outline-level cand) - (+ consult--narrow min-level)))) - (narrow-keys (mapcar (lambda (c) (cons c (format "Level %c" c))) - (number-sequence ?1 ?9))) - (narrow-init (and level (max ?1 (min ?9 (+ level ?0)))))) - (consult--read - candidates - :prompt "Go to heading: " - :annotate (consult--line-prefix) - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--line-match - :narrow `(:predicate ,narrow-pred :keys ,narrow-keys :initial ,narrow-init) - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--location-state candidates)))) - -;;;;; Command: consult-mark - -(defun consult--mark-candidates (markers) - "Return list of candidates strings for MARKERS." - (consult--forbid-minibuffer) - (let ((candidates) - (current-buf (current-buffer))) - (save-excursion - (dolist (marker markers) - (when-let ((pos (marker-position marker)) - (buf (marker-buffer marker))) - (when (and (eq buf current-buf) - (consult--in-range-p pos)) - (goto-char pos) - ;; `line-number-at-pos' is a very slow function, which should be - ;; replaced everywhere. However in this case the slow - ;; line-number-at-pos does not hurt much, since the mark ring is - ;; usually small since it is limited by `mark-ring-max'. - (push (consult--location-candidate - (consult--line-with-mark marker) marker - (line-number-at-pos pos consult-line-numbers-widen) - marker) - candidates))))) - (unless candidates - (user-error "No marks")) - (nreverse (delete-dups candidates)))) - -;;;###autoload -(defun consult-mark (&optional markers) - "Jump to a marker in MARKERS list (defaults to buffer-local `mark-ring'). - -The command supports preview of the currently selected marker position. -The symbol at point is added to the future history." - (interactive) - (consult--read - (consult--mark-candidates - (or markers (cons (mark-marker) mark-ring))) - :prompt "Go to mark: " - :annotate (consult--line-prefix) - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--lookup-location - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--jump-state))) - -;;;;; Command: consult-global-mark - -(defun consult--global-mark-candidates (markers) - "Return list of candidates strings for MARKERS." - (consult--forbid-minibuffer) - (let ((candidates)) - (save-excursion - (dolist (marker markers) - (when-let ((pos (marker-position marker)) - (buf (marker-buffer marker))) - (unless (minibufferp buf) - (with-current-buffer buf - (when (consult--in-range-p pos) - (goto-char pos) - ;; `line-number-at-pos' is slow, see comment in `consult--mark-candidates'. - (let* ((line (line-number-at-pos pos consult-line-numbers-widen)) - (prefix (consult--format-file-line-match (buffer-name buf) line "")) - (cand (concat prefix (consult--line-with-mark marker) (consult--tofu-encode marker)))) - (put-text-property 0 (length prefix) 'consult-strip t cand) - (put-text-property 0 (length cand) 'consult-location (cons marker line) cand) - (push cand candidates)))))))) - (unless candidates - (user-error "No global marks")) - (nreverse (delete-dups candidates)))) - -;;;###autoload -(defun consult-global-mark (&optional markers) - "Jump to a marker in MARKERS list (defaults to `global-mark-ring'). - -The command supports preview of the currently selected marker position. -The symbol at point is added to the future history." - (interactive) - (consult--read - (consult--global-mark-candidates - (or markers global-mark-ring)) - :prompt "Go to global mark: " - ;; Despite `consult-global-mark' formatting the candidates in grep-like - ;; style, we are not using the `consult-grep' category, since the candidates - ;; have location markers attached. - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--lookup-location - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--jump-state))) - -;;;;; Command: consult-line - -(defun consult--line-candidates (top curr-line) - "Return list of line candidates. -Start from top if TOP non-nil. -CURR-LINE is the current line number." - (consult--forbid-minibuffer) - (consult--fontify-all) - (let* ((buffer (current-buffer)) - (line (line-number-at-pos (point-min) consult-line-numbers-widen)) - default-cand candidates) - (consult--each-line beg end - (unless (looking-at-p "^\\s-*$") - (push (consult--location-candidate - (consult--buffer-substring beg end) - (cons buffer beg) line line) - candidates) - (when (and (not default-cand) (>= line curr-line)) - (setq default-cand candidates))) - (cl-incf line)) - (unless candidates - (user-error "No lines")) - (nreverse - (if (or top (not default-cand)) - candidates - (let ((before (cdr default-cand))) - (setcdr default-cand nil) - (nconc before candidates)))))) - -(defun consult--line-point-placement (selected candidates highlighted &rest ignored-faces) - "Find point position on matching line. -SELECTED is the currently selected candidate. -CANDIDATES is the list of candidates. -HIGHLIGHTED is the highlighted string to determine the match position. -IGNORED-FACES are ignored when determining the match position." - (when-let (pos (consult--lookup-location selected candidates)) - (if highlighted - (let* ((matches (apply #'consult--point-placement highlighted 0 ignored-faces)) - (dest (+ pos (car matches)))) - ;; Only create a new marker when jumping across buffers (for example - ;; `consult-line-multi'). Avoid creating unnecessary markers, when - ;; scrolling through candidates, since creating markers is not free. - (when (and (markerp pos) (not (eq (marker-buffer pos) (current-buffer)))) - (setq dest (move-marker (make-marker) dest (marker-buffer pos)))) - (cons dest (cdr matches))) - pos))) - -(defun consult--line-match (selected candidates input &rest _) - "Lookup position of match. -SELECTED is the currently selected candidate. -CANDIDATES is the list of candidates. -INPUT is the input string entered by the user." - (consult--line-point-placement selected candidates - (and (not (string-blank-p input)) - (car (consult--completion-filter - input - (list (substring-no-properties selected)) - 'consult-location 'highlight))) - 'completions-first-difference)) - -;;;###autoload -(defun consult-line (&optional initial start) - "Search for a matching line. - -Depending on the setting `consult-point-placement' the command -jumps to the beginning or the end of the first match on the line -or the line beginning. The default candidate is the non-empty -line next to point. This command obeys narrowing. Optional -INITIAL input can be provided. The search starting point is -changed if the START prefix argument is set. The symbol at point -and the last `isearch-string' is added to the future history." - (interactive (list nil (not (not current-prefix-arg)))) - (let* ((curr-line (line-number-at-pos (point) consult-line-numbers-widen)) - (top (not (eq start consult-line-start-from-top))) - (candidates (consult--slow-operation "Collecting lines..." - (consult--line-candidates top curr-line)))) - (consult--read - candidates - :prompt (if top "Go to line from top: " "Go to line: ") - :annotate (consult--line-prefix curr-line) - :category 'consult-location - :sort nil - :require-match t - ;; Always add last `isearch-string' to future history - :add-history (list (thing-at-point 'symbol) isearch-string) - :history '(:input consult--line-history) - :lookup #'consult--line-match - :default (car candidates) - ;; Add `isearch-string' as initial input if starting from Isearch - :initial (or initial - (and isearch-mode - (prog1 isearch-string (isearch-done)))) - :state (consult--location-state candidates)))) - -;;;;; Command: consult-line-multi - -(defun consult--line-multi-match (selected candidates &rest _) - "Lookup position of match. -SELECTED is the currently selected candidate. -CANDIDATES is the list of candidates." - (consult--line-point-placement selected candidates - (car (member selected candidates)))) - -(defun consult--line-multi-group (cand transform) - "Group function used by `consult-line-multi'. -If TRANSFORM non-nil, return transformed CAND, otherwise return title." - (if transform cand - (let* ((marker (car (get-text-property 0 'consult-location cand))) - (buf (if (consp marker) - (car marker) ;; Handle cheap marker - (marker-buffer marker)))) - (if buf (buffer-name buf) "Dead buffer")))) - -(defun consult--line-multi-candidates (buffers input) - "Collect matching candidates from multiple buffers. -INPUT is the user input which should be matched. -BUFFERS is the list of buffers." - (pcase-let ((`(,regexps . ,hl) - (funcall consult--regexp-compiler - input 'emacs completion-ignore-case)) - (candidates nil) - (cand-idx 0)) - (save-match-data - (dolist (buf buffers (nreverse candidates)) - (with-current-buffer buf - (save-excursion - (let ((line (line-number-at-pos (point-min) consult-line-numbers-widen))) - (goto-char (point-min)) - (while (and (not (eobp)) - (save-excursion (re-search-forward (car regexps) nil t))) - (cl-incf line (consult--count-lines (match-beginning 0))) - (let ((bol (pos-bol)) - (eol (pos-eol))) - (goto-char bol) - (when (and (not (looking-at-p "^\\s-*$")) - (seq-every-p (lambda (r) - (goto-char bol) - (re-search-forward r eol t)) - (cdr regexps))) - (push (consult--location-candidate - (funcall hl (buffer-substring-no-properties bol eol)) - (cons buf bol) (1- line) cand-idx) - candidates) - (cl-incf cand-idx)) - (goto-char (1+ eol))))))))))) - -;;;###autoload -(defun consult-line-multi (query &optional initial) - "Search for a matching line in multiple buffers. - -By default search across all project buffers. If the prefix -argument QUERY is non-nil, all buffers are searched. Optional -INITIAL input can be provided. The symbol at point and the last -`isearch-string' is added to the future history. In order to -search a subset of buffers, QUERY can be set to a plist according -to `consult--buffer-query'." - (interactive "P") - (unless (keywordp (car-safe query)) - (setq query (list :sort 'alpha-current :directory (and (not query) 'project)))) - (pcase-let* ((`(,prompt . ,buffers) (consult--buffer-query-prompt "Go to line" query)) - (collection (consult--dynamic-collection - (apply-partially #'consult--line-multi-candidates - buffers)))) - (consult--read - collection - :prompt prompt - :annotate (consult--line-prefix) - :category 'consult-location - :sort nil - :require-match t - ;; Always add last Isearch string to future history - :add-history (mapcar #'consult--async-split-initial - (delq nil (list (thing-at-point 'symbol) - isearch-string))) - :history '(:input consult--line-multi-history) - :lookup #'consult--line-multi-match - ;; Add `isearch-string' as initial input if starting from Isearch - :initial (consult--async-split-initial - (or initial - (and isearch-mode - (prog1 isearch-string (isearch-done))))) - :state (consult--location-state (lambda () (funcall collection nil))) - :group #'consult--line-multi-group))) - -;;;;; Command: consult-keep-lines - -(defun consult--keep-lines-state (filter) - "State function for `consult-keep-lines' with FILTER function." - (let ((font-lock-orig font-lock-mode) - (whitespace-orig (bound-and-true-p whitespace-mode)) - (hl-line-orig (bound-and-true-p hl-line-mode)) - (point-orig (point)) - lines content-orig replace last-input) - (if (use-region-p) - (save-restriction - ;; Use the same behavior as `keep-lines'. - (let ((rbeg (region-beginning)) - (rend (save-excursion - (goto-char (region-end)) - (unless (or (bolp) (eobp)) - (forward-line 0)) - (point)))) - (consult--fontify-region rbeg rend) - (narrow-to-region rbeg rend) - (consult--each-line beg end - (push (consult--buffer-substring beg end) lines)) - (setq content-orig (buffer-string) - replace (lambda (content &optional pos) - (delete-region rbeg rend) - (insert-before-markers content) - (goto-char (or pos rbeg)) - (setq rend (+ rbeg (length content))) - (add-face-text-property rbeg rend 'region t))))) - (consult--fontify-all) - (setq content-orig (buffer-string) - replace (lambda (content &optional pos) - (delete-region (point-min) (point-max)) - (insert content) - (goto-char (or pos (point-min))))) - (consult--each-line beg end - (push (consult--buffer-substring beg end) lines))) - (setq lines (nreverse lines)) - (lambda (action input) - ;; Restoring content and point position - (when (and (eq action 'return) last-input) - ;; No undo recording, modification hooks, buffer modified-status - (with-silent-modifications (funcall replace content-orig point-orig))) - ;; Committing or new input provided -> Update - (when (and input ;; Input has been provided - (or - ;; Committing, but not with empty input - (and (eq action 'return) (not (string-match-p "\\`!? ?\\'" input))) - ;; Input has changed - (not (equal input last-input)))) - (let ((filtered-content - (if (string-match-p "\\`!? ?\\'" input) - ;; Special case the empty input for performance. - ;; Otherwise it could happen that the minibuffer is empty, - ;; but the buffer has not been updated. - content-orig - (if (eq action 'return) - (apply #'concat (mapcan (lambda (x) (list x "\n")) - (funcall filter input lines))) - (while-no-input - ;; Heavy computation is interruptible if *not* committing! - ;; Allocate new string candidates since the matching function mutates! - (apply #'concat (mapcan (lambda (x) (list x "\n")) - (funcall filter input (mapcar #'copy-sequence lines))))))))) - (when (stringp filtered-content) - (when font-lock-mode (font-lock-mode -1)) - (when (bound-and-true-p whitespace-mode) (whitespace-mode -1)) - (when (bound-and-true-p hl-line-mode) (hl-line-mode -1)) - (if (eq action 'return) - (atomic-change-group - ;; Disable modification hooks for performance - (let ((inhibit-modification-hooks t)) - (funcall replace filtered-content))) - ;; No undo recording, modification hooks, buffer modified-status - (with-silent-modifications - (funcall replace filtered-content) - (setq last-input input)))))) - ;; Restore modes - (when (eq action 'return) - (when hl-line-orig (hl-line-mode 1)) - (when whitespace-orig (whitespace-mode 1)) - (when font-lock-orig (font-lock-mode 1)))))) - -;;;###autoload -(defun consult-keep-lines (filter &optional initial) - "Select a subset of the lines in the current buffer with live preview. - -The selected lines are kept and the other lines are deleted. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. When -called from Elisp, the filtering is performed by a FILTER function. This -command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input." - (interactive - (list (lambda (pattern cands) - ;; Use consult-location completion category when filtering lines - (consult--completion-filter-dispatch - pattern cands 'consult-location 'highlight)))) - (consult--forbid-minibuffer) - (let ((ro buffer-read-only)) - (unwind-protect - (minibuffer-with-setup-hook - (lambda () - (when ro - (minibuffer-message - (substitute-command-keys - " [Unlocked read-only buffer. \\[minibuffer-keyboard-quit] to quit.]")))) - (setq buffer-read-only nil) - (consult--with-increased-gc - (consult--prompt - :prompt "Keep lines: " - :initial initial - :history 'consult--line-history - :state (consult--keep-lines-state filter)))) - (setq buffer-read-only ro)))) - -;;;;; Command: consult-focus-lines - -(defun consult--focus-lines-state (filter) - "State function for `consult-focus-lines' with FILTER function." - (let (lines overlays last-input pt-orig pt-min pt-max) - (save-excursion - (save-restriction - (if (not (use-region-p)) - (consult--fontify-all) - (consult--fontify-region (region-beginning) (region-end)) - (narrow-to-region - (region-beginning) - ;; Behave the same as `keep-lines'. - ;; Move to the next line. - (save-excursion - (goto-char (region-end)) - (unless (or (bolp) (eobp)) - (forward-line 0)) - (point)))) - (setq pt-orig (point) pt-min (point-min) pt-max (point-max)) - (let ((i 0)) - (consult--each-line beg end - ;; Use "\n" for empty lines, since we need a non-empty string to - ;; attach the text property to. - (let ((line (if (eq beg end) (char-to-string ?\n) - (buffer-substring-no-properties beg end)))) - (put-text-property 0 1 'consult--focus-line (cons (cl-incf i) beg) line) - (push line lines))) - (setq lines (nreverse lines))))) - (lambda (action input) - ;; New input provided -> Update - (when (and input (not (equal input last-input))) - (let (new-overlays) - (pcase (while-no-input - (unless (string-match-p "\\`!? ?\\'" input) ;; Empty input. - (let* ((inhibit-quit (eq action 'return)) ;; Non interruptible, when quitting! - (not (string-prefix-p "! " input)) - (stripped (string-remove-prefix "! " input)) - (matches (funcall filter stripped lines)) - (old-ind 0) - (block-beg pt-min) - (block-end pt-min)) - (while old-ind - (let ((match (pop matches)) (ind nil) (beg pt-max) (end pt-max) prop) - (when match - (setq prop (get-text-property 0 'consult--focus-line match) - ind (car prop) - beg (cdr prop) - ;; Check for empty lines, see above. - end (+ 1 beg (if (equal match "\n") 0 (length match))))) - (unless (eq ind (1+ old-ind)) - (let ((a (if not block-beg block-end)) - (b (if not block-end beg))) - (when (/= a b) - (push (consult--make-overlay a b 'invisible t) new-overlays))) - (setq block-beg beg)) - (setq block-end end old-ind ind))))) - 'commit) - ('commit - (mapc #'delete-overlay overlays) - (setq last-input input overlays new-overlays)) - (_ (mapc #'delete-overlay new-overlays))))) - (when (eq action 'return) - (cond - ((not input) - (mapc #'delete-overlay overlays) - (goto-char pt-orig)) - ((equal input "") - (consult-focus-lines nil 'show) - (goto-char pt-orig)) - (t - ;; Successfully terminated -> Remember invisible overlays - (setq consult--focus-lines-overlays - (nconc consult--focus-lines-overlays overlays)) - ;; move point past invisible - (goto-char (if-let (ov (and (invisible-p pt-orig) - (seq-find (lambda (ov) (overlay-get ov 'invisible)) - (overlays-at pt-orig)))) - (overlay-end ov) - pt-orig)))))))) - -;;;###autoload -(defun consult-focus-lines (filter &optional show initial) - "Hide or show lines using overlays. - -The selected lines are shown and the other lines hidden. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. With -optional prefix argument SHOW reveal the hidden lines. Alternatively the -command can be restarted to reveal the lines. When called from Elisp, the -filtering is performed by a FILTER function. This command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input." - (interactive - (list (lambda (pattern cands) - ;; Use consult-location completion category when filtering lines - (consult--completion-filter-dispatch - pattern cands 'consult-location nil)) - current-prefix-arg)) - (if show - (progn - (mapc #'delete-overlay consult--focus-lines-overlays) - (setq consult--focus-lines-overlays nil) - (message "All lines revealed")) - (consult--forbid-minibuffer) - (consult--with-increased-gc - (consult--prompt - :prompt - (if consult--focus-lines-overlays - "Focus on lines (RET to reveal): " - "Focus on lines: ") - :initial initial - :history 'consult--line-history - :state (consult--focus-lines-state filter))))) - -;;;;; Command: consult-goto-line - -(defun consult--goto-line-position (str msg) - "Transform input STR to line number. -Print an error message with MSG function." - (save-match-data - (if (and str (string-match "\\`\\([[:digit:]]+\\):?\\([[:digit:]]*\\)\\'" str)) - (let ((line (string-to-number (match-string 1 str))) - (col (string-to-number (match-string 2 str)))) - (save-excursion - (save-restriction - (when consult-line-numbers-widen - (widen)) - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (min (+ (point) col) (pos-eol))) - (point)))) - (when (and str (not (equal str ""))) - (funcall msg "Please enter a number.")) - nil))) - -;;;###autoload -(defun consult-goto-line (&optional arg) - "Read line number and jump to the line with preview. - -Enter either a line number to jump to the first column of the -given line or line:column in order to jump to a specific column. -Jump directly if a line number is given as prefix ARG. The -command respects narrowing and the settings -`consult-goto-line-numbers' and `consult-line-numbers-widen'." - (interactive "P") - (if arg - (call-interactively #'goto-line) - (consult--forbid-minibuffer) - (consult--local-let ((display-line-numbers consult-goto-line-numbers) - (display-line-numbers-widen consult-line-numbers-widen)) - (while (if-let (pos (consult--goto-line-position - (consult--prompt - :prompt "Go to line: " - :history 'goto-line-history - :state - (let ((preview (consult--jump-preview))) - (lambda (action str) - (funcall preview action - (consult--goto-line-position str #'ignore))))) - #'minibuffer-message)) - (consult--jump pos) - t))))) - -;;;;; Command: consult-recent-file - -(defun consult--file-preview () - "Create preview function for files." - (let ((open (consult--temporary-files)) - (preview (consult--buffer-preview))) - (lambda (action cand) - (unless cand - (funcall open)) - (funcall preview action - (and cand - (eq action 'preview) - (funcall open cand)))))) - -(defun consult--file-action (file) - "Open FILE via `consult--buffer-action'." - ;; Try to preserve the buffer as is, if it has already been opened, for - ;; example in literal or raw mode. - (setq file (abbreviate-file-name (expand-file-name file))) - (consult--buffer-action (or (get-file-buffer file) (find-file-noselect file)))) - -(consult--define-state file) - -;;;###autoload -(defun consult-recent-file () - "Find recent file using `completing-read'." - (interactive) - (find-file - (consult--read - (or - (mapcar #'consult--fast-abbreviate-file-name (bound-and-true-p recentf-list)) - (user-error "No recent files, `recentf-mode' is %s" - (if recentf-mode "enabled" "disabled"))) - :prompt "Find recent file: " - :sort nil - :require-match t - :category 'file - :state (consult--file-preview) - :history 'file-name-history))) - -;;;;; Command: consult-mode-command - -(defun consult--mode-name (mode) - "Return name part of MODE." - (replace-regexp-in-string - "global-\\(.*\\)-mode" "\\1" - (replace-regexp-in-string - "\\(-global\\)?-mode\\'" "" - (if (eq mode 'c-mode) - "cc" - (symbol-name mode)) - 'fixedcase) - 'fixedcase)) - -(defun consult--mode-command-candidates (modes) - "Extract commands from MODES. - -The list of features is searched for files belonging to the modes. -From these files, the commands are extracted." - (let* ((case-fold-search) - (buffer (current-buffer)) - (command-filter (consult--regexp-filter (seq-filter #'stringp consult-mode-command-filter))) - (feature-filter (seq-filter #'symbolp consult-mode-command-filter)) - (minor-hash (consult--string-hash minor-mode-list)) - (minor-local-modes (seq-filter (lambda (m) - (and (gethash m minor-hash) - (local-variable-if-set-p m))) - modes)) - (minor-global-modes (seq-filter (lambda (m) - (and (gethash m minor-hash) - (not (local-variable-if-set-p m)))) - modes)) - (major-modes (seq-remove (lambda (m) - (gethash m minor-hash)) - modes)) - (major-paths-hash (consult--string-hash (mapcar #'symbol-file major-modes))) - (minor-local-paths-hash (consult--string-hash (mapcar #'symbol-file minor-local-modes))) - (minor-global-paths-hash (consult--string-hash (mapcar #'symbol-file minor-global-modes))) - (major-name-regexp (regexp-opt (mapcar #'consult--mode-name major-modes))) - (minor-local-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-local-modes))) - (minor-global-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-global-modes))) - (commands)) - (dolist (feature load-history commands) - (when-let (name (alist-get 'provide feature)) - (let* ((path (car feature)) - (file (file-name-nondirectory path)) - (key (cond - ((memq name feature-filter) nil) - ((or (gethash path major-paths-hash) - (string-match-p major-name-regexp file)) - ?m) - ((or (gethash path minor-local-paths-hash) - (string-match-p minor-local-name-regexp file)) - ?l) - ((or (gethash path minor-global-paths-hash) - (string-match-p minor-global-name-regexp file)) - ?g)))) - (when key - (dolist (cmd (cdr feature)) - (let ((sym (cdr-safe cmd))) - (when (and (consp cmd) - (eq (car cmd) 'defun) - (commandp sym) - (not (get sym 'byte-obsolete-info)) - (or (not read-extended-command-predicate) - (funcall read-extended-command-predicate sym buffer))) - (let ((name (symbol-name sym))) - (unless (string-match-p command-filter name) - (push (propertize name - 'consult--candidate sym - 'consult--type key) - commands)))))))))))) - -;;;###autoload -(defun consult-mode-command (&rest modes) - "Run a command from any of the given MODES. - -If no MODES are specified, use currently active major and minor modes." - (interactive) - (unless modes - (setq modes (cons major-mode - (seq-filter (lambda (m) - (and (boundp m) (symbol-value m))) - minor-mode-list)))) - (let ((narrow `((?m . ,(format "Major: %s" major-mode)) - (?l . "Local Minor") - (?g . "Global Minor")))) - (command-execute - (consult--read - (consult--mode-command-candidates modes) - :prompt "Mode command: " - :predicate - (lambda (cand) - (let ((key (get-text-property 0 'consult--type cand))) - (if consult--narrow - (= key consult--narrow) - (/= key ?g)))) - :lookup #'consult--lookup-candidate - :group (consult--type-group narrow) - :narrow narrow - :require-match t - :history 'extended-command-history - :category 'command)))) - -;;;;; Command: consult-yank - -(defun consult--read-from-kill-ring () - "Open kill ring menu and return selected string." - ;; `current-kill' updates `kill-ring' with interprogram paste, see - ;; gh:minad/consult#443. - (current-kill 0) - ;; Do not specify a :lookup function in order to preserve completion-styles - ;; highlighting of the current candidate. We have to perform a final lookup to - ;; obtain the original candidate which may be propertized with yank-specific - ;; properties, like 'yank-handler. - (consult--lookup-member - (consult--read - (consult--remove-dups - (or (if yank-from-kill-ring-rotate - (append kill-ring-yank-pointer - (butlast kill-ring (length kill-ring-yank-pointer))) - kill-ring) - (user-error "Kill ring is empty"))) - :prompt "Yank from kill-ring: " - :history t ;; disable history - :sort nil - :category 'kill-ring - :require-match t - :state - (consult--insertion-preview - (point) - ;; If previous command is yank, hide previously yanked string - (or (and (eq last-command 'yank) (mark t)) (point)))) - kill-ring)) - -;; Adapted from the Emacs `yank-from-kill-ring' function. -;;;###autoload -(defun consult-yank-from-kill-ring (string &optional arg) - "Select STRING from the kill ring and insert it. -With prefix ARG, put point at beginning, and mark at end, like `yank' does. - -This command behaves like `yank-from-kill-ring', which also offers a -`completing-read' interface to the `kill-ring'. Additionally the -Consult version supports preview of the selected string." - (interactive (list (consult--read-from-kill-ring) current-prefix-arg)) - (when string - (setq yank-window-start (window-start)) - (push-mark) - (insert-for-yank string) - (setq this-command 'yank) - (when yank-from-kill-ring-rotate - (if-let (pos (seq-position kill-ring string)) - (setq kill-ring-yank-pointer (nthcdr pos kill-ring)) - (kill-new string))) - (when (consp arg) - ;; Swap point and mark like in `yank'. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer))))))) - -(put 'consult-yank-replace 'delete-selection 'yank) -(put 'consult-yank-pop 'delete-selection 'yank) -(put 'consult-yank-from-kill-ring 'delete-selection 'yank) - -;;;###autoload -(defun consult-yank-pop (&optional arg) - "If there is a recent yank act like `yank-pop'. - -Otherwise select string from the kill ring and insert it. -See `yank-pop' for the meaning of ARG. - -This command behaves like `yank-pop', which also offers a -`completing-read' interface to the `kill-ring'. Additionally the -Consult version supports preview of the selected string." - (interactive "*p") - (if (eq last-command 'yank) - (yank-pop (or arg 1)) - (call-interactively #'consult-yank-from-kill-ring))) - -;; Adapted from the Emacs yank-pop function. -;;;###autoload -(defun consult-yank-replace (string) - "Select STRING from the kill ring. - -If there was no recent yank, insert the string. -Otherwise replace the just-yanked string with the selected string." - (interactive (list (consult--read-from-kill-ring))) - (when string - (if (not (eq last-command 'yank)) - (consult-yank-from-kill-ring string) - (let ((inhibit-read-only t) - (pt (point)) - (mk (mark t))) - (setq this-command 'yank) - (funcall (or yank-undo-function 'delete-region) (min pt mk) (max pt mk)) - (setq yank-undo-function nil) - (set-marker (mark-marker) pt (current-buffer)) - (insert-for-yank string) - (set-window-start (selected-window) yank-window-start t) - (if (< pt mk) - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer))))))))) - -;;;;; Command: consult-bookmark - -(defun consult--bookmark-preview () - "Create preview function for bookmarks." - (let ((preview (consult--jump-preview)) - (open (consult--temporary-files))) - (lambda (action cand) - (unless cand - (funcall open)) - (funcall - preview action - ;; Only preview bookmarks with the default handler. - (when-let ((bm (and cand (eq action 'preview) (assoc cand bookmark-alist))) - (handler (or (bookmark-get-handler bm) #'bookmark-default-handler)) - ((eq handler #'bookmark-default-handler)) - (file (bookmark-get-filename bm)) - (pos (bookmark-get-position bm)) - (buf (funcall open file))) - (set-marker (make-marker) pos buf)))))) - -(defun consult--bookmark-action (bm) - "Open BM via `consult--buffer-action'." - (bookmark-jump bm consult--buffer-display)) - -(consult--define-state bookmark) - -(defun consult--bookmark-candidates () - "Return bookmark candidates." - (bookmark-maybe-load-default-file) - (let ((narrow (cl-loop for (y _ . xs) in consult-bookmark-narrow nconc - (cl-loop for x in xs collect (cons x y))))) - (cl-loop for bm in bookmark-alist collect - (propertize (car bm) - 'consult--type - (alist-get - (or (bookmark-get-handler bm) #'bookmark-default-handler) - narrow))))) - -;;;###autoload -(defun consult-bookmark (name) - "If bookmark NAME exists, open it, otherwise create a new bookmark with NAME. - -The command supports preview of file bookmarks and narrowing. See the -variable `consult-bookmark-narrow' for the narrowing configuration." - (interactive - (list - (let ((narrow (cl-loop for (x y . _) in consult-bookmark-narrow collect (cons x y)))) - (consult--read - (consult--bookmark-candidates) - :prompt "Bookmark: " - :state (consult--bookmark-preview) - :category 'bookmark - :history 'bookmark-history - ;; Add default names to future history. - ;; Ignore errors such that `consult-bookmark' can be used in - ;; buffers which are not backed by a file. - :add-history (ignore-errors (bookmark-prop-get (bookmark-make-record) 'defaults)) - :group (consult--type-group narrow) - :narrow (consult--type-narrow narrow))))) - (bookmark-maybe-load-default-file) - (if (assoc name bookmark-alist) - (bookmark-jump name) - (bookmark-set name))) - -;;;;; Command: consult-complex-command - -;;;###autoload -(defun consult-complex-command () - "Select and evaluate command from the command history. - -This command can act as a drop-in replacement for `repeat-complex-command'." - (interactive) - (let* ((history (or (delete-dups (mapcar #'prin1-to-string command-history)) - (user-error "There are no previous complex commands"))) - (cmd (read (consult--read - history - :prompt "Command: " - :default (car history) - :sort nil - :history t ;; disable history - :category 'expression)))) - ;; Taken from `repeat-complex-command' - (add-to-history 'command-history cmd) - (apply #'funcall-interactively - (car cmd) - (mapcar (lambda (e) (eval e t)) (cdr cmd))))) - -;;;;; Command: consult-history - -(declare-function ring-elements "ring") - -(defun consult--current-history () - "Return the history and index variable relevant to the current buffer. -If the minibuffer is active, the minibuffer history is returned, -otherwise the history corresponding to the mode. There is a -special case for `repeat-complex-command', for which the command -history is used." - (cond - ;; In the minibuffer we use the current minibuffer history, - ;; which can be configured by setting `minibuffer-history-variable'. - ((minibufferp) - (when (eq minibuffer-history-variable t) - (user-error "Minibuffer history is disabled for `%s'" this-command)) - (list (mapcar #'consult--tofu-hide - (if (eq minibuffer-history-variable 'command-history) - ;; If pressing "C-x M-:", i.e., `repeat-complex-command', - ;; we are instead querying the `command-history' and get a - ;; full s-expression. Alternatively you might want to use - ;; `consult-complex-command', which can also be bound to - ;; "C-x M-:"! - (mapcar #'prin1-to-string command-history) - (symbol-value minibuffer-history-variable))))) - ;; Otherwise we use a mode-specific history, see `consult-mode-histories'. - (t (let ((found (seq-find (lambda (h) - (and (derived-mode-p (car h)) - (boundp (if (consp (cdr h)) (cadr h) (cdr h))))) - consult-mode-histories))) - (unless found - (user-error "No history configured for `%s', see `consult-mode-histories'" - major-mode)) - (cons (symbol-value (cadr found)) (cddr found)))))) - -;;;###autoload -(defun consult-history (&optional history index bol) - "Insert string from HISTORY of current buffer. -In order to select from a specific HISTORY, pass the history -variable as argument. INDEX is the name of the index variable to -update, if any. BOL is the function which jumps to the beginning -of the prompt. See also `cape-history' from the Cape package." - (interactive) - (pcase-let* ((`(,history ,index ,bol) (if history - (list history index bol) - (consult--current-history))) - (history (if (ring-p history) (ring-elements history) history)) - (`(,beg . ,end) - (if (minibufferp) - (cons (minibuffer-prompt-end) (point-max)) - (if bol - (save-excursion - (funcall bol) - (cons (point) (pos-eol))) - (cons (point) (point))))) - (str (consult--local-let ((enable-recursive-minibuffers t)) - (consult--read - (or (consult--remove-dups history) - (user-error "History is empty")) - :prompt "History: " - :history t ;; disable history - :category ;; Report category depending on history variable - (and (minibufferp) - (pcase minibuffer-history-variable - ('extended-command-history 'command) - ('buffer-name-history 'buffer) - ('face-name-history 'face) - ('read-envvar-name-history 'environment-variable) - ('bookmark-history 'bookmark) - ('file-name-history 'file))) - :sort nil - :initial (buffer-substring-no-properties beg end) - :state (consult--insertion-preview beg end))))) - (delete-region beg end) - (when index - (set index (seq-position history str))) - (insert (substring-no-properties str)))) - -;;;;; Command: consult-isearch-history - -(defun consult-isearch-forward (&optional reverse) - "Continue Isearch forward optionally in REVERSE." - (declare (completion ignore)) - (interactive) - (consult--require-minibuffer) - (setq isearch-new-forward (not reverse) isearch-new-nonincremental nil) - (funcall (or (command-remapping #'exit-minibuffer) #'exit-minibuffer))) - -(defun consult-isearch-backward (&optional reverse) - "Continue Isearch backward optionally in REVERSE." - (declare (completion ignore)) - (interactive) - (consult-isearch-forward (not reverse))) - -(defvar-keymap consult-isearch-history-map - :doc "Additional keymap used by `consult-isearch-history'." - "<remap> <isearch-forward>" #'consult-isearch-forward - "<remap> <isearch-backward>" #'consult-isearch-backward) - -(defun consult--isearch-history-candidates () - "Return Isearch history candidates." - ;; Do not throw an error on empty history, in order to allow starting a - ;; search. We do not :require-match here. - (let ((history (if (eq t search-default-mode) - (append regexp-search-ring search-ring) - (append search-ring regexp-search-ring)))) - (delete-dups - (mapcar - (lambda (cand) - ;; The search type can be distinguished via text properties. - (let* ((props (plist-member (text-properties-at 0 cand) - 'isearch-regexp-function)) - (type (pcase (cadr props) - ((and 'nil (guard (not props))) ?r) - ('nil ?l) - ('word-search-regexp ?w) - ('isearch-symbol-regexp ?s) - ('char-fold-to-regexp ?c) - (_ ?u)))) - ;; Disambiguate history items. The same string could - ;; occur with different search types. - (consult--tofu-append cand type))) - history)))) - -(defconst consult--isearch-history-narrow - '((?c . "Char") - (?u . "Custom") - (?l . "Literal") - (?r . "Regexp") - (?s . "Symbol") - (?w . "Word"))) - -;;;###autoload -(defun consult-isearch-history () - "Read a search string with completion from the Isearch history. - -This replaces the current search string if Isearch is active, and -starts a new Isearch session otherwise." - (interactive) - (consult--forbid-minibuffer) - (let* ((isearch-message-function #'ignore) - (cursor-in-echo-area t) ;; Avoid cursor flickering - (candidates (consult--isearch-history-candidates))) - (unless isearch-mode (isearch-mode t)) - (with-isearch-suspended - (setq isearch-new-string - (consult--read - candidates - :prompt "I-search: " - :category 'consult-isearch-history - :history t ;; disable history - :sort nil - :initial isearch-string - :keymap consult-isearch-history-map - :annotate - (lambda (cand) - (consult--annotate-align - cand - (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) - :group - (lambda (cand transform) - (if transform - cand - (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) - :lookup - (lambda (selected candidates &rest _) - (if-let (found (member selected candidates)) - (substring (car found) 0 -1) - selected)) - :state - (lambda (action cand) - (when (and (eq action 'preview) cand) - (setq isearch-string cand) - (isearch-update-from-string-properties cand) - (isearch-update))) - :narrow - (list :predicate - (lambda (cand) (= (consult--tofu-get cand) consult--narrow)) - :keys consult--isearch-history-narrow)) - isearch-new-message - (mapconcat 'isearch-text-char-description isearch-new-string ""))) - ;; Setting `isearch-regexp' etc only works outside of `with-isearch-suspended'. - (unless (plist-member (text-properties-at 0 isearch-string) 'isearch-regexp-function) - (setq isearch-regexp t - isearch-regexp-function nil)))) - -;;;;; Command: consult-minor-mode-menu - -(defun consult--minor-mode-candidates () - "Return list of minor-mode candidate strings." - (mapcar - (pcase-lambda (`(,name . ,sym)) - (propertize - name - 'consult--candidate sym - 'consult--minor-mode-narrow - (logior - (ash (if (local-variable-if-set-p sym) ?l ?g) 8) - (if (and (boundp sym) (symbol-value sym)) ?i ?o)) - 'consult--minor-mode-group - (concat - (if (local-variable-if-set-p sym) "Local " "Global ") - (if (and (boundp sym) (symbol-value sym)) "On" "Off")))) - (nconc - ;; according to describe-minor-mode-completion-table-for-symbol - ;; the minor-mode-list contains *all* minor modes - (mapcar (lambda (sym) (cons (symbol-name sym) sym)) minor-mode-list) - ;; take the lighters from minor-mode-alist - (delq nil - (mapcar (pcase-lambda (`(,sym ,lighter)) - (when (and lighter (not (equal "" lighter))) - (let (message-log-max) - (setq lighter (string-trim (format-mode-line lighter))) - (unless (string-blank-p lighter) - (cons lighter sym))))) - minor-mode-alist))))) - -(defconst consult--minor-mode-menu-narrow - '((?l . "Local") - (?g . "Global") - (?i . "On") - (?o . "Off"))) - -;;;###autoload -(defun consult-minor-mode-menu () - "Enable or disable minor mode. - -This is an alternative to `minor-mode-menu-from-indicator'." - (interactive) - (call-interactively - (consult--read - (consult--minor-mode-candidates) - :prompt "Minor mode: " - :require-match t - :category 'minor-mode - :group - (lambda (cand transform) - (if transform cand (get-text-property 0 'consult--minor-mode-group cand))) - :narrow - (list :predicate - (lambda (cand) - (let ((narrow (get-text-property 0 'consult--minor-mode-narrow cand))) - (or (= (logand narrow 255) consult--narrow) - (= (ash narrow -8) consult--narrow)))) - :keys - consult--minor-mode-menu-narrow) - :lookup #'consult--lookup-candidate - :history 'consult--minor-mode-menu-history))) - -;;;;; Command: consult-theme - -;;;###autoload -(defun consult-theme (theme) - "Disable current themes and enable THEME from `consult-themes'. - -The command supports previewing the currently selected theme." - (interactive - (list - (let* ((regexp (consult--regexp-filter - (mapcar (lambda (x) (if (stringp x) x (format "\\`%s\\'" x))) - consult-themes))) - (avail-themes (seq-filter - (lambda (x) (string-match-p regexp (symbol-name x))) - (cons 'default (custom-available-themes)))) - (saved-theme (car custom-enabled-themes))) - (consult--read - (mapcar #'symbol-name avail-themes) - :prompt "Theme: " - :require-match t - :category 'theme - :history 'consult--theme-history - :lookup (lambda (selected &rest _) - (setq selected (and selected (intern-soft selected))) - (or (and selected (car (memq selected avail-themes))) - saved-theme)) - :state (lambda (action theme) - (pcase action - ('return (consult-theme (or theme saved-theme))) - ((and 'preview (guard theme)) (consult-theme theme)))) - :default (symbol-name (or saved-theme 'default)))))) - (when (eq theme 'default) (setq theme nil)) - (unless (eq theme (car custom-enabled-themes)) - (mapc #'disable-theme custom-enabled-themes) - (when theme - (if (custom-theme-p theme) - (enable-theme theme) - (load-theme theme :no-confirm))))) - -;;;;; Command: consult-buffer - -(defun consult--buffer-sort-alpha (buffers) - "Sort BUFFERS alphabetically, put starred buffers at the end." - (sort buffers - (lambda (x y) - (setq x (buffer-name x) y (buffer-name y)) - (let ((a (and (length> x 0) (eq (aref x 0) ?*))) - (b (and (length> y 0) (eq (aref y 0) ?*)))) - (if (eq a b) - (string< x y) - (not a)))))) - -(defun consult--buffer-sort-alpha-current (buffers) - "Sort BUFFERS alphabetically, put current at the beginning." - (let ((buffers (consult--buffer-sort-alpha buffers)) - (current (current-buffer))) - (if (memq current buffers) - (cons current (delq current buffers)) - buffers))) - -(defun consult--buffer-sort-visibility (buffers) - "Sort BUFFERS by visibility." - (let ((hidden) - (current (car (memq (current-buffer) buffers)))) - (consult--keep! buffers - (unless (eq it current) - (if (get-buffer-window it 'visible) - it - (push it hidden) - nil))) - (nconc (nreverse hidden) buffers (and current (list current))))) - -(defun consult--normalize-directory (dir) - "Normalize directory DIR. -DIR can be project, nil or a path." - (cond - ((eq dir 'project) (consult--project-root)) - (dir (expand-file-name dir)))) - -(defun consult--buffer-query-prompt (prompt query) - "Return a list of buffers and create an appropriate prompt string. -Return a pair of a prompt string and a list of buffers. PROMPT -is the prefix of the prompt string. QUERY specifies the buffers -to search and is passed to `consult--buffer-query'." - (let* ((dir (plist-get query :directory)) - (ndir (consult--normalize-directory dir)) - (buffers (apply #'consult--buffer-query :directory ndir query)) - (count (length buffers))) - (cons (format "%s (%d buffer%s%s): " prompt count - (if (= count 1) "" "s") - (cond - ((and ndir (eq dir 'project)) - (format ", Project %s" (consult--project-name ndir))) - (ndir (concat ", " (consult--left-truncate-file ndir))) - (t ""))) - buffers))) - -(cl-defun consult--buffer-query (&key sort directory mode as predicate (filter t) - include (exclude consult-buffer-filter) - (buffer-list t)) - "Query for a list of matching buffers. -The function supports filtering by various criteria which are -used throughout Consult. In particular it is the backbone of -most `consult-buffer-sources'. -DIRECTORY can either be the symbol project or a file name. -SORT can be visibility, alpha or nil. -FILTER can be either t, nil or invert. -EXCLUDE is a list of regexps. -INCLUDE is a list of regexps. -MODE can be a mode or a list of modes to restrict the returned buffers. -PREDICATE is a predicate function. -BUFFER-LIST is the unfiltered list of buffers. -AS is a conversion function." - (let ((root (consult--normalize-directory directory))) - (setq buffer-list (if (eq buffer-list t) (buffer-list) (copy-sequence buffer-list))) - (when sort - (setq buffer-list (funcall (intern (format "consult--buffer-sort-%s" sort)) buffer-list))) - (when (or filter mode as root) - (let ((exclude-re (consult--regexp-filter exclude)) - (include-re (consult--regexp-filter include)) - (case-fold-search)) - (consult--keep! buffer-list - (and - (or (not mode) - (let ((mm (buffer-local-value 'major-mode it))) - (if (consp mode) - (seq-some (lambda (m) (provided-mode-derived-p mm m)) mode) - (provided-mode-derived-p mm mode)))) - (pcase-exhaustive filter - ('nil t) - ((or 't 'invert) - (eq (eq filter t) - (and - (or (not exclude) - (not (string-match-p exclude-re (buffer-name it)))) - (or (not include) - (not (not (string-match-p include-re (buffer-name it))))))))) - (or (not root) - (when-let (dir (buffer-local-value 'default-directory it)) - (string-prefix-p root - (if (and (/= 0 (length dir)) (eq (aref dir 0) ?/)) - dir - (expand-file-name dir))))) - (or (not predicate) (funcall predicate it)) - (if as (funcall as it) it))))) - buffer-list)) - -(defun consult--buffer-file-hash () - "Return hash table of all buffer file names." - (consult--string-hash (consult--buffer-query :as #'buffer-file-name))) - -(defun consult--buffer-pair (buffer) - "Return a pair of name of BUFFER and BUFFER." - (cons (buffer-name buffer) buffer)) - -(defun consult--buffer-preview () - "Buffer preview function." - (let ((orig-buf (window-buffer (consult--original-window))) - (orig-prev (copy-sequence (window-prev-buffers))) - (orig-next (copy-sequence (window-next-buffers))) - other-win) - (lambda (action cand) - (pcase action - ('exit - (set-window-prev-buffers other-win orig-prev) - (set-window-next-buffers other-win orig-next)) - ('preview - (when (and (eq consult--buffer-display #'switch-to-buffer-other-window) - (not other-win)) - (switch-to-buffer-other-window orig-buf 'norecord) - (setq other-win (selected-window))) - (let ((win (or other-win (selected-window))) - (buf (or (and cand (get-buffer cand)) orig-buf))) - (when (and (window-live-p win) (buffer-live-p buf) - (not (buffer-match-p consult-preview-excluded-buffers buf))) - (with-selected-window win - (unless (or orig-prev orig-next) - (setq orig-prev (copy-sequence (window-prev-buffers)) - orig-next (copy-sequence (window-next-buffers)))) - (switch-to-buffer buf 'norecord))))))))) - -(defun consult--buffer-action (buffer &optional norecord) - "Switch to BUFFER via `consult--buffer-display' function. -If NORECORD is non-nil, do not record the buffer switch in the buffer list." - (funcall consult--buffer-display buffer norecord)) - -(consult--define-state buffer) - -(defvar consult--source-bookmark - `(:name "Bookmark" - :narrow ?m - :category bookmark - :face consult-bookmark - :history bookmark-history - :items ,#'bookmark-all-names - :state ,#'consult--bookmark-state) - "Bookmark candidate source for `consult-buffer'.") - -(defvar consult--source-project-buffer - `(:name "Project Buffer" - :narrow ?b - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :enabled ,(lambda () consult-project-function) - :items - ,(lambda () - (when-let (root (consult--project-root)) - (consult--buffer-query :sort 'visibility - :directory root - :as #'consult--buffer-pair)))) - "Project buffer candidate source for `consult-buffer'.") - -(defvar consult--source-project-recent-file - `(:name "Project File" - :narrow ?f - :category file - :face consult-file - :history file-name-history - :state ,#'consult--file-state - :new - ,(lambda (file) - (consult--file-action - (expand-file-name file (consult--project-root)))) - :enabled - ,(lambda () - (and consult-project-function - recentf-mode)) - :items - ,(lambda () - (when-let (root (consult--project-root)) - (let ((len (length root)) - (ht (consult--buffer-file-hash)) - items) - (dolist (file (bound-and-true-p recentf-list) (nreverse items)) - ;; Emacs 29 abbreviates file paths by default, see - ;; `recentf-filename-handlers'. I recommend to set - ;; `recentf-filename-handlers' to nil to avoid any slow down. - (unless (eq (aref file 0) ?/) - (let (file-name-handler-alist) ;; No Tramp slowdown please. - (setq file (expand-file-name file)))) - (when (and (not (gethash file ht)) (string-prefix-p root file)) - (let ((part (substring file len))) - (when (equal part "") (setq part "./")) - (put-text-property 0 1 'multi-category `(file . ,file) part) - (push part items)))))))) - "Project file candidate source for `consult-buffer'.") - -(defvar consult--source-project-buffer-hidden - `(:hidden t :narrow (?p . "Project") ,@consult--source-project-buffer) - "Like `consult--source-project-buffer' but hidden by default.") - -(defvar consult--source-project-recent-file-hidden - `(:hidden t :narrow (?p . "Project") ,@consult--source-project-recent-file) - "Like `consult--source-project-recent-file' but hidden by default.") - -(defvar consult--source-hidden-buffer - `(:name "Hidden Buffer" - :narrow ?\s - :hidden t - :category buffer - :face consult-buffer - :history buffer-name-history - :action ,#'consult--buffer-action - :items - ,(lambda () (consult--buffer-query :sort 'visibility - :filter 'invert - :as #'consult--buffer-pair))) - "Hidden buffer candidate source for `consult-buffer'.") - -(defvar consult--source-modified-buffer - `(:name "Modified Buffer" - :narrow ?* - :hidden t - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :items - ,(lambda () (consult--buffer-query :sort 'visibility - :as #'consult--buffer-pair - :predicate - (lambda (buf) - (and (buffer-modified-p buf) - (buffer-file-name buf)))))) - "Modified buffer candidate source for `consult-buffer'.") - -(defvar consult--source-buffer - `(:name "Buffer" - :narrow ?b - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :default t - :items - ,(lambda () (consult--buffer-query :sort 'visibility - :as #'consult--buffer-pair))) - "Buffer candidate source for `consult-buffer'.") - -(defun consult--file-register-p (reg) - "Return non-nil if REG is a file register." - (memq (car-safe (cdr reg)) '(file-query file))) - -(autoload 'consult-register--candidates "consult-register") -(defvar consult--source-file-register - `(:name "File Register" - :narrow (?r . "Register") - :category file - :state ,#'consult--file-state - :enabled ,(lambda () (seq-some #'consult--file-register-p register-alist)) - :items ,(lambda () (consult-register--candidates #'consult--file-register-p))) - "File register source.") - -(defvar consult--source-recent-file - `(:name "File" - :narrow ?f - :category file - :face consult-file - :history file-name-history - :state ,#'consult--file-state - :new ,#'consult--file-action - :enabled ,(lambda () recentf-mode) - :items - ,(lambda () - (let ((ht (consult--buffer-file-hash)) - items) - (dolist (file (bound-and-true-p recentf-list) (nreverse items)) - ;; Emacs 29 abbreviates file paths by default, see - ;; `recentf-filename-handlers'. I recommend to set - ;; `recentf-filename-handlers' to nil to avoid any slow down. - (unless (eq (aref file 0) ?/) - (let (file-name-handler-alist) ;; No Tramp slowdown please. - (setq file (expand-file-name file)))) - (unless (gethash file ht) - (push (consult--fast-abbreviate-file-name file) items)))))) - "Recent file candidate source for `consult-buffer'.") - -;;;###autoload -(defun consult-buffer (&optional sources) - "Enhanced `switch-to-buffer' command with support for virtual buffers. - -The command supports recent files, bookmarks, views and project files as -virtual buffers. Buffers are previewed. Narrowing to buffers (b), files (f), -bookmarks (m) and project files (p) is supported via the corresponding -keys. In order to determine the project-specific files and buffers, the -`consult-project-function' is used. The virtual buffer SOURCES -default to `consult-buffer-sources'. See `consult--multi' for the -configuration of the virtual buffer sources." - (interactive) - (let ((selected (consult--multi (or sources consult-buffer-sources) - :require-match - (confirm-nonexistent-file-or-buffer) - :prompt "Switch to: " - :history 'consult--buffer-history - :sort nil))) - ;; For non-matching candidates, fall back to buffer creation. - (unless (plist-get (cdr selected) :match) - (consult--buffer-action (car selected))))) - -(defmacro consult--with-project (&rest body) - "Ensure that BODY is executed with a project root." - ;; We have to work quite hard here to ensure that the project root is - ;; only overridden at the current recursion level. When entering a - ;; recursive minibuffer session, we should be able to still switch the - ;; project. But who does that? Working on the first level on project A - ;; and on the second level on project B and on the third level on project C? - ;; You mustn't be afraid to dream a little bigger, darling. - `(let ((consult-project-function - (let ((root (or (consult--project-root t) (user-error "No project found"))) - (depth (recursion-depth)) - (orig consult-project-function)) - (lambda (may-prompt) - (if (= depth (recursion-depth)) - root - (funcall orig may-prompt)))))) - ,@body)) - -;;;###autoload -(defun consult-project-buffer () - "Enhanced `project-switch-to-buffer' command with support for virtual buffers. -The command may prompt you for a project directory if it is invoked from -outside a project. See `consult-buffer' for more details." - (interactive) - (consult--with-project - (consult-buffer consult-project-buffer-sources))) - -;;;###autoload -(defun consult-buffer-other-window () - "Variant of `consult-buffer', switching to a buffer in another window." - (interactive) - (let ((consult--buffer-display #'switch-to-buffer-other-window)) - (consult-buffer))) - -;;;###autoload -(defun consult-buffer-other-frame () - "Variant of `consult-buffer', switching to a buffer in another frame." - (interactive) - (let ((consult--buffer-display #'switch-to-buffer-other-frame)) - (consult-buffer))) - -;;;###autoload -(defun consult-buffer-other-tab () - "Variant of `consult-buffer', switching to a buffer in another tab." - (interactive) - (let ((consult--buffer-display #'switch-to-buffer-other-tab)) - (consult-buffer))) - -;;;;; Command: consult-grep - -(defun consult--grep-format (async builder) - "Return ASYNC function highlighting grep match results. -BUILDER is the command line builder function." - (let (highlight) - (lambda (action) - (cond - ((stringp action) - (setq highlight (cdr (funcall builder action))) - (funcall async action)) - ((consp action) - (let ((file "") (file-len 0) result) - (save-match-data - (dolist (str action) - (when (and (string-match consult--grep-match-regexp str) - ;; Filter out empty context lines - (or (/= (aref str (match-beginning 3)) ?-) - (/= (match-end 0) (length str)))) - ;; We share the file name across candidates to reduce - ;; the amount of allocated memory. - (unless (and (= file-len (- (match-end 1) (match-beginning 1))) - (eq t (compare-strings - file 0 file-len - str (match-beginning 1) (match-end 1) nil))) - (setq file (match-string 1 str) - file-len (length file))) - (let* ((line (match-string 2 str)) - (ctx (= (aref str (match-beginning 3)) ?-)) - (sep (if ctx "-" ":")) - (content (substring str (match-end 0))) - (line-len (length line))) - (when (and consult-grep-max-columns - (length> content consult-grep-max-columns)) - (setq content (substring content 0 consult-grep-max-columns))) - (when highlight - (funcall highlight content)) - (setq str (concat file sep line sep content)) - ;; Store file name in order to avoid allocations in `consult--prefix-group' - (add-text-properties 0 file-len `(face consult-file consult--prefix-group ,file) str) - (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str) - (when ctx - (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str)) - (push str result))))) - (funcall async (nreverse result)))) - (t (funcall async action)))))) - -(defun consult--grep-position (cand &optional find-file) - "Return the grep position marker for CAND. -FIND-FILE is the file open function, defaulting to `find-file-noselect'." - (when cand - (let* ((file-end (next-single-property-change 0 'face cand)) - (line-end (next-single-property-change (1+ file-end) 'face cand)) - (matches (consult--point-placement cand (1+ line-end) 'consult-grep-context)) - (file (substring-no-properties cand 0 file-end)) - (line (string-to-number (substring-no-properties cand (+ 1 file-end) line-end)))) - (when-let (pos (consult--marker-from-line-column - (funcall (or find-file #'consult--file-action) file) - line (or (car matches) 0))) - (cons pos (cdr matches)))))) - -(defun consult--grep-state () - "Grep state function." - (let ((open (consult--temporary-files)) - (jump (consult--jump-state))) - (lambda (action cand) - (unless cand - (funcall open)) - (funcall jump action (consult--grep-position - cand - (and (not (eq action 'return)) open)))))) - -(defun consult--grep-exclude-args () - "Produce grep exclude arguments. -Take the variables `grep-find-ignored-directories' and -`grep-find-ignored-files' into account." - (unless (boundp 'grep-find-ignored-files) (require 'grep)) - (nconc (mapcar (lambda (s) (concat "--exclude=" s)) - (bound-and-true-p grep-find-ignored-files)) - (mapcar (lambda (s) (concat "--exclude-dir=" s)) - (bound-and-true-p grep-find-ignored-directories)))) - -(defun consult--grep (prompt make-builder dir initial) - "Run asynchronous grep. - -MAKE-BUILDER is the function that returns the command line -builder function. DIR is a directory or a list of file or -directories. PROMPT is the prompt string. INITIAL is initial -input." - (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt prompt dir)) - (default-directory dir) - (builder (funcall make-builder paths))) - (consult--read - (consult--async-command builder - (consult--grep-format builder) - :file-handler t) ;; allow tramp - :prompt prompt - :lookup #'consult--lookup-member - :state (consult--grep-state) - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'symbol) - :require-match t - :category 'consult-grep - :group #'consult--prefix-group - :history '(:input consult--grep-history) - :sort nil))) - -(defun consult--grep-lookahead-p (&rest cmd) - "Return t if grep CMD supports look-ahead." - (eq 0 (process-file-shell-command - (concat "echo xaxbx | " - (mapconcat #'shell-quote-argument `(,@cmd "^(?=.*b)(?=.*a)") " "))))) - -(defun consult--grep-make-builder (paths) - "Build grep command line and grep across PATHS." - (let* ((cmd (consult--build-args consult-grep-args)) - (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) - (lambda (input) - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (flags (append cmd opts)) - (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) - (if (or (member "-F" flags) (member "--fixed-strings" flags)) - (cons (append cmd (list "-e" arg) opts paths) - (apply-partially #'consult--highlight-regexps - (list (regexp-quote arg)) ignore-case)) - (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) - (when re - (cons (append cmd - (list (if (eq type 'pcre) "-P" "-E") ;; perl or extended - "-e" (consult--join-regexps re type)) - opts paths) - hl)))))))) - -;;;###autoload -(defun consult-grep (&optional dir initial) - "Search with `grep' for files in DIR where the content matches a regexp. - -The initial input is given by the INITIAL argument. DIR can be nil, a -directory string or a list of file/directory paths. If `consult-grep' -is called interactively with a prefix argument, the user can specify the -directories or files to search in. Multiple directories or files must -be separated by comma in the minibuffer, since they are read via -`completing-read-multiple'. By default the project directory is used if -`consult-project-function' is defined and returns non-nil. Otherwise -the `default-directory' is searched. If the command is invoked with a -double prefix argument (twice `C-u') the user is asked for a project, if -not yet inside a project, or the current project is searched. - -The input string is split, the first part of the string (grep input) is -passed to the asynchronous grep process and the second part of the -string is passed to the completion-style filtering. - -The input string is split at a punctuation character, which is given as -the first character of the input string. The format is similar to -Perl-style regular expressions, e.g., /regexp/. Furthermore command -line options can be passed to grep, specified behind --. The overall -prompt input has the form `#async-input -- grep-opts#filter-string'. - -Note that the grep input string is transformed from Emacs regular -expressions to Posix regular expressions. Always enter Emacs regular -expressions at the prompt. `consult-grep' behaves like builtin Emacs -search commands, e.g., Isearch, which take Emacs regular expressions. -Furthermore the asynchronous input split into words, each word must -match separately and in any order. See `consult--regexp-compiler' for -the inner workings. In order to disable transformations of the grep -input, adjust `consult--regexp-compiler' accordingly. - -Here we give a few example inputs: - -#alpha beta : Search for alpha and beta in any order. -#alpha.*beta : Search for alpha before beta. -#\\(alpha\\|beta\\) : Search for alpha or beta (Note Emacs syntax!) -#word -- -C3 : Search for word, include 3 lines as context -#first#second : Search for first, quick filter for second. - -The symbol at point is added to the future history." - (interactive "P") - (consult--grep "Grep" #'consult--grep-make-builder dir initial)) - -;;;;; Command: consult-git-grep - -(defun consult--git-grep-make-builder (paths) - "Create grep command line builder given PATHS." - (let ((cmd (consult--build-args consult-git-grep-args))) - (lambda (input) - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (flags (append cmd opts)) - (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) - (if (or (member "-F" flags) (member "--fixed-strings" flags)) - (cons (append cmd (list "-e" arg) opts paths) - (apply-partially #'consult--highlight-regexps - (list (regexp-quote arg)) ignore-case)) - (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended ignore-case))) - (when re - (cons (append cmd - (cdr (mapcan (lambda (x) (list "--and" "-e" x)) re)) - opts paths) - hl)))))))) - -;;;###autoload -(defun consult-git-grep (&optional dir initial) - "Search with `git grep' for files in DIR with INITIAL input. -See `consult-grep' for details." - (interactive "P") - (consult--grep "Git-grep" #'consult--git-grep-make-builder dir initial)) - -;;;;; Command: consult-ripgrep - -(defun consult--ripgrep-make-builder (paths) - "Create ripgrep command line builder given PATHS." - (let* ((cmd (consult--build-args consult-ripgrep-args)) - (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) - (lambda (input) - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (flags (append cmd opts)) - (ignore-case - (and (not (or (member "-s" flags) (member "--case-sensitive" flags))) - (or (member "-i" flags) (member "--ignore-case" flags) - (and (or (member "-S" flags) (member "--smart-case" flags)) - (let (case-fold-search) - ;; Case insensitive if there are no uppercase letters - (not (string-match-p "[[:upper:]]" arg)))))))) - (if (or (member "-F" flags) (member "--fixed-strings" flags)) - (cons (append cmd (list "-e" arg) opts paths) - (apply-partially #'consult--highlight-regexps - (list (regexp-quote arg)) ignore-case)) - (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) - (when re - (cons (append cmd (and (eq type 'pcre) '("-P")) - (list "-e" (consult--join-regexps re type)) - opts paths) - hl)))))))) - -;;;###autoload -(defun consult-ripgrep (&optional dir initial) - "Search with `rg' for files in DIR with INITIAL input. -See `consult-grep' for details." - (interactive "P") - (consult--grep "Ripgrep" #'consult--ripgrep-make-builder dir initial)) - -;;;;; Command: consult-find - -(defun consult--find (prompt builder initial) - "Run find command in current directory. - -The function returns the selected file. -The filename at point is added to the future history. - -BUILDER is the command line builder function. -PROMPT is the prompt. -INITIAL is initial input." - (consult--read - (consult--async-command builder - (consult--async-map (lambda (x) (string-remove-prefix "./" x))) - (consult--async-highlight builder) - :file-handler t) ;; allow tramp - :prompt prompt - :sort nil - :require-match t - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'filename) - :category 'file - :history '(:input consult--find-history))) - -(defun consult--find-make-builder (paths) - "Build find command line, finding across PATHS." - (let* ((cmd (seq-mapcat (lambda (x) - (if (equal x ".") paths (list x))) - (consult--build-args consult-find-args))) - (type (if (eq 0 (process-file-shell-command - (concat (car cmd) " -regextype emacs -version"))) - 'emacs 'basic))) - (lambda (input) - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - ;; ignore-case=t since -iregex is used below - (`(,re . ,hl) (funcall consult--regexp-compiler arg type t))) - (when re - (cons (append cmd - (cdr (mapcan - (lambda (x) - `("-and" "-iregex" - ,(format ".*%s.*" - ;; Replace non-capturing groups with capturing groups. - ;; GNU find does not support non-capturing groups. - (replace-regexp-in-string - "\\\\(\\?:" "\\(" x 'fixedcase 'literal)))) - re)) - opts) - hl)))))) - -;;;###autoload -(defun consult-find (&optional dir initial) - "Search for files with `find' in DIR. -The file names must match the input regexp. INITIAL is the -initial minibuffer input. See `consult-grep' for details -regarding the asynchronous search and the arguments." - (interactive "P") - (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Find" dir)) - (default-directory dir) - (builder (consult--find-make-builder paths))) - (find-file (consult--find prompt builder initial)))) - -;;;;; Command: consult-fd - -(defun consult--fd-make-builder (paths) - "Build find command line, finding across PATHS." - (let ((cmd (consult--build-args consult-fd-args))) - (lambda (input) - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (flags (append cmd opts)) - (ignore-case - (and (not (or (member "-s" flags) (member "--case-sensitive" flags))) - (or (member "-i" flags) (member "--ignore-case" flags) - (let (case-fold-search) - ;; Case insensitive if there are no uppercase letters - (not (string-match-p "[[:upper:]]" arg))))))) - (if (or (member "-F" flags) (member "--fixed-strings" flags)) - (cons (append cmd (list arg) opts paths) - (apply-partially #'consult--highlight-regexps - (list (regexp-quote arg)) ignore-case)) - (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg 'pcre ignore-case))) - (when re - (cons (append cmd - (mapcan (lambda (x) `("--and" ,x)) re) - opts - (mapcan (lambda (x) `("--search-path" ,x)) paths)) - hl)))))))) - -;;;###autoload -(defun consult-fd (&optional dir initial) - "Search for files with `fd' in DIR. -The file names must match the input regexp. INITIAL is the -initial minibuffer input. See `consult-grep' for details -regarding the asynchronous search and the arguments." - (interactive "P") - (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Fd" dir)) - (default-directory dir) - (builder (consult--fd-make-builder paths))) - (find-file (consult--find prompt builder initial)))) - -;;;;; Command: consult-locate - -(defun consult--locate-builder (input) - "Build command line from INPUT." - (pcase-let ((`(,arg . ,opts) (consult--command-split input))) - (unless (string-blank-p arg) - (cons (append (consult--build-args consult-locate-args) - (consult--split-escaped arg) opts) - (cdr (consult--default-regexp-compiler input 'basic t)))))) - -;;;###autoload -(defun consult-locate (&optional initial) - "Search with `locate' for files which match input given INITIAL input. - -The input is treated literally such that locate can take advantage of -the locate database index. Regular expressions would often force a slow -linear search through the entire database. The locate process is started -asynchronously, similar to `consult-grep'. See `consult-grep' for more -details regarding the asynchronous search." - (interactive) - (find-file (consult--find "Locate: " #'consult--locate-builder initial))) - -;;;;; Command: consult-man - -(defun consult--man-builder (input) - "Build command line from INPUT." - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended t))) - (when re - (cons (append (consult--build-args consult-man-args) - (list (consult--join-regexps re 'extended)) - opts) - hl)))) - -(defun consult--man-format (lines) - "Format man candidates from LINES." - (let ((candidates)) - (save-match-data - (dolist (str lines) - (when (string-match "\\`\\(.*?\\([^ ]+\\) *(\\([^,)]+\\)[^)]*).*?\\) +- +\\(.*\\)\\'" str) - (let* ((names (match-string 1 str)) - (name (match-string 2 str)) - (section (match-string 3 str)) - (desc (match-string 4 str)) - (cand (format "%s - %s" names desc))) - (add-text-properties 0 (length names) - (list 'face 'consult-file - 'consult-man (concat section " " name)) - cand) - (push cand candidates))))) - (nreverse candidates))) - -;;;###autoload -(defun consult-man (&optional initial) - "Search for man page given INITIAL input. - -The input string is not preprocessed and passed literally to the -underlying man commands. The man process is started asynchronously, -similar to `consult-grep'. See `consult-grep' for more details regarding -the asynchronous search." - (interactive) - (man (consult--read - (consult--async-command #'consult--man-builder - (consult--async-transform consult--man-format) - (consult--async-highlight #'consult--man-builder)) - :prompt "Manual entry: " - :require-match t - :category 'consult-man - :lookup (apply-partially #'consult--lookup-prop 'consult-man) - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'symbol) - :history '(:input consult--man-history)))) - -;;;; Preview at point in completions buffers - -(define-minor-mode consult-preview-at-point-mode - "Preview minor mode for *Completions* buffers. -When moving around in the *Completions* buffer, the candidate at point is -automatically previewed." - :group 'consult - (if consult-preview-at-point-mode - (add-hook 'post-command-hook #'consult-preview-at-point nil 'local) - (remove-hook 'post-command-hook #'consult-preview-at-point 'local))) - -(defun consult-preview-at-point () - "Preview candidate at point in *Completions* buffer." - (interactive) - (when-let ((win (active-minibuffer-window)) - (buf (window-buffer win)) - (fun (buffer-local-value 'consult--preview-function buf))) - (funcall fun))) - -;;;; Integration with completion systems - -;;;;; Integration: Default *Completions* - -(defun consult--default-completion-minibuffer-candidate () - "Return current minibuffer candidate from default completion system or Icomplete." - (when (and (minibufferp) - (eq completing-read-function #'completing-read-default)) - (let ((content (minibuffer-contents-no-properties))) - ;; When the current minibuffer content matches a candidate, return it! - (if (test-completion content - minibuffer-completion-table - minibuffer-completion-predicate) - content - ;; Return the full first candidate of the sorted completion list. - (when-let ((completions (completion-all-sorted-completions))) - (concat - (substring content 0 (or (cdr (last completions)) 0)) - (car completions))))))) - -(defun consult--default-completion-list-candidate () - "Return current candidate at point from completions buffer." - (let (beg end) - (when (and - (derived-mode-p 'completion-list-mode) - ;; Logic taken from `choose-completion'. - ;; TODO Upstream a `completion-list-get-candidate' function. - (cond - ((and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) - ((and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) - (setq end (1- (point)) beg (point))))) - (setq beg (previous-single-property-change beg 'mouse-face) - end (or (next-single-property-change end 'mouse-face) (point-max))) - (or (get-text-property beg 'completion--string) - (buffer-substring-no-properties beg end))))) - -;;;;; Integration: Vertico - -(defvar vertico--input) -(declare-function vertico--exhibit "ext:vertico") -(declare-function vertico--candidate "ext:vertico") -(declare-function vertico--filter-completions "ext:vertico") - -(defun consult--vertico-candidate () - "Return current candidate for Consult preview." - (and vertico--input (vertico--candidate 'highlight))) - -(defun consult--vertico-refresh () - "Refresh completion UI." - (when vertico--input - (setq vertico--input t) - (vertico--exhibit))) - -(defun consult--vertico-filter-adv (orig pattern cands category highlight) - "Advice for ORIG `consult--completion-filter' function. -See `consult--completion-filter' for arguments PATTERN, CANDS, CATEGORY -and HIGHLIGHT." - (if (and (not highlight) (bound-and-true-p vertico-mode)) - ;; Optimize `consult--completion-filter' using the deferred highlighting - ;; from Vertico. The advice is not necessary - it is a pure optimization. - (nconc (car (vertico--filter-completions pattern cands nil (length pattern) - `(metadata (category . ,category)))) - nil) - (funcall orig pattern cands category highlight))) - -(with-eval-after-load 'vertico - (advice-add #'consult--completion-filter :around #'consult--vertico-filter-adv) - (add-hook 'consult--completion-candidate-hook #'consult--vertico-candidate) - (add-hook 'consult--completion-refresh-hook #'consult--vertico-refresh) - (define-key consult-async-map [remap vertico-insert] 'vertico-next-group)) - -;;;;; Integration: Mct - -(with-eval-after-load 'mct (add-hook 'consult--completion-refresh-hook - 'mct--live-completions-refresh)) - -;;;;; Integration: Icomplete - -(defvar icomplete-mode) -(declare-function icomplete-exhibit "icomplete") - -(defun consult--icomplete-refresh () - "Refresh icomplete view." - (when icomplete-mode - (let ((top (car completion-all-sorted-completions))) - (completion--flush-all-sorted-completions) - ;; force flushing, otherwise narrowing is broken! - (setq completion-all-sorted-completions nil) - (when top - (let* ((completions (completion-all-sorted-completions)) - (last (last completions)) - (before)) ;; completions before top - ;; warning: completions is an improper list - (while (consp completions) - (if (equal (car completions) top) - (progn - (setcdr last (append (nreverse before) (cdr last))) - (setq completion-all-sorted-completions completions - completions nil)) - (push (car completions) before) - (setq completions (cdr completions))))))) - (icomplete-exhibit))) - -(with-eval-after-load 'icomplete - (add-hook 'consult--completion-refresh-hook #'consult--icomplete-refresh)) - -(provide 'consult) -;;; consult.el ends here diff --git a/emacs/elpa/consult-20241105.2133/consult.elc b/emacs/elpa/consult-20241105.2133/consult.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-autoloads.el b/emacs/elpa/consult-20241115.517/consult-autoloads.el diff --git a/emacs/elpa/consult-20241105.2133/consult-compile.el b/emacs/elpa/consult-20241115.517/consult-compile.el diff --git a/emacs/elpa/consult-20241105.2133/consult-compile.elc b/emacs/elpa/consult-20241115.517/consult-compile.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-flymake.el b/emacs/elpa/consult-20241115.517/consult-flymake.el diff --git a/emacs/elpa/consult-20241105.2133/consult-flymake.elc b/emacs/elpa/consult-20241115.517/consult-flymake.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-imenu.el b/emacs/elpa/consult-20241115.517/consult-imenu.el diff --git a/emacs/elpa/consult-20241105.2133/consult-imenu.elc b/emacs/elpa/consult-20241115.517/consult-imenu.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-info.el b/emacs/elpa/consult-20241115.517/consult-info.el diff --git a/emacs/elpa/consult-20241105.2133/consult-info.elc b/emacs/elpa/consult-20241115.517/consult-info.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-kmacro.el b/emacs/elpa/consult-20241115.517/consult-kmacro.el diff --git a/emacs/elpa/consult-20241105.2133/consult-kmacro.elc b/emacs/elpa/consult-20241115.517/consult-kmacro.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-org.el b/emacs/elpa/consult-20241115.517/consult-org.el diff --git a/emacs/elpa/consult-20241115.517/consult-org.elc b/emacs/elpa/consult-20241115.517/consult-org.elc Binary files differ. diff --git a/emacs/elpa/consult-20241115.517/consult-pkg.el b/emacs/elpa/consult-20241115.517/consult-pkg.el @@ -0,0 +1,10 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "consult" "20241115.517" + "Consulting completing-read." + '((emacs "28.1") + (compat "30")) + :url "https://github.com/minad/consult" + :commit "554c21567a05e367a0daf60a199ba1db6ba09eca" + :revdesc "554c21567a05" + :keywords '("matching" "files" "completion") + :maintainers '(("Daniel Mendler" . "mail@daniel-mendler.de"))) diff --git a/emacs/elpa/consult-20241105.2133/consult-register.el b/emacs/elpa/consult-20241115.517/consult-register.el diff --git a/emacs/elpa/consult-20241105.2133/consult-register.elc b/emacs/elpa/consult-20241115.517/consult-register.elc Binary files differ. diff --git a/emacs/elpa/consult-20241105.2133/consult-xref.el b/emacs/elpa/consult-20241115.517/consult-xref.el diff --git a/emacs/elpa/consult-20241105.2133/consult-xref.elc b/emacs/elpa/consult-20241115.517/consult-xref.elc Binary files differ. diff --git a/emacs/elpa/consult-20241115.517/consult.el b/emacs/elpa/consult-20241115.517/consult.el @@ -0,0 +1,5254 @@ +;;; consult.el --- Consulting completing-read -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2024 Free Software Foundation, Inc. + +;; Author: Daniel Mendler and Consult contributors +;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> +;; Created: 2020 +;; Package-Version: 20241115.517 +;; Package-Revision: 554c21567a05 +;; Package-Requires: ((emacs "28.1") (compat "30")) +;; URL: https://github.com/minad/consult +;; Keywords: matching, files, completion + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Consult implements a set of `consult-<thing>' commands, which aim to +;; improve the way you use Emacs. The commands are founded on +;; `completing-read', which selects from a list of candidate strings. +;; Consult provides an enhanced buffer switcher `consult-buffer' and +;; search and navigation commands like `consult-imenu' and +;; `consult-line'. Searching through multiple files is supported by the +;; asynchronous `consult-grep' command. Many Consult commands support +;; previewing candidates. If a candidate is selected in the completion +;; view, the buffer shows the candidate immediately. + +;; The Consult commands are compatible with multiple completion systems +;; based on the Emacs `completing-read' API, including the default +;; completion system, Vertico, Mct and Icomplete. + +;; See the README for an overview of the available Consult commands and +;; the documentation of the configuration and installation of the +;; package. + +;; The full list of contributors can be found in the acknowledgments +;; section of the README. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) +(require 'compat) +(require 'bookmark) + +(defgroup consult nil + "Consulting `completing-read'." + :link '(info-link :tag "Info Manual" "(consult)") + :link '(url-link :tag "Website" "https://github.com/minad/consult") + :link '(url-link :tag "Wiki" "https://github.com/minad/consult/wiki") + :link '(emacs-library-link :tag "Library Source" "consult.el") + :group 'files + :group 'outlines + :group 'minibuffer + :prefix "consult-") + +;;;; Customization + +(defcustom consult-narrow-key nil + "Prefix key for narrowing during completion. + +Good choices for this key are \"<\" and \"C-+\" for example. The +key must be a string accepted by `key-valid-p'." + :type '(choice key (const :tag "None" nil))) + +(defcustom consult-widen-key nil + "Key used for widening during completion. + +If this key is unset, defaults to twice the `consult-narrow-key'. +The key must be a string accepted by `key-valid-p'." + :type '(choice key (const :tag "None" nil))) + +(defcustom consult-project-function + #'consult--default-project-function + "Function which returns project root directory. +The function takes one boolean argument MAY-PROMPT. If +MAY-PROMPT is non-nil, the function may ask the prompt the user +for a project directory. The root directory is used by +`consult-buffer' and `consult-grep'." + :type `(choice + (const :tag "Default project function" ,#'consult--default-project-function) + (function :tag "Custom function") + (const :tag "No project integration" nil))) + +(defcustom consult-async-refresh-delay 0.2 + "Refreshing delay of the completion UI for asynchronous commands. + +The completion UI is only updated every +`consult-async-refresh-delay' seconds. This applies to +asynchronous commands like for example `consult-grep'." + :type '(float :tag "Delay in seconds")) + +(defcustom consult-async-input-throttle 0.5 + "Input throttle for asynchronous commands. + +The asynchronous process is started only every +`consult-async-input-throttle' seconds. This applies to asynchronous +commands, e.g., `consult-grep'." + :type '(float :tag "Delay in seconds")) + +(defcustom consult-async-input-debounce 0.2 + "Input debounce for asynchronous commands. + +The asynchronous process is started only when there has not been new +input for `consult-async-input-debounce' seconds. This applies to +asynchronous commands, e.g., `consult-grep'." + :type '(float :tag "Delay in seconds")) + +(defcustom consult-async-min-input 3 + "Minimum number of characters needed, before asynchronous process is called. + +This applies to asynchronous commands, e.g., `consult-grep'." + :type '(natnum :tag "Number of characters")) + +(defcustom consult-async-split-style 'perl + "Async splitting style, see `consult-async-split-styles-alist'." + :type '(choice (const :tag "No splitting" nil) + (const :tag "Comma" comma) + (const :tag "Semicolon" semicolon) + (const :tag "Perl" perl))) + +(defcustom consult-async-split-styles-alist + `((nil :function ,#'consult--split-nil) + (comma :separator ?, :function ,#'consult--split-separator) + (semicolon :separator ?\; :function ,#'consult--split-separator) + (perl :initial "#" :function ,#'consult--split-perl)) + "Async splitting styles." + :type '(alist :key-type symbol :value-type plist)) + +(defcustom consult-mode-histories + '((eshell-mode eshell-history-ring eshell-history-index eshell-bol) + (comint-mode comint-input-ring comint-input-ring-index comint-bol) + (term-mode term-input-ring term-input-ring-index term-bol)) + "Alist of mode histories (mode history index bol). +The histories can be rings or lists. Index, if provided, is a +variable to set to the index of the selection within the ring or +list. Bol, if provided is a function which jumps to the beginning +of the line after the prompt." + :type '(alist :key-type symbol + :value-type (group :tag "Include Index" + (symbol :tag "List/Ring") + (symbol :tag "Index Variable") + (symbol :tag "Bol Function")))) + +(defcustom consult-themes nil + "List of themes (symbols or regexps) to be presented for selection. +nil shows all `custom-available-themes'." + :type '(repeat (choice symbol regexp))) + +(defcustom consult-after-jump-hook (list #'recenter) + "Function called after jumping to a location. + +Commonly used functions for this hook are `recenter' and +`reposition-window'. You may want to add a function which pulses the +current line, e.g., `pulse-momentary-highlight-one-line'. The hook +called during preview and for the jump after selection." + :type 'hook) + +(defcustom consult-line-start-from-top nil + "Start search from the top if non-nil. +Otherwise start the search at the current line and wrap around." + :type 'boolean) + +(defcustom consult-point-placement 'match-beginning + "Where to leave point when jumping to a match. +This setting affects the command `consult-line' and the `consult-grep' variants." + :type '(choice (const :tag "Beginning of the line" line-beginning) + (const :tag "Beginning of the match" match-beginning) + (const :tag "End of the match" match-end))) + +(defcustom consult-line-numbers-widen t + "Show absolute line numbers when narrowing is active. + +See also `display-line-numbers-widen'." + :type 'boolean) + +(defcustom consult-goto-line-numbers t + "Show line numbers for `consult-goto-line'." + :type 'boolean) + +(defcustom consult-fontify-preserve t + "Preserve fontification for line-based commands." + :type 'boolean) + +(defcustom consult-fontify-max-size 1048576 + "Buffers larger than this byte limit are not fontified. + +This is necessary in order to prevent a large startup time +for navigation commands like `consult-line'." + :type '(natnum :tag "Buffer size in bytes")) + +(defcustom consult-buffer-filter + '("\\` " + "\\`\\*Completions\\*\\'" + "\\`\\*Flymake log\\*\\'" + "\\`\\*Semantic SymRef\\*\\'" + "\\`\\*vc\\*\\'" + "\\`newsrc-dribble\\'" ;; Gnus + "\\`\\*tramp/.*\\*\\'") + "Filter regexps for `consult-buffer'. + +The default setting is to filter ephemeral buffer names beginning +with a space character, the *Completions* buffer and a few log +buffers. The regular expressions are matched case sensitively." + :type '(repeat regexp)) + +(defcustom consult-buffer-sources + '(consult--source-hidden-buffer + consult--source-modified-buffer + consult--source-buffer + consult--source-recent-file + consult--source-file-register + consult--source-bookmark + consult--source-project-buffer-hidden + consult--source-project-recent-file-hidden) + "Sources used by `consult-buffer'. +See also `consult-project-buffer-sources'. +See `consult--multi' for a description of the source data structure." + :type '(repeat symbol)) + +(defcustom consult-project-buffer-sources + '(consult--source-project-buffer + consult--source-project-recent-file) + "Sources used by `consult-project-buffer'. +See also `consult-buffer-sources'. +See `consult--multi' for a description of the source data structure." + :type '(repeat symbol)) + +(defcustom consult-mode-command-filter + '(;; Filter commands + "-mode\\'" "--" + ;; Filter whole features + simple mwheel time so-long recentf tab-bar tab-line) + "Filter commands for `consult-mode-command'." + :type '(repeat (choice symbol regexp))) + +(defcustom consult-grep-max-columns 300 + "Maximal number of columns of grep output. +If set to nil, do not truncate candidates. This can have negative +performance implications but helps if you want to export long lines via +`embark-export'." + :type '(choice natnum (const nil))) + +(defconst consult--grep-match-regexp + "\\`\\(?:\\./\\)?\\([^\n\0]+\\)\0\\([0-9]+\\)\\([-:\0]\\)" + "Regexp used to match file and line of grep output.") + +(defcustom consult-grep-args + '("grep" (consult--grep-exclude-args) + "--null --line-buffered --color=never --ignore-case\ + --with-filename --line-number -I -r") + "Command line arguments for grep, see `consult-grep'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-git-grep-args + "git --no-pager grep --null --color=never --ignore-case\ + --extended-regexp --line-number -I" + "Command line arguments for git-grep, see `consult-git-grep'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-ripgrep-args + "rg --null --line-buffered --color=never --max-columns=1000 --path-separator /\ + --smart-case --no-heading --with-filename --line-number --search-zip" + "Command line arguments for ripgrep, see `consult-ripgrep'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-find-args + "find . -not ( -path */.[A-Za-z]* -prune )" + "Command line arguments for find, see `consult-find'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-fd-args + '((if (executable-find "fdfind" 'remote) "fdfind" "fd") + "--full-path --color=never") + "Command line arguments for fd, see `consult-fd'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-locate-args + "locate --ignore-case" ;; --existing not supported by Debian plocate + "Command line arguments for locate, see `consult-locate'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-man-args + "man -k" + "Command line arguments for man, see `consult-man'. +The dynamically computed arguments are appended. +Can be either a string, or a list of strings or expressions." + :type '(choice string (repeat (choice string sexp)))) + +(defcustom consult-preview-key 'any + "Preview trigger keys, can be nil, `any', a single key or a list of keys. +Debouncing can be specified via the `:debounce' attribute. The +individual keys must be strings accepted by `key-valid-p'." + :type '(choice (const :tag "Any key" any) + (list :tag "Debounced" + (const :debounce) + (float :tag "Seconds" 0.1) + (const any)) + (const :tag "No preview" nil) + (key :tag "Key") + (repeat :tag "List of keys" key))) + +(defcustom consult-preview-partial-size 1048576 + "Files larger than this byte limit are previewed partially." + :type '(natnum :tag "File size in bytes")) + +(defcustom consult-preview-partial-chunk 102400 + "Partial preview chunk size in bytes. +If a file is larger than `consult-preview-partial-size' only the +chunk from the beginning of the file is previewed." + :type '(natnum :tag "Chunk size in bytes")) + +(defcustom consult-preview-max-count 10 + "Number of file buffers to keep open temporarily during preview." + :type '(natnum :tag "Number of buffers")) + +(defcustom consult-preview-excluded-buffers nil + "Buffers excluded from preview. +The value should conform to the predicate format demanded by the +function `buffer-match-p'." + :type 'sexp) + +(defcustom consult-preview-excluded-files + '("\\`/[^/|:]+:") ;; Do not preview remote files + "List of regexps matched against names of files, which are not previewed." + :type '(repeat regexp)) + +(defcustom consult-preview-allowed-hooks + '(global-font-lock-mode + save-place-find-file-hook) + "List of hooks, which should be executed during file preview. +This variable applies to `find-file-hook', `change-major-mode-hook' and +mode hooks, e.g., `prog-mode-hook'." + :type '(repeat symbol)) + +(defcustom consult-preview-variables + '((inhibit-message . t) + (enable-dir-local-variables . nil) + (enable-local-variables . :safe) + (non-essential . t) + (delay-mode-hooks . t)) + "Variables which are bound for file preview." + :type '(alist :key-type symbol)) + +(defcustom consult-bookmark-narrow + `((?f "File" bookmark-default-handler) + (?h "Help" help-bookmark-jump Info-bookmark-jump + Man-bookmark-jump woman-bookmark-jump) + (?p "Picture" image-bookmark-jump) + (?d "Docview" doc-view-bookmark-jump) + (?m "Mail" gnus-summary-bookmark-jump) + (?s "Eshell" eshell-bookmark-jump) + (?w "Web" eww-bookmark-jump xwidget-webkit-bookmark-jump-handler) + (?v "VC Directory" vc-dir-bookmark-jump) + (nil "Other")) + "Bookmark narrowing configuration. + +Each element of the list must have the form (char name handlers...)." + :type '(alist :key-type character :value-type (cons string (repeat function)))) + +(define-obsolete-variable-alias + 'consult-yank-rotate 'yank-from-kill-ring-rotate "1.8") + +;;;; Faces + +(defgroup consult-faces nil + "Faces used by Consult." + :group 'consult + :group 'faces) + +(defface consult-preview-line + '((t :inherit consult-preview-insertion :extend t)) + "Face used for line previews.") + +(defface consult-highlight-match + '((t :inherit match)) + "Face used to highlight matches in the completion candidates. +Used for example by `consult-grep'.") + +(defface consult-highlight-mark + '((t :inherit consult-highlight-match)) + "Face used for mark positions in completion candidates. +Used for example by `consult-mark'. The face should be different +than the `cursor' face to avoid confusion.") + +(defface consult-preview-match + '((t :inherit isearch)) + "Face used for match previews, e.g., in `consult-line'.") + +(defface consult-preview-insertion + '((t :inherit region)) + "Face used for previews of text to be inserted. +Used by `consult-completion-in-region', `consult-yank' and `consult-history'.") + +(defface consult-narrow-indicator + '((t :inherit warning)) + "Face used for the narrowing indicator.") + +(defface consult-async-running + '((t :inherit consult-narrow-indicator)) + "Face used if asynchronous process is running.") + +(defface consult-async-finished + '((t :inherit success)) + "Face used if asynchronous process has finished.") + +(defface consult-async-failed + '((t :inherit error)) + "Face used if asynchronous process has failed.") + +(defface consult-async-split + '((t :inherit font-lock-negation-char-face)) + "Face used to highlight punctuation character.") + +(defface consult-help + '((t :inherit shadow)) + "Face used to highlight help, e.g., in `consult-register-store'.") + +(defface consult-key + '((t :inherit font-lock-keyword-face)) + "Face used to highlight keys, e.g., in `consult-register'.") + +(defface consult-line-number + '((t :inherit consult-key)) + "Face used to highlight location line in `consult-global-mark'.") + +(defface consult-file + '((t :inherit font-lock-function-name-face)) + "Face used to highlight files in `consult-buffer'.") + +(defface consult-grep-context + '((t :inherit shadow)) + "Face used to highlight grep context in `consult-grep'.") + +(defface consult-bookmark + '((t :inherit font-lock-constant-face)) + "Face used to highlight bookmarks in `consult-buffer'.") + +(defface consult-buffer + '((t)) + "Face used to highlight buffers in `consult-buffer'.") + +(defface consult-line-number-prefix + '((t :inherit line-number)) + "Face used to highlight line number prefixes.") + +(defface consult-line-number-wrapped + '((t :inherit consult-line-number-prefix :inherit font-lock-warning-face)) + "Face used to highlight line number prefixes after wrap around.") + +(defface consult-separator + '((((class color) (min-colors 88) (background light)) + :foreground "#ccc") + (((class color) (min-colors 88) (background dark)) + :foreground "#333")) + "Face used for thin line separators in `consult-register-window'.") + +;;;; Input history variables + +(defvar consult--path-history nil) +(defvar consult--grep-history nil) +(defvar consult--find-history nil) +(defvar consult--man-history nil) +(defvar consult--line-history nil) +(defvar consult--line-multi-history nil) +(defvar consult--theme-history nil) +(defvar consult--minor-mode-menu-history nil) +(defvar consult--buffer-history nil) + +;;;; Internal variables + +(defvar consult--regexp-compiler + #'consult--default-regexp-compiler + "Regular expression compiler used by `consult-grep' and other commands. +The function must return a list of regular expressions and a highlighter +function.") + +(defvar consult--customize-alist + ;; Disable preview in frames, since `consult--jump-preview' does not properly + ;; clean up. See gh:minad/consult#593. This issue should better be fixed in + ;; `consult--jump-preview'. + `((,#'consult-buffer-other-frame :preview-key nil) + (,#'consult-buffer-other-tab :preview-key nil)) + "Command configuration alist for fine-grained configuration. + +Each element of the list must have the form (command-name plist...). The +options set here will be evaluated and passed to `consult--read', when +called from the corresponding command. Note that the options depend on +the private `consult--read' API and should not be considered as stable +as the public API.") + +(defvar consult--buffer-display #'switch-to-buffer + "Buffer display function.") + +(defvar consult--completion-candidate-hook + (list #'consult--default-completion-minibuffer-candidate + #'consult--default-completion-list-candidate) + "Get candidate from completion system.") + +(defvar consult--completion-refresh-hook nil + "Refresh completion system.") + +(defvar-local consult--preview-function nil + "Minibuffer-local variable which exposes the current preview function. +This function can be called by custom completion systems from +outside the minibuffer.") + +(defvar consult--annotate-align-step 10 + "Round candidate width.") + +(defvar consult--annotate-align-width 0 + "Maximum candidate width used for annotation alignment.") + +(defconst consult--tofu-char #x200000 + "Special character used to encode line prefixes for disambiguation. +We use invalid characters outside the Unicode range.") + +(defconst consult--tofu-range #x100000 + "Special character range.") + +(defvar-local consult--narrow nil + "Current narrowing key.") + +(defvar-local consult--narrow-keys nil + "Narrowing prefixes of the current completion.") + +(defvar-local consult--narrow-predicate nil + "Narrowing predicate of the current completion.") + +(defvar-local consult--narrow-overlay nil + "Narrowing indicator overlay.") + +(defvar consult--gc-threshold (* 64 1024 1024) + "Large GC threshold for temporary increase.") + +(defvar consult--gc-percentage 0.5 + "Large GC percentage for temporary increase.") + +(defvar consult--process-chunk (* 1024 1024) + "Increase process output chunk size.") + +(defvar consult--async-log + " *consult-async*" + "Buffer for async logging output used by `consult--async-process'.") + +(defvar-local consult--focus-lines-overlays nil + "Overlays used by `consult-focus-lines'.") + +(defvar-local consult--org-fold-regions nil + "Stored regions for the org-fold API.") + +;;;; Miscellaneous helper functions + +(defun consult--key-parse (key) + "Parse KEY or signal error if invalid." + (unless (key-valid-p key) + (error "%S is not a valid key definition; see `key-valid-p'" key)) + (key-parse key)) + +(defun consult--in-buffer (fun &optional buffer) + "Ensure that FUN is executed inside BUFFER." + (unless buffer (setq buffer (current-buffer))) + (lambda (&rest args) + (with-current-buffer buffer + (apply fun args)))) + +(defun consult--completion-table-in-buffer (table &optional buffer) + "Ensure that completion TABLE is executed inside BUFFER." + (if (functionp table) + (consult--in-buffer + (lambda (str pred action) + (let ((result (funcall table str pred action))) + (pcase action + ('metadata + (setq result + (mapcar + (lambda (x) + (if (and (string-suffix-p "-function" (symbol-name (car-safe x))) (cdr x)) + (cons (car x) (consult--in-buffer (cdr x))) + x)) + result))) + ((and 'completion--unquote (guard (functionp (cadr result)))) + (cl-callf consult--in-buffer (cadr result) buffer) + (cl-callf consult--in-buffer (cadddr result) buffer))) + result)) + buffer) + table)) + +(defun consult--build-args (arg) + "Return ARG as a flat list of split strings. + +Turn ARG into a list, and for each element either: +- split it if it a string. +- eval it if it is an expression." + (seq-mapcat (lambda (x) + (if (stringp x) + (split-string-and-unquote x) + (ensure-list (eval x 'lexical)))) + (ensure-list arg))) + +(defun consult--command-split (str) + "Return command argument and options list given input STR." + (save-match-data + (let ((opts (when (string-match " +--\\( +\\|\\'\\)" str) + (prog1 (substring str (match-end 0)) + (setq str (substring str 0 (match-beginning 0))))))) + ;; split-string-and-unquote fails if the quotes are invalid. Ignore it. + (cons str (and opts (ignore-errors (split-string-and-unquote opts))))))) + +(defmacro consult--keep! (list form) + "Evaluate FORM for every element of LIST and keep the non-nil results." + (declare (indent 1)) + (cl-with-gensyms (head prev result) + `(let* ((,head (cons nil ,list)) + (,prev ,head)) + (while (cdr ,prev) + (if-let (,result (let ((it (cadr ,prev))) ,form)) + (progn + (pop ,prev) + (setcar ,prev ,result)) + (setcdr ,prev (cddr ,prev)))) + (setq ,list (cdr ,head)) + nil))) + +(defun consult--completion-filter (pattern cands category _highlight) + "Filter CANDS with PATTERN. + +CATEGORY is the completion category, used to find the completion style via +`completion-category-defaults' and `completion-category-overrides'. +HIGHLIGHT must be non-nil if the resulting strings should be highlighted." + ;; Ensure that the global completion style settings are used for + ;; `consult-line', `consult-focus-lines' and `consult-keep-lines' filtering. + ;; This override is necessary since users may want to override the settings + ;; buffer-locally for in-buffer completion via Corfu. + (let ((completion-styles (default-value 'completion-styles)) + (completion-category-defaults (default-value 'completion-category-defaults)) + (completion-category-overrides (default-value 'completion-category-overrides))) + ;; `completion-all-completions' returns an improper list where the last link + ;; is not necessarily nil. + (nconc (completion-all-completions pattern cands nil (length pattern) + `(metadata (category . ,category))) + nil))) + +(defun consult--completion-filter-complement (pattern cands category _highlight) + "Filter CANDS with complement of PATTERN. +See `consult--completion-filter' for the arguments CATEGORY and HIGHLIGHT." + (let ((ht (consult--string-hash (consult--completion-filter pattern cands category nil)))) + (seq-remove (lambda (x) (gethash x ht)) cands))) + +(defun consult--completion-filter-dispatch (pattern cands category highlight) + "Filter CANDS with PATTERN with optional complement. +Either using `consult--completion-filter' or +`consult--completion-filter-complement', depending on if the pattern starts +with a bang. See `consult--completion-filter' for the arguments CATEGORY and +HIGHLIGHT." + (cond + ((string-match-p "\\`!? ?\\'" pattern) cands) ;; empty pattern + ((string-prefix-p "! " pattern) (consult--completion-filter-complement + (substring pattern 2) cands category nil)) + (t (consult--completion-filter pattern cands category highlight)))) + +(defmacro consult--each-line (beg end &rest body) + "Iterate over each line. + +The line beginning/ending BEG/END is bound in BODY." + (declare (indent 2)) + (cl-with-gensyms (max) + `(save-excursion + (let ((,beg (point-min)) (,max (point-max)) ,end) + (while (< ,beg ,max) + (goto-char ,beg) + (setq ,end (pos-eol)) + ,@body + (setq ,beg (1+ ,end))))))) + +(defun consult--display-width (string) + "Compute width of STRING taking display and invisible properties into account." + (let ((pos 0) (width 0) (end (length string))) + (while (< pos end) + (let ((nextd (next-single-property-change pos 'display string end)) + (display (get-text-property pos 'display string))) + (if (stringp display) + (setq width (+ width (string-width display)) + pos nextd) + (while (< pos nextd) + (let ((nexti (next-single-property-change pos 'invisible string nextd))) + (unless (get-text-property pos 'invisible string) + (setq width (+ width (string-width string pos nexti)))) + (setq pos nexti)))))) + width)) + +(defun consult--string-hash (strings) + "Create hash table from STRINGS." + (let ((ht (make-hash-table :test #'equal :size (length strings)))) + (dolist (str strings) + (puthash str t ht)) + ht)) + +(defmacro consult--local-let (binds &rest body) + "Buffer local let BINDS of dynamic variables in BODY." + (declare (indent 1)) + (let ((buffer (gensym "buffer")) + (local (mapcar (lambda (x) (cons (gensym "local") (car x))) binds))) + `(let ((,buffer (current-buffer)) + ,@(mapcar (lambda (x) `(,(car x) (local-variable-p ',(cdr x)))) local)) + (unwind-protect + (progn + ,@(mapcar (lambda (x) `(make-local-variable ',(car x))) binds) + (let (,@binds) + ,@body)) + (when (buffer-live-p ,buffer) + (with-current-buffer ,buffer + ,@(mapcar (lambda (x) + `(unless ,(car x) + (kill-local-variable ',(cdr x)))) + local))))))) + +(defvar consult--fast-abbreviate-file-name nil) +(defun consult--fast-abbreviate-file-name (name) + "Return abbreviate file NAME. +This function is a pure variant of `abbreviate-file-name', which +does not access the file system. This is important if we require +that the operation is fast, even for remote paths or paths on +network file systems." + (save-match-data + (let (case-fold-search) ;; Assume that file system is case sensitive. + (setq name (directory-abbrev-apply name)) + (if (string-match (with-memoization consult--fast-abbreviate-file-name + (directory-abbrev-make-regexp (expand-file-name "~"))) + name) + (concat "~" (substring name (match-beginning 1))) + name)))) + +(defun consult--left-truncate-file (file) + "Return abbreviated file name of FILE for use in `completing-read' prompt." + (save-match-data + (let ((file (directory-file-name (abbreviate-file-name file))) + (prefix nil)) + (when (string-match "\\`/\\([^/|:]+:\\)" file) + (setq prefix (propertize (match-string 1 file) 'face 'error) + file (substring file (match-end 0)))) + (when (and (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" file) + (< (- (match-end 0) (match-beginning 0) -3) (length file))) + (setq file (format "…/%s/%s" (match-string 1 file) (match-string 2 file)))) + (concat prefix file)))) + +(defun consult--directory-prompt (prompt dir) + "Return prompt, paths and default directory. + +PROMPT is the prompt prefix. The directory is appended to the +prompt prefix. For projects only the project name is shown. The +`default-directory' is not shown. Other directories are +abbreviated and only the last two path components are shown. + +If DIR is a string, it is returned as default directory. If DIR +is a list of strings, the list is returned as search paths. If +DIR is nil the `consult-project-function' is tried to retrieve +the default directory. If no project is found the +`default-directory' is returned as is. Otherwise the user is +asked for the directories or files to search via +`completing-read-multiple'." + (let* ((paths nil) + (dir + (pcase dir + ((pred stringp) dir) + ((or 'nil '(16)) (or (consult--project-root dir) default-directory)) + (_ + (pcase (if (stringp (car-safe dir)) + dir + ;; Preserve this-command across `completing-read-multiple' call, + ;; such that `consult-customize' continues to work. + (let ((this-command this-command) + (def (abbreviate-file-name default-directory)) + ;; TODO: `minibuffer-completing-file-name' is + ;; mostly deprecated, but still in use. Packages + ;; should instead use the completion metadata. + (minibuffer-completing-file-name t) + (ignore-case read-file-name-completion-ignore-case)) + (minibuffer-with-setup-hook + (lambda () + (setq-local completion-ignore-case ignore-case) + (set-syntax-table minibuffer-local-filename-syntax)) + (completing-read-multiple "Directories or files: " + #'completion-file-name-table + nil t def 'consult--path-history def)))) + ((and `(,p) (guard (file-directory-p p))) p) + (ps (setq paths (mapcar (lambda (p) + (file-relative-name (expand-file-name p))) + ps)) + default-directory))))) + (edir (file-name-as-directory (expand-file-name dir))) + (pdir (let ((default-directory edir)) + ;; Bind default-directory in order to find the project + (consult--project-root)))) + (list + (format "%s (%s): " prompt + (pcase paths + ((guard (<= 1 (length paths) 2)) + (string-join (mapcar #'consult--left-truncate-file paths) ", ")) + (`(,p . ,_) + (format "%d paths, %s, …" (length paths) (consult--left-truncate-file p))) + ((guard (equal edir pdir)) (concat "Project " (consult--project-name pdir))) + (_ (consult--left-truncate-file edir)))) + (or paths '(".")) + edir))) + +(declare-function project-current "project") +(declare-function project-root "project") + +(defun consult--default-project-function (may-prompt) + "Return project root directory. +When no project is found and MAY-PROMPT is non-nil ask the user." + (when-let (proj (project-current may-prompt)) + (project-root proj))) + +(defun consult--project-root (&optional may-prompt) + "Return project root as absolute path. +When no project is found and MAY-PROMPT is non-nil ask the user." + ;; Preserve this-command across project selection, + ;; such that `consult-customize' continues to work. + (let ((this-command this-command)) + (when-let (root (and consult-project-function + (funcall consult-project-function may-prompt))) + (expand-file-name root)))) + +(defun consult--project-name (dir) + "Return the project name for DIR." + (if (string-match "/\\([^/]+\\)/\\'" dir) + (propertize (match-string 1 dir) 'help-echo (abbreviate-file-name dir)) + dir)) + +(defun consult--format-file-line-match (file line match) + "Format string FILE:LINE:MATCH with faces." + (setq line (number-to-string line) + match (concat file ":" line ":" match) + file (length file)) + (put-text-property 0 file 'face 'consult-file match) + (put-text-property (1+ file) (+ 1 file (length line)) 'face 'consult-line-number match) + match) + +(defun consult--make-overlay (beg end &rest props) + "Make consult overlay between BEG and END with PROPS." + (let ((ov (make-overlay beg end))) + (while props + (overlay-put ov (car props) (cadr props)) + (setq props (cddr props))) + ov)) + +(defun consult--remove-dups (list) + "Remove duplicate strings from LIST." + (delete-dups (copy-sequence list))) + +(defsubst consult--in-range-p (pos) + "Return t if position POS lies in range `point-min' to `point-max'." + (<= (point-min) pos (point-max))) + +(defun consult--completion-window-p () + "Return non-nil if the selected window belongs to the completion UI." + (or (eq (selected-window) (active-minibuffer-window)) + (eq #'completion-list-mode (buffer-local-value 'major-mode (window-buffer))))) + +(defun consult--original-window () + "Return window which was just selected just before the minibuffer was entered. +In contrast to `minibuffer-selected-window' never return nil and +always return an appropriate non-minibuffer window." + (or (minibuffer-selected-window) + (if (window-minibuffer-p (selected-window)) + (next-window) + (selected-window)))) + +(defun consult--forbid-minibuffer () + "Raise an error if executed from the minibuffer." + (when (minibufferp) + (user-error "`%s' called inside the minibuffer" this-command))) + +(defun consult--require-minibuffer () + "Raise an error if executed outside the minibuffer." + (unless (minibufferp) + (user-error "`%s' must be called inside the minibuffer" this-command))) + +(defun consult--fontify-all () + "Ensure that the whole buffer is fontified." + ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the line + ;; is not font-locked. We would observe this if consulting an unfontified + ;; line. Therefore we have to enforce font-locking now, which is slow. In + ;; order to prevent is hang-up we check the buffer size against + ;; `consult-fontify-max-size'. + (when (and consult-fontify-preserve jit-lock-mode + (< (buffer-size) consult-fontify-max-size)) + (jit-lock-fontify-now))) + +(defun consult--fontify-region (start end) + "Ensure that region between START and END is fontified." + (when (and consult-fontify-preserve jit-lock-mode) + (jit-lock-fontify-now start end))) + +(defmacro consult--with-increased-gc (&rest body) + "Temporarily increase the GC limit in BODY to optimize for throughput." + (cl-with-gensyms (overwrite) + `(let* ((,overwrite (> consult--gc-threshold gc-cons-threshold)) + (gc-cons-threshold (if ,overwrite consult--gc-threshold gc-cons-threshold)) + (gc-cons-percentage (if ,overwrite consult--gc-percentage gc-cons-percentage))) + ,@body))) + +(defmacro consult--slow-operation (message &rest body) + "Show delayed MESSAGE if BODY takes too long. +Also temporarily increase the GC limit via `consult--with-increased-gc'." + (declare (indent 1)) + `(with-delayed-message (1 ,message) + (consult--with-increased-gc ,@body))) + +(defun consult--count-lines (pos) + "Move to position POS and return number of lines." + (let ((line 1)) + (while (< (point) pos) + (forward-line) + (when (<= (point) pos) + (cl-incf line))) + (goto-char pos) + line)) + +(defun consult--marker-from-line-column (buffer line column) + "Get marker in BUFFER from LINE and COLUMN." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (without-restriction + (goto-char (point-min)) + ;; Location data might be invalid by now! + (ignore-errors + (forward-line (1- line)) + (goto-char (min (+ (point) column) (pos-eol)))) + (point-marker)))))) + +(defun consult--line-prefix (&optional curr-line) + "Annotate `consult-location' candidates with line numbers. +CURR-LINE is the current line number." + (setq curr-line (or curr-line -1)) + (let* ((width (length (number-to-string (line-number-at-pos + (point-max) + consult-line-numbers-widen)))) + (before (format #("%%%dd " 0 6 (face consult-line-number-wrapped)) width)) + (after (format #("%%%dd " 0 6 (face consult-line-number-prefix)) width))) + (lambda (cand) + (let ((line (cdr (get-text-property 0 'consult-location cand)))) + (list cand (format (if (< line curr-line) before after) line) ""))))) + +(defsubst consult--location-candidate (cand marker line tofu &rest props) + "Add MARKER and LINE as `consult-location' text property to CAND. +Furthermore add the additional text properties PROPS, and append +TOFU suffix for disambiguation." + (setq cand (concat cand (consult--tofu-encode tofu))) + (add-text-properties 0 1 `(consult-location (,marker . ,line) ,@props) cand) + cand) + +;; There is a similar variable `yank-excluded-properties'. Unfortunately +;; we cannot use it here since it excludes too much (e.g., invisible) +;; and at the same time not enough (e.g., cursor-sensor-functions). +(defconst consult--remove-text-properties + '( category cursor cursor-intangible cursor-sensor-functions field follow-link + fontified front-sticky help-echo insert-behind-hooks insert-in-front-hooks + intangible keymap local-map modification-hooks mouse-face pointer read-only + rear-nonsticky yank-handler) + "List of text properties to remove from buffer strings.") + +(defsubst consult--buffer-substring (beg end &optional fontify) + "Return buffer substring between BEG and END. +If FONTIFY and `consult-fontify-preserve' are non-nil, first ensure that the +region has been fontified." + (if consult-fontify-preserve + (let (str) + (when fontify (consult--fontify-region beg end)) + (setq str (buffer-substring beg end)) + ;; TODO Propose the upstream addition of a function + ;; `preserve-list-of-text-properties', which should be as efficient as + ;; `remove-list-of-text-properties'. + (remove-list-of-text-properties + 0 (- end beg) consult--remove-text-properties str) + str) + (buffer-substring-no-properties beg end))) + +(defun consult--line-with-mark (marker) + "Current line string where the MARKER position is highlighted." + (let* ((beg (pos-bol)) + (end (pos-eol)) + (str (consult--buffer-substring beg end 'fontify))) + (if (>= marker end) + (concat str #(" " 0 1 (face consult-highlight-mark))) + (put-text-property (- marker beg) (- (1+ marker) beg) + 'face 'consult-highlight-mark str) + str))) + +;;;; Tofu cooks + +(defsubst consult--tofu-p (char) + "Return non-nil if CHAR is a tofu." + (<= consult--tofu-char char (+ consult--tofu-char consult--tofu-range -1))) + +(defun consult--tofu-hide (str) + "Hide the tofus in STR." + (let* ((max (length str)) + (end max)) + (while (and (> end 0) (consult--tofu-p (aref str (1- end)))) + (cl-decf end)) + (when (< end max) + (setq str (copy-sequence str)) + (put-text-property end max 'invisible t str)) + str)) + +(defsubst consult--tofu-append (cand id) + "Append tofu-encoded ID to CAND. +The ID must fit within a single character. It must be smaller +than `consult--tofu-range'." + (setq id (char-to-string (+ consult--tofu-char id))) + (add-text-properties 0 1 '(invisible t consult-strip t) id) + (concat cand id)) + +(defsubst consult--tofu-get (cand) + "Extract tofu-encoded ID from CAND. +See `consult--tofu-append'." + (- (aref cand (1- (length cand))) consult--tofu-char)) + +;; We must disambiguate the lines by adding a prefix such that two lines with +;; the same text can be distinguished. In order to avoid matching the line +;; number, such that the user can search for numbers with `consult-line', we +;; encode the line number as characters outside the Unicode range. By doing +;; that, no accidental matching can occur. +(defun consult--tofu-encode (n) + "Return tofu-encoded number N as a string. +Large numbers are encoded as multiple tofu characters." + (let (str tofu) + (while (progn + (setq tofu (char-to-string + (+ consult--tofu-char (% n consult--tofu-range))) + str (if str (concat tofu str) tofu)) + (and (>= n consult--tofu-range) + (setq n (/ n consult--tofu-range))))) + (add-text-properties 0 (length str) '(invisible t consult-strip t) str) + str)) + +;;;; Regexp utilities + +(defun consult--find-highlights (str start &rest ignored-faces) + "Find highlighted regions in STR from position START. +Highlighted regions have a non-nil face property. +IGNORED-FACES are ignored when searching for matches." + (let (highlights + (end (length str)) + (beg start)) + (while (< beg end) + (let ((next (next-single-property-change beg 'face str end)) + (val (get-text-property beg 'face str))) + (when (and val + (not (memq val ignored-faces)) + (not (and (consp val) + (seq-some (lambda (x) (memq x ignored-faces)) val)))) + (push (cons (- beg start) (- next start)) highlights)) + (setq beg next))) + (nreverse highlights))) + +(defun consult--point-placement (str start &rest ignored-faces) + "Compute point placement from STR with START offset. +IGNORED-FACES are ignored when searching for matches. +Return cons of point position and a list of match begin/end pairs." + (let* ((matches (apply #'consult--find-highlights str start ignored-faces)) + (pos (pcase-exhaustive consult-point-placement + ('match-beginning (or (caar matches) 0)) + ('match-end (or (cdar (last matches)) 0)) + ('line-beginning 0)))) + (dolist (match matches) + (cl-decf (car match) pos) + (cl-decf (cdr match) pos)) + (cons pos matches))) + +(defun consult--highlight-regexps (regexps ignore-case str) + "Highlight REGEXPS in STR. +If a regular expression contains capturing groups, only these are highlighted. +If no capturing groups are used highlight the whole match. Case is ignored +if IGNORE-CASE is non-nil." + (dolist (re regexps) + (let ((i 0)) + (while (and (let ((case-fold-search ignore-case)) + (string-match re str i)) + ;; Ensure that regexp search made progress (edge case for .*) + (> (match-end 0) i)) + ;; Unfortunately there is no way to avoid the allocation of the match + ;; data, since the number of capturing groups is unknown. + (let ((m (match-data))) + (setq i (cadr m) m (or (cddr m) m)) + (while m + (when (car m) + (add-face-text-property (car m) (cadr m) + 'consult-highlight-match nil str)) + (setq m (cddr m))))))) + str) + +(defconst consult--convert-regexp-table + (append + ;; For simplicity, treat word beginning/end as word boundaries, + ;; since PCRE does not make this distinction. Usually the + ;; context determines if \b is the beginning or the end. + '(("\\<" . "\\b") ("\\>" . "\\b") + ("\\_<" . "\\b") ("\\_>" . "\\b")) + ;; Treat \` and \' as beginning and end of line. This is more + ;; widely supported and makes sense for line-based commands. + '(("\\`" . "^") ("\\'" . "$")) + ;; Historical: Unescaped *, +, ? are supported at the beginning + (mapcan (lambda (x) + (mapcar (lambda (y) + (cons (concat x y) + (concat (string-remove-prefix "\\" x) "\\" y))) + '("*" "+" "?"))) + '("" "\\(" "\\(?:" "\\|" "^")) + ;; Different escaping + (mapcan (lambda (x) `(,x (,(cdr x) . ,(car x)))) + '(("\\|" . "|") + ("\\(" . "(") ("\\)" . ")") + ("\\{" . "{") ("\\}" . "}")))) + "Regexp conversion table.") + +(defun consult--convert-regexp (regexp type) + "Convert Emacs REGEXP to regexp syntax TYPE." + (if (memq type '(emacs basic)) + regexp + ;; Support for Emacs regular expressions is fairly complete for basic + ;; usage. There are a few unsupported Emacs regexp features: + ;; - \= point matching + ;; - Syntax classes \sx \Sx + ;; - Character classes \cx \Cx + ;; - Explicitly numbered groups (?3:group) + (replace-regexp-in-string + (rx (or "\\\\" "\\^" ;; Pass through + (seq (or "\\(?:" "\\|") (any "*+?")) ;; Historical: \|+ or \(?:* etc + (seq "\\(" (any "*+")) ;; Historical: \(* or \(+ + (seq (or bos "^") (any "*+?")) ;; Historical: + or * at the beginning + (seq (opt "\\") (any "(){|}")) ;; Escape parens/braces/pipe + (seq "\\" (any "'<>`")) ;; Special escapes + (seq "\\_" (any "<>")))) ;; Beginning or end of symbol + (lambda (x) (or (cdr (assoc x consult--convert-regexp-table)) x)) + regexp 'fixedcase 'literal))) + +(defun consult--default-regexp-compiler (input type ignore-case) + "Compile the INPUT string to a list of regular expressions. +The function should return a pair, the list of regular expressions and a +highlight function. The highlight function should take a single +argument, the string to highlight given the INPUT. TYPE is the desired +type of regular expression, which can be `basic', `extended', `emacs' or +`pcre'. If IGNORE-CASE is non-nil return a highlight function which +matches case insensitively." + (setq input (consult--split-escaped input)) + (cons (mapcar (lambda (x) (consult--convert-regexp x type)) input) + (when-let (regexps (seq-filter #'consult--valid-regexp-p input)) + (apply-partially #'consult--highlight-regexps regexps ignore-case)))) + +(defun consult--split-escaped (str) + "Split STR at spaces, which can be escaped with backslash." + (mapcar + (lambda (x) (string-replace "\0" " " x)) + (split-string (replace-regexp-in-string + "\\\\\\\\\\|\\\\ " + (lambda (x) (if (equal x "\\ ") "\0" x)) + str 'fixedcase 'literal) + " +" t))) + +(defun consult--join-regexps (regexps type) + "Join REGEXPS of TYPE." + ;; Add look-ahead wrapper only if there is more than one regular expression + (cond + ((and (eq type 'pcre) (cdr regexps)) + (concat "^" (mapconcat (lambda (x) (format "(?=.*%s)" x)) + regexps ""))) + ((eq type 'basic) + (string-join regexps ".*")) + (t + (when (length> regexps 3) + (message "Too many regexps, %S ignored. Use post-filtering!" + (string-join (seq-drop regexps 3) " ")) + (setq regexps (seq-take regexps 3))) + (consult--join-regexps-permutations regexps (and (eq type 'emacs) "\\"))))) + +(defun consult--join-regexps-permutations (regexps esc) + "Join all permutations of REGEXPS. +ESC is the escaping string for choice and groups." + (pcase regexps + ('nil "") + (`(,r) r) + (_ (mapconcat + (lambda (r) + (concat esc "(" r esc ").*" esc "(" + (consult--join-regexps-permutations (remove r regexps) esc) + esc ")")) + regexps (concat esc "|"))))) + +(defun consult--valid-regexp-p (re) + "Return t if regexp RE is valid." + (condition-case nil + (progn (string-match-p re "") t) + (invalid-regexp nil))) + +(defun consult--regexp-filter (regexps) + "Create filter regexp from REGEXPS." + (if (stringp regexps) + regexps + (mapconcat (lambda (x) (concat "\\(?:" x "\\)")) regexps "\\|"))) + +;;;; Lookup functions + +(defun consult--lookup-member (selected candidates &rest _) + "Lookup SELECTED in CANDIDATES list, return original element." + (car (member selected candidates))) + +(defun consult--lookup-cons (selected candidates &rest _) + "Lookup SELECTED in CANDIDATES alist, return cons." + (assoc selected candidates)) + +(defun consult--lookup-cdr (selected candidates &rest _) + "Lookup SELECTED in CANDIDATES alist, return `cdr' of element." + (cdr (assoc selected candidates))) + +(defun consult--lookup-location (selected candidates &rest _) + "Lookup SELECTED in CANDIDATES list of `consult-location' category. +Return the location marker." + (when-let (found (member selected candidates)) + (setq found (car (consult--get-location (car found)))) + ;; Check that marker is alive + (and (or (not (markerp found)) (marker-buffer found)) found))) + +(defun consult--lookup-prop (prop selected candidates &rest _) + "Lookup SELECTED in CANDIDATES list and return PROP value." + (when-let (found (member selected candidates)) + (get-text-property 0 prop (car found)))) + +(defun consult--lookup-candidate (selected candidates &rest _) + "Lookup SELECTED in CANDIDATES list and return property `consult--candidate'." + (consult--lookup-prop 'consult--candidate selected candidates)) + +;;;; Preview support + +(defun consult--preview-allowed-p (fun) + "Return non-nil if FUN is an allowed preview mode hook." + (or (memq fun consult-preview-allowed-hooks) + (when-let (((symbolp fun)) + (name (symbol-name fun)) + ;; Global modes in Emacs 29 are activated via a + ;; `find-file-hook' ending with `-check-buffers'. This has been + ;; changed in Emacs 30. Now a `change-major-mode-hook' is used + ;; instead with the suffix `-check-buffers'. + (suffix (static-if (>= emacs-major-version 30) + "-enable-in-buffer" + "-check-buffers")) + ((string-suffix-p suffix name))) + (memq (intern (string-remove-suffix suffix name)) + consult-preview-allowed-hooks)))) + +(defun consult--filter-find-file-hook (orig &rest hooks) + "Filter `find-file-hook' by `consult-preview-allowed-hooks'. +This function is an advice for `run-hooks'. +ORIG is the original function, HOOKS the arguments." + (if (memq 'find-file-hook hooks) + (cl-letf* (((default-value 'find-file-hook) + (seq-filter #'consult--preview-allowed-p + (default-value 'find-file-hook))) + (find-file-hook (default-value 'find-file-hook))) + (apply orig hooks)) + (apply orig hooks))) + +(defun consult--find-file-temporarily-1 (name) + "Open file NAME, helper function for `consult--find-file-temporarily'." + (when-let (((not (seq-find (lambda (x) (string-match-p x name)) + consult-preview-excluded-files))) + ;; file-attributes may throw permission denied error + (attrs (ignore-errors (file-attributes name))) + (size (file-attribute-size attrs))) + (let* ((partial (>= size consult-preview-partial-size)) + (buffer (if partial + (generate-new-buffer (format "consult-partial-preview-%s" name)) + (find-file-noselect name 'nowarn))) + (success nil)) + (unwind-protect + (with-current-buffer buffer + (if (not partial) + (when (or (eq major-mode 'hexl-mode) + (and (eq major-mode 'fundamental-mode) + (save-excursion (search-forward "\0" nil 'noerror)))) + (error "No preview of binary file `%s'" + (file-name-nondirectory name))) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents name nil 0 consult-preview-partial-chunk) + (goto-char (point-max)) + (insert "\nFile truncated. End of partial preview.\n") + (goto-char (point-min))) + (when (save-excursion (search-forward "\0" nil 'noerror)) + (error "No partial preview of binary file `%s'" + (file-name-nondirectory name))) + ;; Auto detect major mode and hope for the best, given that the + ;; file is only previewed partially. If an error is thrown the + ;; buffer will be killed and preview is aborted. + (set-auto-mode) + (font-lock-mode 1)) + (when (bound-and-true-p so-long-detected-p) + (error "No preview of file `%s' with long lines" + (file-name-nondirectory name))) + ;; Run delayed hooks listed in `consult-preview-allowed-hooks'. + (dolist (hook (reverse (cons 'after-change-major-mode-hook delayed-mode-hooks))) + (run-hook-wrapped hook (lambda (fun) + (when (consult--preview-allowed-p fun) + (funcall fun)) + nil))) + (setq success (current-buffer))) + (unless success + (kill-buffer buffer)))))) + +(defun consult--find-file-temporarily (name) + "Open file NAME temporarily for preview." + (let ((vars (delq nil + (mapcar + (pcase-lambda (`(,k . ,v)) + (if (boundp k) + (list k v (default-value k) (symbol-value k)) + (message "consult-preview-variables: The variable `%s' is not bound" k) + nil)) + consult-preview-variables)))) + (condition-case err + (unwind-protect + (progn + (advice-add #'run-hooks :around #'consult--filter-find-file-hook) + (pcase-dolist (`(,k ,v . ,_) vars) + (set-default k v) + (set k v)) + (consult--find-file-temporarily-1 name)) + (advice-remove #'run-hooks #'consult--filter-find-file-hook) + (pcase-dolist (`(,k ,_ ,d ,v) vars) + (set-default k d) + (set k v))) + (error + (message "%s" (error-message-string err)) + nil)))) + +(defun consult--temporary-files () + "Return a function to open files temporarily for preview." + (let ((dir default-directory) + (hook (make-symbol "consult--temporary-files-upgrade-hook")) + (orig-buffers (buffer-list)) + temporary-buffers) + (fset hook + (lambda (_) + ;; Fully initialize previewed files and keep them alive. + (unless (consult--completion-window-p) + (let (live-files) + (pcase-dolist (`(,file . ,buf) temporary-buffers) + (when-let (wins (and (buffer-live-p buf) + (get-buffer-window-list buf))) + (push (cons file (mapcar + (lambda (win) + (cons win (window-state-get win t))) + wins)) + live-files))) + (pcase-dolist (`(,_ . ,buf) temporary-buffers) + (kill-buffer buf)) + (setq temporary-buffers nil) + (pcase-dolist (`(,file . ,wins) live-files) + (when-let (buf (consult--file-action file)) + (push buf orig-buffers) + (pcase-dolist (`(,win . ,state) wins) + (setf (car (alist-get 'buffer state)) buf) + (window-state-put state win)))))))) + (lambda (&optional name) + (if name + (let ((default-directory dir)) + (setq name (abbreviate-file-name (expand-file-name name))) + (or + ;; Find existing fully initialized buffer (non-previewed). We have + ;; to check for fully initialized buffer before accessing the + ;; previewed buffers, since `embark-act' can open a buffer which is + ;; currently previewed, such that we end up with two buffers for + ;; the same file - one previewed and only partially initialized and + ;; one fully initialized. In this case we prefer the fully + ;; initialized buffer. For directories `get-file-buffer' returns nil, + ;; therefore we have to special case Dired. + (if (and (fboundp 'dired-find-buffer-nocreate) (file-directory-p name)) + (dired-find-buffer-nocreate name) + (get-file-buffer name)) + ;; Find existing previewed buffer. Previewed buffers are not fully + ;; initialized (hooks are delayed) in order to ensure fast preview. + (cdr (assoc name temporary-buffers)) + ;; Finally, if no existing buffer has been found, open the file for + ;; preview. + (when-let (buf (consult--find-file-temporarily name)) + ;; Only add new buffer if not already in the list + (unless (or (rassq buf temporary-buffers) (memq buf orig-buffers)) + (add-hook 'window-selection-change-functions hook) + (push (cons name buf) temporary-buffers) + ;; Disassociate buffer from file by setting `buffer-file-name' + ;; and `dired-directory' to nil and rename the buffer. This + ;; lets us open an already previewed buffer with the Embark + ;; default action C-. RET. + (with-current-buffer buf + (rename-buffer + (format " Preview:%s" + (file-name-nondirectory (directory-file-name name))) + 'unique)) + ;; The buffer disassociation is delayed to avoid breaking modes + ;; like `pdf-view-mode' or `doc-view-mode' which rely on + ;; `buffer-file-name'. Executing (set-visited-file-name nil) + ;; early also prevents the major mode initialization. + (let ((hook (make-symbol "consult--temporary-files-disassociate-hook"))) + (fset hook (lambda () + (when (buffer-live-p buf) + (with-current-buffer buf + (remove-hook 'pre-command-hook hook) + (setq-local buffer-read-only t + dired-directory nil + buffer-file-name nil))))) + (add-hook 'pre-command-hook hook)) + ;; Only keep a few buffers alive + (while (length> temporary-buffers consult-preview-max-count) + (kill-buffer (cdar (last temporary-buffers))) + (setq temporary-buffers (nbutlast temporary-buffers)))) + buf))) + (remove-hook 'window-selection-change-functions hook) + (pcase-dolist (`(,_ . ,buf) temporary-buffers) + (kill-buffer buf)) + (setq temporary-buffers nil))))) + +(defun consult--invisible-open-permanently () + "Open overlays which hide the current line. +See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." + (if (and (derived-mode-p 'org-mode) (fboundp 'org-fold-show-set-visibility)) + ;; New Org 9.6 fold-core API + (let ((inhibit-redisplay t)) ;; HACK: Prevent flicker due to premature redisplay + (org-fold-show-set-visibility 'canonical)) + (dolist (ov (overlays-in (pos-bol) (pos-eol))) + (when-let (fun (overlay-get ov 'isearch-open-invisible)) + (when (invisible-p (overlay-get ov 'invisible)) + (funcall fun ov)))))) + +(defun consult--invisible-open-temporarily () + "Temporarily open overlays which hide the current line. +See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." + (if (and (derived-mode-p 'org-mode) + (fboundp 'org-fold-show-set-visibility) + (fboundp 'org-fold-core-get-regions) + (fboundp 'org-fold-core-region)) + ;; New Org 9.6 fold-core API + ;; TODO The provided Org API `org-fold-show-set-visibility' cannot be used + ;; efficiently. We obtain all regions in the whole buffer in order to + ;; restore them. A better show API would return all the applied + ;; modifications such that we can restore the ones which got modified. + (progn + (unless consult--org-fold-regions + (setq consult--org-fold-regions + (delq nil (org-fold-core-get-regions + :with-markers t :from (point-min) :to (point-max)))) + (when consult--org-fold-regions + (let ((hook (make-symbol "consult--invisible-open-temporarily-cleanup-hook")) + (buffer (current-buffer)) + (depth (recursion-depth))) + (fset hook + (lambda () + (when (= (recursion-depth) depth) + (remove-hook 'minibuffer-exit-hook hook) + (run-at-time + 0 nil + (lambda () + (when (buffer-live-p buffer) + (with-current-buffer buffer + (pcase-dolist (`(,beg ,end ,_) consult--org-fold-regions) + (when (markerp beg) (set-marker beg nil)) + (when (markerp end) (set-marker end nil))) + (kill-local-variable 'consult--org-fold-regions)))))))) + (add-hook 'minibuffer-exit-hook hook)))) + (let ((inhibit-redisplay t)) ;; HACK: Prevent flicker due to premature redisplay + (org-fold-show-set-visibility 'canonical)) + (list (lambda () + (pcase-dolist (`(,beg ,end ,spec) consult--org-fold-regions) + (org-fold-core-region beg end t spec))))) + (let (restore) + (dolist (ov (overlays-in (pos-bol) (pos-eol))) + (let ((inv (overlay-get ov 'invisible))) + (when (and (invisible-p inv) (overlay-get ov 'isearch-open-invisible)) + (push (if-let (fun (overlay-get ov 'isearch-open-invisible-temporary)) + (progn + (funcall fun ov nil) + (lambda () (funcall fun ov t))) + (overlay-put ov 'invisible nil) + (lambda () (overlay-put ov 'invisible inv))) + restore)))) + restore))) + +(defun consult--jump-ensure-buffer (pos) + "Ensure that buffer of marker POS is displayed, return t if successful." + (or (not (markerp pos)) + ;; Switch to buffer if it is not visible + (when-let ((buf (marker-buffer pos))) + (or (and (eq (current-buffer) buf) (eq (window-buffer) buf)) + (consult--buffer-action buf 'norecord) + t)))) + +(defun consult--jump (pos) + "Jump to POS. +First push current position to mark ring, then move to new +position and run `consult-after-jump-hook'." + (when pos + ;; Extract marker from list with with overlay positions, see `consult--line-match' + (when (consp pos) (setq pos (car pos))) + ;; When the marker is in the same buffer, record previous location + ;; such that the user can jump back quickly. + (when (or (not (markerp pos)) (eq (current-buffer) (marker-buffer pos))) + ;; push-mark mutates markers in the mark-ring and the mark-marker. + ;; Therefore we transform the marker to a number to be safe. + ;; We all love side effects! + (setq pos (+ pos 0)) + (push-mark (point) t)) + (when (consult--jump-ensure-buffer pos) + (unless (= (goto-char pos) (point)) ;; Widen if jump failed + (widen) + (goto-char pos)) + (consult--invisible-open-permanently) + (run-hooks 'consult-after-jump-hook))) + nil) + +(defun consult--jump-preview () + "The preview function used if selecting from a list of candidate positions. +The function can be used as the `:state' argument of `consult--read'." + (let (restore) + (lambda (action cand) + (when (eq action 'preview) + (mapc #'funcall restore) + (setq restore nil) + ;; TODO Better buffer preview support + ;; 1. Use consult--buffer-preview instead of consult--jump-ensure-buffer + ;; 2. Remove function consult--jump-ensure-buffer + ;; 3. Remove consult-buffer-other-* from consult-customize-alist + (when-let ((pos (or (car-safe cand) cand)) ;; Candidate can be previewed + ((consult--jump-ensure-buffer pos))) + (let ((saved-min (point-min-marker)) + (saved-max (point-max-marker)) + (saved-pos (point-marker))) + (set-marker-insertion-type saved-max t) ;; Grow when text is inserted + (push (lambda () + (when-let ((buf (marker-buffer saved-pos))) + (with-current-buffer buf + (narrow-to-region saved-min saved-max) + (goto-char saved-pos) + (set-marker saved-pos nil) + (set-marker saved-min nil) + (set-marker saved-max nil)))) + restore)) + (unless (= (goto-char pos) (point)) ;; Widen if jump failed + (widen) + (goto-char pos)) + (setq restore (nconc (consult--invisible-open-temporarily) restore)) + ;; Ensure that cursor is properly previewed (gh:minad/consult#764) + (unless (eq cursor-in-non-selected-windows 'box) + (let ((orig cursor-in-non-selected-windows) + (buf (current-buffer))) + (push + (if (local-variable-p 'cursor-in-non-selected-windows) + (lambda () + (when (buffer-live-p buf) + (with-current-buffer buf + (setq-local cursor-in-non-selected-windows orig)))) + (lambda () + (when (buffer-live-p buf) + (with-current-buffer buf + (kill-local-variable 'cursor-in-non-selected-windows))))) + restore) + (setq-local cursor-in-non-selected-windows 'box))) + ;; Match previews + (let ((overlays + (list (save-excursion + (let ((vbeg (progn (beginning-of-visual-line) (point))) + (vend (progn (end-of-visual-line) (point))) + (end (pos-eol))) + (consult--make-overlay vbeg (if (= vend end) (1+ end) vend) + 'face 'consult-preview-line + 'window (selected-window) + 'priority 1)))))) + (dolist (match (cdr-safe cand)) + (push (consult--make-overlay (+ (point) (car match)) + (+ (point) (cdr match)) + 'face 'consult-preview-match + 'window (selected-window) + 'priority 2) + overlays)) + (push (lambda () (mapc #'delete-overlay overlays)) restore)) + (run-hooks 'consult-after-jump-hook)))))) + +(defun consult--jump-state () + "The state function used if selecting from a list of candidate positions." + (consult--state-with-return (consult--jump-preview) #'consult--jump)) + +(defun consult--get-location (cand) + "Return location from CAND." + (let ((loc (get-text-property 0 'consult-location cand))) + (when (consp (car loc)) + ;; Transform cheap marker to real marker + (setcar loc (set-marker (make-marker) (cdar loc) (caar loc)))) + loc)) + +(defun consult--location-state (candidates) + "Location state function. +The cheap location markers from CANDIDATES are upgraded on window +selection change to full Emacs markers." + (let ((jump (consult--jump-state)) + (hook (make-symbol "consult--location-upgrade-hook"))) + (fset hook + (lambda (_) + (unless (consult--completion-window-p) + (remove-hook 'window-selection-change-functions hook) + (mapc #'consult--get-location + (if (functionp candidates) (funcall candidates) candidates))))) + (lambda (action cand) + (pcase action + ('setup (add-hook 'window-selection-change-functions hook)) + ('exit (remove-hook 'window-selection-change-functions hook))) + (funcall jump action cand)))) + +(defun consult--state-with-return (state return) + "Compose STATE function with RETURN function." + (lambda (action cand) + (funcall state action cand) + (when (and cand (eq action 'return)) + (funcall return cand)))) + +(defmacro consult--define-state (type) + "Define state function for TYPE." + `(defun ,(intern (format "consult--%s-state" type)) () + ,(format "State function for %ss with preview. +The result can be passed as :state argument to `consult--read'." type) + (consult--state-with-return (,(intern (format "consult--%s-preview" type))) + #',(intern (format "consult--%s-action" type))))) + +(defun consult--preview-key-normalize (preview-key) + "Normalize PREVIEW-KEY, return alist of keys and debounce times." + (let ((keys) + (debounce 0)) + (setq preview-key (ensure-list preview-key)) + (while preview-key + (if (eq (car preview-key) :debounce) + (setq debounce (cadr preview-key) + preview-key (cddr preview-key)) + (let ((key (car preview-key))) + (unless (eq key 'any) + (setq key (consult--key-parse key))) + (push (cons key debounce) keys)) + (pop preview-key))) + keys)) + +(defun consult--preview-key-debounce (preview-key cand) + "Return debounce value of PREVIEW-KEY given the current candidate CAND." + (when (and (consp preview-key) (memq :keys preview-key)) + (setq preview-key (funcall (plist-get preview-key :predicate) cand))) + (let ((map (make-sparse-keymap)) + (keys (this-single-command-keys)) + any) + (pcase-dolist (`(,k . ,d) (consult--preview-key-normalize preview-key)) + (if (eq k 'any) + (setq any d) + (define-key map k `(lambda () ,d)))) + (setq keys (lookup-key map keys)) + (if (functionp keys) (funcall keys) any))) + +(defun consult--preview-append-local-pch (fun) + "Append FUN to local `post-command-hook' list." + ;; Symbol indirection because of bug#46407. + (let ((hook (make-symbol "consult--preview-post-command-hook"))) + (fset hook fun) + ;; TODO Emacs 28 has a bug, where the hook--depth-alist is not cleaned up properly + ;; Do not use the broken add-hook here. + ;;(add-hook 'post-command-hook hook 'append 'local) + (setq-local post-command-hook + (append + (remove t post-command-hook) + (list hook) + (and (memq t post-command-hook) '(t)))))) + +(defun consult--with-preview-1 (preview-key state transform candidate save-input fun) + "Add preview support for FUN. +See `consult--with-preview' for the arguments +PREVIEW-KEY, STATE, TRANSFORM, CANDIDATE and SAVE-INPUT." + (let ((mb-input "") mb-narrow selected timer previewed) + (minibuffer-with-setup-hook + (if (and state preview-key) + (lambda () + (let ((hook (make-symbol "consult--preview-minibuffer-exit-hook")) + (depth (recursion-depth))) + (fset hook + (lambda () + (when (= (recursion-depth) depth) + (remove-hook 'minibuffer-exit-hook hook) + (when timer + (cancel-timer timer) + (setq timer nil)) + (with-selected-window (consult--original-window) + ;; STEP 3: Reset preview + (when previewed + (funcall state 'preview nil)) + ;; STEP 4: Notify the preview function of the minibuffer exit + (funcall state 'exit nil))))) + (add-hook 'minibuffer-exit-hook hook)) + ;; STEP 1: Setup the preview function + (with-selected-window (consult--original-window) + (funcall state 'setup nil)) + (setq consult--preview-function + (lambda () + (when-let ((cand (funcall candidate))) + ;; Drop properties to prevent bugs regarding candidate + ;; lookup, which must handle candidates without + ;; properties. Otherwise the arguments passed to the + ;; lookup function are confusing, since during preview + ;; the candidate has properties but for the final lookup + ;; after completion it does not. + (setq cand (substring-no-properties cand)) + (with-selected-window (active-minibuffer-window) + (let ((input (minibuffer-contents-no-properties)) + (narrow consult--narrow) + (win (consult--original-window))) + (with-selected-window win + (when-let ((transformed (funcall transform narrow input cand)) + (debounce (consult--preview-key-debounce preview-key transformed))) + (when timer + (cancel-timer timer) + (setq timer nil)) + ;; The transformed candidate may have text + ;; properties, which change the preview display. + ;; This matters for example for `consult-grep', + ;; where the current candidate and input may + ;; stay equal, but the highlighting of the + ;; candidate changes while the candidates list + ;; is lagging a bit behind and updates + ;; asynchronously. + ;; + ;; In older Consult versions we instead compared + ;; the input without properties, since I worried + ;; that comparing the transformed candidates + ;; could be potentially expensive. However + ;; comparing the transformed candidates is more + ;; correct. The transformed candidate is the + ;; thing which is actually previewed. + (unless (equal-including-properties previewed transformed) + (if (> debounce 0) + (setq timer + (run-at-time + debounce nil + (lambda () + ;; Preview only when a completion + ;; window is selected and when + ;; the preview window is alive. + (when (and (consult--completion-window-p) + (window-live-p win)) + (with-selected-window win + ;; STEP 2: Preview candidate + (funcall state 'preview (setq previewed transformed))))))) + ;; STEP 2: Preview candidate + (funcall state 'preview (setq previewed transformed))))))))))) + (consult--preview-append-local-pch + (lambda () + (setq mb-input (minibuffer-contents-no-properties) + mb-narrow consult--narrow) + (funcall consult--preview-function)))) + (lambda () + (consult--preview-append-local-pch + (lambda () + (setq mb-input (minibuffer-contents-no-properties) + mb-narrow consult--narrow))))) + (unwind-protect + (setq selected (when-let (result (funcall fun)) + (when-let ((save-input) + (list (symbol-value save-input)) + ((equal (car list) result))) + (set save-input (cdr list))) + (funcall transform mb-narrow mb-input result))) + (when save-input + (add-to-history save-input mb-input)) + (when state + ;; STEP 5: The preview function should perform its final action + (funcall state 'return selected)))))) + +(defmacro consult--with-preview (preview-key state transform candidate save-input &rest body) + "Add preview support to BODY. + +STATE is the state function. +TRANSFORM is the transformation function. +CANDIDATE is the function returning the current candidate. +PREVIEW-KEY are the keys which triggers the preview. +SAVE-INPUT can be a history variable symbol to save the input. + +The state function takes two arguments, an action argument and the +selected candidate. The candidate argument can be nil if no candidate is +selected or if the selection was aborted. The function is called in +sequence with the following arguments: + + 1. \\='setup nil After entering the mb (minibuffer-setup-hook). +⎧ 2. \\='preview CAND/nil Preview candidate CAND or reset if CAND is nil. +⎪ \\='preview CAND/nil +⎪ \\='preview CAND/nil +⎪ ... +⎩ 3. \\='preview nil Reset preview. + 4. \\='exit nil Before exiting the mb (minibuffer-exit-hook). + 5. \\='return CAND/nil After leaving the mb, CAND has been selected. + +The state function is always executed with the original window selected, +see `consult--original-window'. The state function is called once in +the beginning of the minibuffer setup with the `setup' argument. This is +useful in order to perform certain setup operations which require that +the minibuffer is initialized. During completion candidates are +previewed. Then the function is called with the `preview' argument and a +candidate CAND or nil if no candidate is selected. Furthermore if nil is +passed for CAND, then the preview must be undone and the original state +must be restored. The call with the `exit' argument happens once at the +end of the completion process, just before exiting the minibuffer. The +minibuffer is still alive at that point. Both `setup' and `exit' are +only useful for setup and cleanup operations. They don't receive a +candidate as argument. After leaving the minibuffer, the selected +candidate or nil is passed to the state function with the action +argument `return'. At this point the state function can perform the +actual action on the candidate. The state function with the `return' +argument is the continuation of `consult--read'. Via `unwind-protect' it +is guaranteed, that if the `setup' action of a state function is +invoked, the state function will also be called with `exit' and +`return'." + (declare (indent 5)) + `(consult--with-preview-1 ,preview-key ,state ,transform ,candidate ,save-input (lambda () ,@body))) + +;;;; Narrowing and grouping + +(defun consult--prefix-group (cand transform) + "Return title for CAND or TRANSFORM the candidate. +The candidate must have a `consult--prefix-group' property." + (if transform + (substring cand (1+ (length (get-text-property 0 'consult--prefix-group cand)))) + (get-text-property 0 'consult--prefix-group cand))) + +(defun consult--type-group (types) + "Return group function for TYPES." + (lambda (cand transform) + (if transform cand + (alist-get (get-text-property 0 'consult--type cand) types)))) + +(defun consult--type-narrow (types) + "Return narrowing configuration from TYPES." + (list :predicate + (lambda (cand) (eq (get-text-property 0 'consult--type cand) consult--narrow)) + :keys types)) + +(defun consult--widen-key () + "Return widening key, if `consult-widen-key' is not set. +The default is twice the `consult-narrow-key'." + (cond + (consult-widen-key + (consult--key-parse consult-widen-key)) + (consult-narrow-key + (let ((key (consult--key-parse consult-narrow-key))) + (vconcat key key))))) + +(defun consult-narrow (key) + "Narrow current completion with KEY. + +This command is used internally by the narrowing system of `consult--read'." + (declare (completion ignore)) + (interactive + (list (unless (equal (this-single-command-keys) (consult--widen-key)) + last-command-event))) + (consult--require-minibuffer) + (setq consult--narrow key) + (when consult--narrow-predicate + (setq minibuffer-completion-predicate (and consult--narrow consult--narrow-predicate))) + (when consult--narrow-overlay + (delete-overlay consult--narrow-overlay)) + (when consult--narrow + (setq consult--narrow-overlay + (consult--make-overlay + (1- (minibuffer-prompt-end)) (minibuffer-prompt-end) + 'before-string + (propertize (format " [%s]" (alist-get consult--narrow + consult--narrow-keys)) + 'face 'consult-narrow-indicator)))) + (run-hooks 'consult--completion-refresh-hook)) + +(defconst consult--narrow-delete + `(menu-item + "" nil :filter + ,(lambda (&optional _) + (when (equal (minibuffer-contents-no-properties) "") + (lambda () + (interactive) + (consult-narrow nil)))))) + +(defconst consult--narrow-space + `(menu-item + "" nil :filter + ,(lambda (&optional _) + (let ((str (minibuffer-contents-no-properties))) + (when-let (pair (or (and (length= str 1) + (assoc (aref str 0) consult--narrow-keys)) + (and (equal str "") + (assoc ?\s consult--narrow-keys)))) + (lambda () + (interactive) + (delete-minibuffer-contents) + (consult-narrow (car pair)))))))) + +(defun consult-narrow-help () + "Print narrowing help as a `minibuffer-message'. + +This command can be bound to a key in `consult-narrow-map', +to make it available for commands with narrowing." + (declare (completion ignore)) + (interactive) + (consult--require-minibuffer) + (let ((minibuffer-message-timeout 1000000)) + (minibuffer-message + (mapconcat (lambda (x) + (concat + (propertize (key-description (list (car x))) 'face 'consult-key) + " " + (propertize (cdr x) 'face 'consult-help))) + consult--narrow-keys + " ")))) + +(defun consult--narrow-setup (settings map) + "Setup narrowing with SETTINGS and keymap MAP." + (if (memq :keys settings) + (setq consult--narrow-predicate (plist-get settings :predicate) + consult--narrow-keys (plist-get settings :keys)) + (setq consult--narrow-predicate nil + consult--narrow-keys settings)) + (when-let ((key consult-narrow-key)) + (setq key (consult--key-parse key)) + (dolist (pair consult--narrow-keys) + (define-key map (vconcat key (vector (car pair))) + (cons (cdr pair) #'consult-narrow)))) + (when-let ((widen (consult--widen-key))) + (define-key map widen (cons "All" #'consult-narrow))) + (when-let ((init (and (memq :keys settings) (plist-get settings :initial)))) + (consult-narrow init))) + +;;;; Splitting completion style + +(defun consult--split-perl (str &optional _plist) + "Split input STR in async input and filtering part. + +The function returns a list with three elements: The async +string, the start position of the completion filter string and a +force flag. If the first character is a punctuation character it +determines the separator. Examples: \"/async/filter\", +\"#async#filter\"." + (if (string-match-p "^[[:punct:]]" str) + (save-match-data + (let ((q (regexp-quote (substring str 0 1)))) + (string-match (concat "^" q "\\([^" q "]*\\)\\(" q "\\)?") str) + `(,(match-string 1 str) + ,(match-end 0) + ;; Force update it two punctuation characters are entered. + ,(match-end 2) + ;; List of highlights + (0 . ,(match-beginning 1)) + ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))))) + `(,str ,(length str)))) + +(defun consult--split-nil (str &optional _plist) + "Treat the complete input STR as async input." + `(,str ,(length str))) + +(defun consult--split-separator (str plist) + "Split input STR in async input and filtering part at first separator. +PLIST is the splitter configuration, including the separator." + (let ((sep (regexp-quote (char-to-string (plist-get plist :separator))))) + (save-match-data + (if (string-match (format "^\\([^%s]+\\)\\(%s\\)?" sep sep) str) + `(,(match-string 1 str) + ,(match-end 0) + ;; Force update it space is entered. + ,(match-end 2) + ;; List of highlights + ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))) + `(,str ,(length str)))))) + +(defun consult--split-setup (split) + "Setup splitting completion style with splitter function SPLIT." + (let* ((styles completion-styles) + (catdef completion-category-defaults) + (catovr completion-category-overrides) + (try (lambda (str table pred point) + (let ((completion-styles styles) + (completion-category-defaults catdef) + (completion-category-overrides catovr) + (pos (cadr (funcall split str)))) + (pcase (completion-try-completion (substring str pos) table pred + (max 0 (- point pos))) + ('t t) + (`(,newstr . ,newpt) + (cons (concat (substring str 0 pos) newstr) + (+ pos newpt))))))) + (all (lambda (str table pred point) + (let ((completion-styles styles) + (completion-category-defaults catdef) + (completion-category-overrides catovr) + (pos (cadr (funcall split str)))) + (completion-all-completions (substring str pos) table pred + (max 0 (- point pos))))))) + (setq-local completion-styles-alist (cons `(consult--split ,try ,all "") + completion-styles-alist) + completion-styles '(consult--split) + completion-category-defaults nil + completion-category-overrides nil))) + +;;;; Asynchronous filtering functions + +(defun consult--async-p (fun) + "Return t if FUN is an asynchronous completion function." + (and (functionp fun) + (condition-case nil + (progn (funcall fun "" nil 'metadata) nil) + (wrong-number-of-arguments t)))) + +(defmacro consult--with-async (bind &rest body) + "Setup asynchronous completion in BODY. + +BIND is the asynchronous function binding." + (declare (indent 1)) + (let ((async (car bind))) + `(let ((,async ,@(cdr bind)) + (new-chunk (max read-process-output-max consult--process-chunk)) + orig-chunk) + (minibuffer-with-setup-hook + ;; Append such that we overwrite the completion style setting of + ;; `fido-mode'. See `consult--async-split' and + ;; `consult--split-setup'. + (:append + (lambda () + (when (consult--async-p ,async) + (setq orig-chunk read-process-output-max + read-process-output-max new-chunk) + (funcall ,async 'setup) + (let* ((mb (current-buffer)) + (fun (lambda () + (when-let (win (active-minibuffer-window)) + (when (eq (window-buffer win) mb) + (with-current-buffer mb + (let ((inhibit-modification-hooks t)) + ;; Push input string to request refresh. + (funcall ,async (minibuffer-contents-no-properties)))))))) + ;; We use a symbol in order to avoid adding lambdas to + ;; the hook variable. Symbol indirection because of + ;; bug#46407. + (hook (make-symbol "consult--async-after-change-hook"))) + ;; Delay modification hook to ensure that minibuffer is still + ;; alive after the change, such that we don't restart a new + ;; asynchronous search right before exiting the minibuffer. + (fset hook (lambda (&rest _) (run-at-time 0 nil fun))) + (add-hook 'after-change-functions hook nil 'local) + (funcall hook))))) + (let ((,async (if (consult--async-p ,async) ,async (lambda (_) ,async)))) + (unwind-protect + ,(macroexp-progn body) + (funcall ,async 'destroy) + (when (and orig-chunk (eq read-process-output-max new-chunk)) + (setq read-process-output-max orig-chunk)))))))) + +(defun consult--async-sink () + "Create ASYNC sink function. + +An async function must accept a single action argument. For the +\\='setup action it is guaranteed that the call originates from +the minibuffer. For the other actions no assumption about the +context can be made. + +\\='setup Setup the internal closure state. Return nil. +\\='destroy Destroy the internal closure state. Return nil. +\\='flush Flush the list of candidates. Return nil. +\\='refresh Request UI refresh. Return nil. +nil Return the list of candidates. +list Append the list to the already existing candidates list and return it. +string Update with the current user input string. Return nil." + (let (candidates last buffer) + (lambda (action) + (pcase-exhaustive action + ('setup + (setq buffer (current-buffer)) + nil) + ((or (pred stringp) 'destroy) nil) + ('flush (setq candidates nil last nil)) + ('refresh + ;; Refresh the UI when the current minibuffer window belongs + ;; to the current asynchronous completion session. + (when-let (win (active-minibuffer-window)) + (when (eq (window-buffer win) buffer) + (with-selected-window win + (run-hooks 'consult--completion-refresh-hook) + ;; Interaction between asynchronous completion functions and + ;; preview: We have to trigger preview immediately when + ;; candidates arrive (gh:minad/consult#436). + (when (and consult--preview-function candidates) + (funcall consult--preview-function))))) + nil) + ('nil candidates) + ((pred consp) + (setq last (last (if last (setcdr last action) (setq candidates action)))) + candidates))))) + +(defun consult--async-split-style () + "Return the async splitting style function and initial string." + (or (alist-get consult-async-split-style consult-async-split-styles-alist) + (user-error "Splitting style `%s' not found" consult-async-split-style))) + +(defun consult--async-split-initial (initial) + "Return initial string for async command. +INITIAL is the additional initial string." + (concat (plist-get (consult--async-split-style) :initial) initial)) + +(defun consult--async-split-thingatpt (thing) + "Return THING at point with async initial prefix." + (when-let (str (thing-at-point thing)) + (consult--async-split-initial str))) + +(defun consult--async-split (async &optional split) + "Create async function, which splits the input string. +ASYNC is the async sink. +SPLIT is the splitting function." + (unless split + (let* ((style (consult--async-split-style)) + (fn (plist-get style :function))) + (setq split (lambda (str) (funcall fn str style))))) + (lambda (action) + (pcase action + ('setup + (consult--split-setup split) + (funcall async 'setup)) + ((pred stringp) + (pcase-let* ((`(,async-str ,_ ,force . ,highlights) + (funcall split action)) + (async-len (length async-str)) + (input-len (length action)) + (end (minibuffer-prompt-end))) + ;; Highlight punctuation characters + (remove-list-of-text-properties end (+ end input-len) '(face)) + (dolist (hl highlights) + (put-text-property (+ end (car hl)) (+ end (cdr hl)) + 'face 'consult-async-split)) + (funcall async + ;; Pass through if the input is long enough! + (if (or force (>= async-len consult-async-min-input)) + async-str + ;; Pretend that there is no input + "")))) + (_ (funcall async action))))) + +(defun consult--async-indicator (async) + "Create async function with a state indicator overlay. +ASYNC is the async sink." + (let (ov) + (lambda (action &optional state) + (pcase action + ('indicator + (overlay-put ov 'display + (pcase-exhaustive state + ('running #("*" 0 1 (face consult-async-running))) + ('finished #(":" 0 1 (face consult-async-finished))) + ('killed #(";" 0 1 (face consult-async-failed))) + ('failed #("!" 0 1 (face consult-async-failed)))))) + ('setup + (setq ov (make-overlay (- (minibuffer-prompt-end) 2) + (- (minibuffer-prompt-end) 1))) + (funcall async 'setup)) + ('destroy + (delete-overlay ov) + (funcall async 'destroy)) + (_ (funcall async action)))))) + +(defun consult--async-log (formatted &rest args) + "Log FORMATTED ARGS to variable `consult--async-log'." + (with-current-buffer (get-buffer-create consult--async-log) + (goto-char (point-max)) + (insert (apply #'format formatted args)))) + +(defun consult--async-process (async builder &rest props) + "Create process source async function. + +ASYNC is the async function which receives the candidates. +BUILDER is the command line builder function. +PROPS are optional properties passed to `make-process'." + (setq async (consult--async-indicator async)) + (let (proc proc-buf last-args count) + (lambda (action) + (pcase action + ("" ;; If no input is provided kill current process + (when proc + (delete-process proc) + (kill-buffer proc-buf) + (setq proc nil proc-buf nil)) + (setq last-args nil)) + ((pred stringp) + (funcall async action) + (let* ((args (funcall builder action))) + (unless (stringp (car args)) + (setq args (car args))) + (unless (equal args last-args) + (setq last-args args) + (when proc + (delete-process proc) + (kill-buffer proc-buf) + (setq proc nil proc-buf nil)) + (when args + (let* ((flush t) + (rest "") + (proc-filter + (lambda (_ out) + (when flush + (setq flush nil) + (funcall async 'flush)) + (let ((lines (split-string out "[\r\n]+"))) + (if (not (cdr lines)) + (setq rest (concat rest (car lines))) + (setcar lines (concat rest (car lines))) + (let* ((len (length lines)) + (last (nthcdr (- len 2) lines))) + (setq rest (cadr last) + count (+ count len -1)) + (setcdr last nil) + (funcall async lines)))))) + (proc-sentinel + (lambda (_ event) + (when flush + (setq flush nil) + (funcall async 'flush)) + (funcall async 'indicator + (cond + ((string-prefix-p "killed" event) 'killed) + ((string-prefix-p "finished" event) 'finished) + (t 'failed))) + (when (and (string-prefix-p "finished" event) (not (equal rest ""))) + (cl-incf count) + (funcall async (list rest))) + (consult--async-log + "consult--async-process sentinel: event=%s lines=%d\n" + (string-trim event) count) + (when (> (buffer-size proc-buf) 0) + (with-current-buffer (get-buffer-create consult--async-log) + (goto-char (point-max)) + (insert ">>>>> stderr >>>>>\n") + (let ((beg (point))) + (insert-buffer-substring proc-buf) + (save-excursion + (goto-char beg) + (message #("%s" 0 2 (face error)) + (buffer-substring-no-properties (pos-bol) (pos-eol))))) + (insert "<<<<< stderr <<<<<\n"))))) + (process-adaptive-read-buffering nil)) + (funcall async 'indicator 'running) + (consult--async-log "consult--async-process started: args=%S default-directory=%S\n" + args default-directory) + (setq count 0 + proc-buf (generate-new-buffer " *consult-async-stderr*") + proc (apply #'make-process + `(,@props + :connection-type pipe + :name ,(car args) + ;;; XXX tramp bug, the stderr buffer must be empty + :stderr ,proc-buf + :noquery t + :command ,args + :filter ,proc-filter + :sentinel ,proc-sentinel))))))) + nil) + ('destroy + (when proc + (delete-process proc) + (kill-buffer proc-buf) + (setq proc nil proc-buf nil)) + (funcall async 'destroy)) + (_ (funcall async action)))))) + +(defun consult--async-highlight (async builder) + "Return a new ASYNC function with candidate highlighting. +BUILDER is the command line builder function." + (let (highlight) + (lambda (action) + (cond + ((stringp action) + (setq highlight (cdr (funcall builder action))) + (funcall async action)) + ((and (consp action) highlight) + (dolist (str action) + (funcall highlight str)) + (funcall async action)) + (t (funcall async action)))))) + +(defun consult--async-throttle (async &optional throttle debounce) + "Create async function from ASYNC which throttles input. + +The THROTTLE delay defaults to `consult-async-input-throttle'. +The DEBOUNCE delay defaults to `consult-async-input-debounce'." + (setq throttle (or throttle consult-async-input-throttle) + debounce (or debounce consult-async-input-debounce)) + (let* ((input "") (timer (timer-create)) (last 0)) + (lambda (action) + (pcase action + ((pred stringp) + (unless (equal action input) + (cancel-timer timer) + (funcall async "") ;; cancel running process + (setq input action) + (unless (equal action "") + (timer-set-function timer (lambda () + (setq last (float-time)) + (funcall async action))) + (timer-set-time + timer + (timer-relative-time + nil (max debounce (- (+ last throttle) (float-time))))) + (timer-activate timer))) + nil) + ('destroy + (cancel-timer timer) + (funcall async 'destroy)) + (_ (funcall async action)))))) + +(defun consult--async-refresh-immediate (async) + "Create async function from ASYNC, which refreshes the display. + +The refresh happens immediately when candidates are pushed." + (lambda (action) + (pcase action + ((or (pred consp) 'flush) + (prog1 (funcall async action) + (funcall async 'refresh))) + (_ (funcall async action))))) + +(defun consult--async-refresh-timer (async &optional delay) + "Create async function from ASYNC, which refreshes the display. + +The refresh happens after a DELAY, defaulting to `consult-async-refresh-delay'." + (let ((delay (or delay consult-async-refresh-delay)) + (timer (timer-create))) + (timer-set-function timer async '(refresh)) + (lambda (action) + (prog1 (funcall async action) + (pcase action + ((or (pred consp) 'flush) + (unless (memq timer timer-list) + (timer-set-time timer (timer-relative-time nil delay)) + (timer-activate timer))) + ('destroy + (cancel-timer timer))))))) + +(defmacro consult--async-command (builder &rest args) + "Asynchronous command pipeline. +ARGS is a list of `make-process' properties and transforms. +BUILDER is the command line builder function, which takes the +input string and must either return a list of command line +arguments or a pair of the command line argument list and a +highlighting function." + (declare (indent 1)) + `(thread-first + (consult--async-sink) + (consult--async-refresh-timer) + ,@(seq-take-while (lambda (x) (not (keywordp x))) args) + (consult--async-process + ,builder + ,@(seq-drop-while (lambda (x) (not (keywordp x))) args)) + (consult--async-throttle) + (consult--async-split))) + +(defmacro consult--async-transform (async &rest transform) + "Use FUN to TRANSFORM candidates of ASYNC." + (cl-with-gensyms (async-var action-var) + `(let ((,async-var ,async)) + (lambda (,action-var) + (funcall ,async-var (if (consp ,action-var) (,@transform ,action-var) ,action-var)))))) + +(defun consult--async-map (async fun) + "Map candidates of ASYNC by FUN." + (consult--async-transform async mapcar fun)) + +(defun consult--async-filter (async fun) + "Filter candidates of ASYNC by FUN." + (consult--async-transform async seq-filter fun)) + +;;;; Dynamic collections based + +(defun consult--dynamic-compute (async fun &optional debounce) + "Dynamic computation of candidates. +ASYNC is the sink. +FUN computes the candidates given the input. +DEBOUNCE is the time after which an interrupted computation +should be restarted." + (setq debounce (or debounce consult-async-input-debounce)) + (setq async (consult--async-indicator async)) + (let* ((request) (current) (timer) + (cancel (lambda () (when timer (cancel-timer timer) (setq timer nil)))) + (start (lambda (req) (setq request req) (funcall async 'refresh)))) + (lambda (action) + (pcase action + ((and 'nil (guard (not request))) + (funcall async nil)) + ('nil + (funcall cancel) + (let ((state 'killed)) + (unwind-protect + (progn + (funcall async 'indicator 'running) + (redisplay) + ;; Run computation + (let ((response (funcall fun request))) + ;; Flush and update candidate list + (funcall async 'flush) + (setq state 'finished current request) + (funcall async response))) + (funcall async 'indicator state) + ;; If the computation was killed, restart it after some time. + (when (eq state 'killed) + (setq timer (run-at-time debounce nil start request))) + (setq request nil)))) + ((pred stringp) + (funcall cancel) + (if (or (equal action "") (equal action current)) + (funcall async 'indicator 'finished) + (funcall start action))) + ('destroy + (funcall cancel) + (funcall async 'destroy)) + (_ (funcall async action)))))) + +(defun consult--dynamic-collection (fun) + "Dynamic collection with input splitting. +FUN computes the candidates given the input." + (thread-first + (consult--async-sink) + (consult--dynamic-compute fun) + (consult--async-throttle) + (consult--async-split))) + +;;;; Special keymaps + +(defvar-keymap consult-async-map + :doc "Keymap added for commands with asynchronous candidates." + ;; Overwriting some unusable defaults of default minibuffer completion. + "<remap> <minibuffer-complete-word>" #'self-insert-command + ;; Remap Emacs 29 history and default completion for now + ;; (gh:minad/consult#613). + "<remap> <minibuffer-complete-defaults>" #'ignore + "<remap> <minibuffer-complete-history>" #'consult-history) + +(defvar-keymap consult-narrow-map + :doc "Narrowing keymap which is added to the local minibuffer map. +Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically." + "SPC" consult--narrow-space + "DEL" consult--narrow-delete) + +;;;; Internal API: consult--read + +(defun consult--annotate-align (cand ann) + "Align annotation ANN by computing the maximum CAND width." + (setq consult--annotate-align-width + (max consult--annotate-align-width + (* (ceiling (consult--display-width cand) + consult--annotate-align-step) + consult--annotate-align-step))) + (when ann + (concat + #(" " 0 1 (display (space :align-to (+ left consult--annotate-align-width)))) + ann))) + +(defun consult--add-history (async items) + "Add ITEMS to the minibuffer future history. +ASYNC must be non-nil for async completion functions." + (delete-dups + (append + ;; the defaults are at the beginning of the future history + (ensure-list minibuffer-default) + ;; then our custom items + (remove "" (remq nil (ensure-list items))) + ;; Add all the completions for non-async commands. For async commands this + ;; feature is not useful, since if one selects a completion candidate, the + ;; async search is restarted using that candidate string. This usually does + ;; not yield a desired result since the async input uses a special format, + ;; e.g., `#grep#filter'. + (unless async + (all-completions "" + minibuffer-completion-table + minibuffer-completion-predicate))))) + +(defun consult--setup-keymap (keymap async narrow preview-key) + "Setup minibuffer keymap. + +KEYMAP is a command-specific keymap. +ASYNC must be non-nil for async completion functions. +NARROW are the narrow settings. +PREVIEW-KEY are the preview keys." + (let ((old-map (current-local-map)) + (map (make-sparse-keymap))) + + ;; Add narrow keys + (when narrow + (consult--narrow-setup narrow map)) + + ;; Preview trigger keys + (when (and (consp preview-key) (memq :keys preview-key)) + (setq preview-key (plist-get preview-key :keys))) + (setq preview-key (mapcar #'car (consult--preview-key-normalize preview-key))) + (when preview-key + (dolist (key preview-key) + (unless (or (eq key 'any) (lookup-key old-map key)) + (define-key map key #'ignore)))) + + ;; Put the keymap together + (use-local-map + (make-composed-keymap + (delq nil (list keymap + (and async consult-async-map) + (and narrow consult-narrow-map) + map)) + old-map)))) + +(defun consult--tofu-hide-in-minibuffer (&rest _) + "Hide the tofus in the minibuffer." + (let* ((min (minibuffer-prompt-end)) + (max (point-max)) + (pos max)) + (while (and (> pos min) (consult--tofu-p (char-before pos))) + (cl-decf pos)) + (when (< pos max) + (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t))))) + +(defun consult--read-annotate (fun cand) + "Annotate CAND with annotation function FUN." + (pcase (funcall fun cand) + (`(,_ ,_ ,suffix) suffix) + (ann ann))) + +(defun consult--read-affixate (fun cands) + "Affixate CANDS with annotation function FUN." + (mapcar (lambda (cand) + (let ((ann (funcall fun cand))) + (if (consp ann) + ann + (setq ann (or ann "")) + (list cand "" + ;; The default completion UI adds the + ;; `completions-annotations' face if no other faces are + ;; present. + (if (text-property-not-all 0 (length ann) 'face nil ann) + ann + (propertize ann 'face 'completions-annotations)))))) + cands)) + +(cl-defun consult--read-1 (table &key + prompt predicate require-match history default + keymap category initial narrow add-history annotate + state preview-key sort lookup group inherit-input-method) + "See `consult--read' for the documentation of the arguments." + (minibuffer-with-setup-hook + (:append (lambda () + (add-hook 'after-change-functions #'consult--tofu-hide-in-minibuffer nil 'local) + (consult--setup-keymap keymap (consult--async-p table) narrow preview-key) + (setq-local minibuffer-default-add-function + (apply-partially #'consult--add-history (consult--async-p table) add-history)))) + (consult--with-async (async table) + (consult--with-preview + preview-key state + (lambda (narrow input cand) + (funcall lookup cand (funcall async nil) input narrow)) + (apply-partially #'run-hook-with-args-until-success + 'consult--completion-candidate-hook) + (pcase-exhaustive history + (`(:input ,var) var) + ((pred symbolp))) + ;; Do not unnecessarily let-bind the lambdas to avoid over-capturing in + ;; the interpreter. This will make closures and the lambda string + ;; representation larger, which makes debugging much worse. Fortunately + ;; the over-capturing problem does not affect the bytecode interpreter + ;; which does a proper scope analysis. + (let* ((metadata `(metadata + ,@(when category `((category . ,category))) + ,@(when group `((group-function . ,group))) + ,@(when annotate + `((affixation-function + . ,(apply-partially #'consult--read-affixate annotate)) + (annotation-function + . ,(apply-partially #'consult--read-annotate annotate)))) + ,@(unless sort '((cycle-sort-function . identity) + (display-sort-function . identity))))) + (consult--annotate-align-width 0) + (selected + (completing-read + prompt + (lambda (str pred action) + (let ((result (complete-with-action action (funcall async nil) str pred))) + (if (eq action 'metadata) + (if (and (eq (car result) 'metadata) (cdr result)) + ;; Merge metadata + `(metadata ,@(cdr metadata) ,@(cdr result)) + metadata) + result))) + predicate require-match initial + (if (symbolp history) history (cadr history)) + default + inherit-input-method))) + ;; Repair the null completion semantics. `completing-read' may return + ;; an empty string even if REQUIRE-MATCH is non-nil. One can always + ;; opt-in to null completion by passing the empty string for DEFAULT. + (when (and (eq require-match t) (not default) (equal selected "")) + (user-error "No selection")) + selected))))) + +(cl-defun consult--read (table &rest options &key + prompt predicate require-match history default + keymap category initial narrow add-history annotate + state preview-key sort lookup group inherit-input-method) + "Enhanced completing read function to select from TABLE. + +The function is a thin wrapper around `completing-read'. Keyword +arguments are used instead of positional arguments for code +clarity. On top of `completing-read' it additionally supports +computing the candidate list asynchronously, candidate preview +and narrowing. You should use `completing-read' instead of +`consult--read' if you don't use asynchronous candidate +computation or candidate preview. + +Keyword OPTIONS: + +PROMPT is the string which is shown as prompt in the minibuffer. +PREDICATE is a filter function called for each candidate, returns +nil or t. +REQUIRE-MATCH equals t means that an exact match is required. +HISTORY is the symbol of the history variable. +DEFAULT is the default selected value. +ADD-HISTORY is a list of items to add to the history. +CATEGORY is the completion category symbol. +SORT should be set to nil if the candidates are already sorted. +This will disable sorting in the completion UI. +LOOKUP is a lookup function passed the selected candidate string, +the list of candidates, the current input string and the current +narrowing value. +ANNOTATE is a function passed a candidate string. The function +should either return an annotation string or a list of three +strings (candidate prefix postfix). +INITIAL is the initial input string. +STATE is the state function, see `consult--with-preview'. +GROUP is a completion metadata `group-function' as documented in +the Elisp manual. +PREVIEW-KEY are the preview keys. Can be nil, `any', a single +key or a list of keys. +NARROW is an alist of narrowing prefix strings and description. +KEYMAP is a command-specific keymap. +INHERIT-INPUT-METHOD, if non-nil the minibuffer inherits the +input method." + ;; supported types + (cl-assert (or (functionp table) ;; dynamic table or asynchronous function + (obarrayp table) ;; obarray + (hash-table-p table) ;; hash table + (not table) ;; empty list + (stringp (car table)) ;; string list + (and (consp (car table)) (stringp (caar table))) ;; string alist + (and (consp (car table)) (symbolp (caar table))))) ;; symbol alist + (ignore prompt predicate require-match history default + keymap category initial narrow add-history annotate + state preview-key sort lookup group inherit-input-method) + (apply #'consult--read-1 table + (append + (consult--customize-get) + options + (list :prompt "Select: " + :preview-key consult-preview-key + :sort t + :lookup (lambda (selected &rest _) selected))))) + +;;;; Internal API: consult--prompt + +(cl-defun consult--prompt-1 (&key prompt history add-history initial default + keymap state preview-key transform inherit-input-method) + "See `consult--prompt' for documentation." + (minibuffer-with-setup-hook + (:append (lambda () + (consult--setup-keymap keymap nil nil preview-key) + (setq-local minibuffer-default-add-function + (apply-partially #'consult--add-history nil add-history)))) + (consult--with-preview + preview-key state + (lambda (_narrow inp _cand) (funcall transform inp)) + (lambda () "") + history + (read-from-minibuffer prompt initial nil nil history default inherit-input-method)))) + +(cl-defun consult--prompt (&rest options &key prompt history add-history initial default + keymap state preview-key transform inherit-input-method) + "Read from minibuffer. + +Keyword OPTIONS: + +PROMPT is the string to prompt with. +TRANSFORM is a function which is applied to the current input string. +HISTORY is the symbol of the history variable. +INITIAL is initial input. +DEFAULT is the default selected value. +ADD-HISTORY is a list of items to add to the history. +STATE is the state function, see `consult--with-preview'. +PREVIEW-KEY are the preview keys (nil, `any', a single key or a list of keys). +KEYMAP is a command-specific keymap." + (ignore prompt history add-history initial default + keymap state preview-key transform inherit-input-method) + (apply #'consult--prompt-1 + (append + (consult--customize-get) + options + (list :prompt "Input: " + :preview-key consult-preview-key + :transform #'identity)))) + +;;;; Internal API: consult--multi + +(defsubst consult--multi-source (sources cand) + "Lookup source for CAND in SOURCES list." + (aref sources (consult--tofu-get cand))) + +(defun consult--multi-predicate (sources cand) + "Predicate function called for each candidate CAND given SOURCES." + (let* ((src (consult--multi-source sources cand)) + (narrow (plist-get src :narrow)) + (type (or (car-safe narrow) narrow -1))) + (or (eq consult--narrow type) + (not (or consult--narrow (plist-get src :hidden)))))) + +(defun consult--multi-narrow (sources) + "Return narrow list from SOURCES." + (thread-last + sources + (mapcar (lambda (src) + (when-let (narrow (plist-get src :narrow)) + (if (consp narrow) + narrow + (when-let (name (plist-get src :name)) + (cons narrow name)))))) + (delq nil) + (delete-dups))) + +(defun consult--multi-annotate (sources cand) + "Annotate candidate CAND from multi SOURCES." + (consult--annotate-align + cand + (let ((src (consult--multi-source sources cand))) + (if-let ((fun (plist-get src :annotate))) + (funcall fun (cdr (get-text-property 0 'multi-category cand))) + (plist-get src :name))))) + +(defun consult--multi-group (sources cand transform) + "Return title of candidate CAND or TRANSFORM the candidate given SOURCES." + (if transform cand + (plist-get (consult--multi-source sources cand) :name))) + +(defun consult--multi-preview-key (sources) + "Return preview keys from SOURCES." + (list :predicate + (lambda (cand) + (if (plist-member (cdr cand) :preview-key) + (plist-get (cdr cand) :preview-key) + consult-preview-key)) + :keys + (delete-dups + (seq-filter (lambda (k) (or (eq k 'any) (stringp k))) + (seq-mapcat (lambda (src) + (ensure-list + (if (plist-member src :preview-key) + (plist-get src :preview-key) + consult-preview-key))) + sources))))) + +(defun consult--multi-lookup (sources selected candidates _input narrow &rest _) + "Lookup SELECTED in CANDIDATES given SOURCES, with potential NARROW." + (if (or (string-blank-p selected) + (not (consult--tofu-p (aref selected (1- (length selected)))))) + ;; Non-existing candidate without Tofu or default submitted (empty string) + (let* ((src (cond + (narrow (seq-find (lambda (src) + (let ((n (plist-get src :narrow))) + (eq (or (car-safe n) n -1) narrow))) + sources)) + ((seq-find (lambda (src) (plist-get src :default)) sources)) + ((seq-find (lambda (src) (not (plist-get src :hidden))) sources)) + ((aref sources 0)))) + (idx (seq-position sources src)) + (def (and (string-blank-p selected) ;; default candidate + (seq-find (lambda (cand) (eq idx (consult--tofu-get cand))) candidates)))) + (if def + (cons (cdr (get-text-property 0 'multi-category def)) src) + `(,selected :match nil ,@src))) + (if-let (found (member selected candidates)) + ;; Existing candidate submitted + (cons (cdr (get-text-property 0 'multi-category (car found))) + (consult--multi-source sources selected)) + ;; Non-existing Tofu'ed candidate submitted, e.g., via Embark + `(,(substring selected 0 -1) :match nil ,@(consult--multi-source sources selected))))) + +(defun consult--multi-candidates (sources) + "Return `consult--multi' candidates from SOURCES." + (let ((idx 0) candidates) + (seq-doseq (src sources) + (let* ((face (and (plist-member src :face) `(face ,(plist-get src :face)))) + (cat (plist-get src :category)) + (items (plist-get src :items)) + (items (if (functionp items) (funcall items) items))) + (dolist (item items) + (let* ((str (or (car-safe item) item)) + (cand (consult--tofu-append str idx))) + ;; Preserve existing `multi-category' datum of the candidate. + (if (and (eq str item) (get-text-property 0 'multi-category str)) + (when face (add-text-properties 0 (length str) face cand)) + ;; Attach `multi-category' datum and face. + (add-text-properties + 0 (length str) + `(multi-category (,cat . ,(or (cdr-safe item) item)) ,@face) cand)) + (push cand candidates)))) + (cl-incf idx)) + (nreverse candidates))) + +(defun consult--multi-enabled-sources (sources) + "Return vector of enabled SOURCES." + (vconcat + (seq-filter (lambda (src) + (if-let (pred (plist-get src :enabled)) + (funcall pred) + t)) + (mapcar (lambda (src) + (if (symbolp src) (symbol-value src) src)) + sources)))) + +(defun consult--multi-state (sources) + "State function given SOURCES." + (when-let (states (delq nil (mapcar (lambda (src) + (when-let (fun (plist-get src :state)) + (cons src (funcall fun)))) + sources))) + (let (last-fun) + (pcase-lambda (action `(,cand . ,src)) + (pcase action + ('setup + (pcase-dolist (`(,_ . ,fun) states) + (funcall fun 'setup nil))) + ('exit + (pcase-dolist (`(,_ . ,fun) states) + (funcall fun 'exit nil))) + ('preview + (let ((selected-fun (cdr (assq src states)))) + ;; If the candidate source changed during preview communicate to + ;; the last source, that none of its candidates is previewed anymore. + (when (and last-fun (not (eq last-fun selected-fun))) + (funcall last-fun 'preview nil)) + (setq last-fun selected-fun) + (when selected-fun + (funcall selected-fun 'preview cand)))) + ('return + (let ((selected-fun (cdr (assq src states)))) + ;; Finish all the sources, except the selected one. + (pcase-dolist (`(,_ . ,fun) states) + (unless (eq fun selected-fun) + (funcall fun 'return nil))) + ;; Finish the source with the selected candidate + (when selected-fun + (funcall selected-fun 'return cand))))))))) + +(defun consult--multi (sources &rest options) + "Select from candidates taken from a list of SOURCES. + +OPTIONS is the plist of options passed to `consult--read'. The following +options are supported: :require-match, :history, :keymap, :initial, +:add-history, :sort and :inherit-input-method. The other options of +`consult--read' are used by the implementation of `consult--multi' and +should not be overwritten, except in in special scenarios. + +The function returns the selected candidate in the form (cons candidate +source-plist). The plist has the key :match with a value nil if the +candidate does not exist, t if the candidate exists and `new' if the +candidate has been created. The sources of the source list can either be +symbols of source variables or source values. Source values must be +plists with fields from the following list. + +Required source fields: +* :category - Completion category symbol. +* :items - List of strings to select from or function returning + list of strings. Note that the strings can use text properties + to carry metadata, which is then available to the :annotate, + :action and :state functions. + +Optional source fields: +* :name - Name of the source as a string, used for narrowing, + group titles and annotations. +* :narrow - Narrowing character or (character . string) pair. +* :enabled - Function which must return t if the source is enabled. +* :hidden - When t candidates of this source are hidden by default. +* :face - Face used for highlighting the candidates. +* :annotate - Annotation function called for each candidate, returns string. +* :history - Name of history variable to add selected candidate. +* :default - Must be t if the first item of the source is the default value. +* :action - Function called with the selected candidate. +* :new - Function called with new candidate name, only if :require-match is nil. +* :state - State constructor for the source, must return the + state function. The state function is informed about state + changes of the UI and can be used to implement preview. +* Other custom source fields can be added depending on the use + case. Note that the source is returned by `consult--multi' + together with the selected candidate." + (let* ((sources (consult--multi-enabled-sources sources)) + (candidates (consult--with-increased-gc + (consult--multi-candidates sources))) + (selected + (apply #'consult--read + candidates + (append + options + (list + :category 'multi-category + :predicate (apply-partially #'consult--multi-predicate sources) + :annotate (apply-partially #'consult--multi-annotate sources) + :group (apply-partially #'consult--multi-group sources) + :lookup (apply-partially #'consult--multi-lookup sources) + :preview-key (consult--multi-preview-key sources) + :narrow (consult--multi-narrow sources) + :state (consult--multi-state sources)))))) + (when-let (history (plist-get (cdr selected) :history)) + (add-to-history history (car selected))) + (if (plist-member (cdr selected) :match) + (when-let (fun (plist-get (cdr selected) :new)) + (funcall fun (car selected)) + (plist-put (cdr selected) :match 'new)) + (when-let (fun (plist-get (cdr selected) :action)) + (funcall fun (car selected))) + (setq selected `(,(car selected) :match t ,@(cdr selected)))) + selected)) + +;;;; Customization macro + +(defun consult--customize-put (cmds prop form) + "Set property PROP to FORM of commands CMDS." + (dolist (cmd cmds) + (cond + ((and (boundp cmd) (consp (symbol-value cmd))) + (setf (plist-get (symbol-value cmd) prop) (eval form 'lexical))) + ((functionp cmd) + (setf (plist-get (alist-get cmd consult--customize-alist) prop) form)) + (t (user-error "%s is neither a Command command nor a source" cmd)))) + nil) + +(defmacro consult-customize (&rest args) + "Set properties of commands or sources. +ARGS is a list of commands or sources followed by the list of +keyword-value pairs. For `consult-customize' to succeed, the +customized sources and commands must exist. When a command is +invoked, the value of `this-command' is used to lookup the +corresponding customization options." + (let (setter) + (while args + (let ((cmds (seq-take-while (lambda (x) (not (keywordp x))) args))) + (setq args (seq-drop-while (lambda (x) (not (keywordp x))) args)) + (while (keywordp (car args)) + (push `(consult--customize-put ',cmds ,(car args) ',(cadr args)) setter) + (setq args (cddr args))))) + (macroexp-progn setter))) + +(defun consult--customize-get () + "Get configuration from `consult--customize-alist' for `this-command'." + (mapcar (lambda (x) (eval x 'lexical)) + (alist-get this-command consult--customize-alist))) + +;;;; Commands + +;;;;; Command: consult-completion-in-region + +(defun consult--insertion-preview (start end) + "State function for previewing a candidate in a specific region. +The candidates are previewed in the region from START to END. This function is +used as the `:state' argument for `consult--read' in the `consult-yank' family +of functions and in `consult-completion-in-region'." + (unless (or (minibufferp) + ;; Disable preview if anything odd is going on with the markers. + ;; Otherwise we get "Marker points into wrong buffer errors". See + ;; gh:minad/consult#375, where Org mode source blocks are + ;; completed in a different buffer than the original buffer. This + ;; completion is probably also problematic in my Corfu completion + ;; package. + (not (eq (window-buffer) (current-buffer))) + (and (markerp start) (not (eq (marker-buffer start) (current-buffer)))) + (and (markerp end) (not (eq (marker-buffer end) (current-buffer))))) + (let (ov) + (lambda (action cand) + (cond + ((and (not cand) ov) + (delete-overlay ov) + (setq ov nil)) + ((and (eq action 'preview) cand) + (unless ov + (setq ov (consult--make-overlay start end + 'invisible t + 'window (selected-window)))) + ;; Use `add-face-text-property' on a copy of "cand in order to merge face properties + (setq cand (copy-sequence cand)) + (add-face-text-property 0 (length cand) 'consult-preview-insertion t cand) + ;; Use the `before-string' property since the overlay might be empty. + (overlay-put ov 'before-string cand))))))) + +;;;###autoload +(defun consult-completion-in-region (start end collection &optional predicate) + "Use minibuffer completion as the UI for `completion-at-point'. + +The function is called with 4 arguments: START END COLLECTION +PREDICATE. The arguments and expected return value are as +specified for `completion-in-region'. Use this function as a +value for `completion-in-region-function'." + (barf-if-buffer-read-only) + (let* ((initial (buffer-substring-no-properties start end)) + (metadata (completion-metadata initial collection predicate)) + ;; TODO: `minibuffer-completing-file-name' is mostly deprecated, but + ;; still in use. Packages should instead use the completion metadata. + (minibuffer-completing-file-name + (eq 'file (completion-metadata-get metadata 'category))) + (threshold (completion--cycle-threshold metadata)) + (all (completion-all-completions initial collection predicate (length initial))) + ;; Wrap all annotation functions to ensure that they are executed + ;; in the original buffer. + (exit-fun (plist-get completion-extra-properties :exit-function)) + (ann-fun (plist-get completion-extra-properties :annotation-function)) + (aff-fun (plist-get completion-extra-properties :affixation-function)) + (docsig-fun (plist-get completion-extra-properties :company-docsig)) + (completion-extra-properties + `(,@(and ann-fun (list :annotation-function (consult--in-buffer ann-fun))) + ,@(and aff-fun (list :affixation-function (consult--in-buffer aff-fun))) + ;; Provide `:annotation-function' if `:company-docsig' is specified. + ,@(and docsig-fun (not ann-fun) (not aff-fun) + (list :annotation-function + (consult--in-buffer + (lambda (cand) + (concat (propertize " " 'display '(space :align-to center)) + (funcall docsig-fun cand))))))))) + ;; error if `threshold' is t or the improper list `all' is too short + (if (and threshold + (or (not (consp (ignore-errors (nthcdr threshold all)))) + (and completion-cycling completion-all-sorted-completions))) + (completion--in-region start end collection predicate) + (let* ((limit (car (completion-boundaries initial collection predicate ""))) + (this-command #'consult-completion-in-region) + (completion + (cond + ((atom all) nil) + ((and (consp all) (atom (cdr all))) + (concat (substring initial 0 limit) (car all))) + (t + (consult--local-let ((enable-recursive-minibuffers t)) + ;; Evaluate completion table in the original buffer. + ;; This is a reasonable thing to do and required by + ;; some completion tables in particular by lsp-mode. + ;; See gh:minad/vertico#61. + (consult--read (consult--completion-table-in-buffer collection) + :prompt "Completion: " + :state (consult--insertion-preview start end) + :predicate predicate + :initial initial)))))) + (if completion + (progn + ;; bug#55205: completion--replace removes properties! + (completion--replace start end (setq completion (concat completion))) + (when exit-fun + (funcall exit-fun completion + ;; If completion is finished and cannot be further + ;; completed, return `finished'. Otherwise return + ;; `exact'. + (if (eq (try-completion completion collection predicate) t) + 'finished 'exact))) + t) + (message "No completion") + nil))))) + +;;;;; Command: consult-outline + +(defun consult--outline-candidates () + "Return alist of outline headings and positions." + (consult--forbid-minibuffer) + (let* ((line (line-number-at-pos (point-min) consult-line-numbers-widen)) + (heading-regexp (concat "^\\(?:" + ;; default definition from outline.el + (or (bound-and-true-p outline-regexp) "[*\^L]+") + "\\)")) + (heading-alist (bound-and-true-p outline-heading-alist)) + (level-fun (or (bound-and-true-p outline-level) + (lambda () ;; as in the default from outline.el + (or (cdr (assoc (match-string 0) heading-alist)) + (- (match-end 0) (match-beginning 0)))))) + (buffer (current-buffer)) + candidates) + (save-excursion + (goto-char (point-min)) + (while (save-excursion + (if-let (fun (bound-and-true-p outline-search-function)) + (funcall fun) + (re-search-forward heading-regexp nil t))) + (cl-incf line (consult--count-lines (match-beginning 0))) + (push (consult--location-candidate + (consult--buffer-substring (pos-bol) (pos-eol) 'fontify) + (cons buffer (point)) (1- line) (1- line) + 'consult--outline-level (funcall level-fun)) + candidates) + (goto-char (1+ (pos-eol))))) + (unless candidates + (user-error "No headings")) + (nreverse candidates))) + +;;;###autoload +(defun consult-outline (&optional level) + "Jump to an outline heading, obtained by matching against `outline-regexp'. + +This command supports narrowing to a heading level and candidate +preview. The initial narrowing LEVEL can be given as prefix +argument. The symbol at point is added to the future history." + (interactive + (list (and current-prefix-arg (prefix-numeric-value current-prefix-arg)))) + (let* ((candidates (consult--slow-operation + "Collecting headings..." + (consult--outline-candidates))) + (min-level (- (cl-loop for cand in candidates minimize + (get-text-property 0 'consult--outline-level cand)) + ?1)) + (narrow-pred (lambda (cand) + (<= (get-text-property 0 'consult--outline-level cand) + (+ consult--narrow min-level)))) + (narrow-keys (mapcar (lambda (c) (cons c (format "Level %c" c))) + (number-sequence ?1 ?9))) + (narrow-init (and level (max ?1 (min ?9 (+ level ?0)))))) + (consult--read + candidates + :prompt "Go to heading: " + :annotate (consult--line-prefix) + :category 'consult-location + :sort nil + :require-match t + :lookup #'consult--line-match + :narrow `(:predicate ,narrow-pred :keys ,narrow-keys :initial ,narrow-init) + :history '(:input consult--line-history) + :add-history (thing-at-point 'symbol) + :state (consult--location-state candidates)))) + +;;;;; Command: consult-mark + +(defun consult--mark-candidates (markers) + "Return list of candidates strings for MARKERS." + (consult--forbid-minibuffer) + (let ((candidates) + (current-buf (current-buffer))) + (save-excursion + (dolist (marker markers) + (when-let ((pos (marker-position marker)) + (buf (marker-buffer marker))) + (when (and (eq buf current-buf) + (consult--in-range-p pos)) + (goto-char pos) + ;; `line-number-at-pos' is a very slow function, which should be + ;; replaced everywhere. However in this case the slow + ;; line-number-at-pos does not hurt much, since the mark ring is + ;; usually small since it is limited by `mark-ring-max'. + (push (consult--location-candidate + (consult--line-with-mark marker) marker + (line-number-at-pos pos consult-line-numbers-widen) + marker) + candidates))))) + (unless candidates + (user-error "No marks")) + (nreverse (delete-dups candidates)))) + +;;;###autoload +(defun consult-mark (&optional markers) + "Jump to a marker in MARKERS list (defaults to buffer-local `mark-ring'). + +The command supports preview of the currently selected marker position. +The symbol at point is added to the future history." + (interactive) + (consult--read + (consult--mark-candidates + (or markers (cons (mark-marker) mark-ring))) + :prompt "Go to mark: " + :annotate (consult--line-prefix) + :category 'consult-location + :sort nil + :require-match t + :lookup #'consult--lookup-location + :history '(:input consult--line-history) + :add-history (thing-at-point 'symbol) + :state (consult--jump-state))) + +;;;;; Command: consult-global-mark + +(defun consult--global-mark-candidates (markers) + "Return list of candidates strings for MARKERS." + (consult--forbid-minibuffer) + (let ((candidates)) + (save-excursion + (dolist (marker markers) + (when-let ((pos (marker-position marker)) + (buf (marker-buffer marker))) + (unless (minibufferp buf) + (with-current-buffer buf + (when (consult--in-range-p pos) + (goto-char pos) + ;; `line-number-at-pos' is slow, see comment in `consult--mark-candidates'. + (let* ((line (line-number-at-pos pos consult-line-numbers-widen)) + (prefix (consult--format-file-line-match (buffer-name buf) line "")) + (cand (concat prefix (consult--line-with-mark marker) (consult--tofu-encode marker)))) + (put-text-property 0 (length prefix) 'consult-strip t cand) + (put-text-property 0 (length cand) 'consult-location (cons marker line) cand) + (push cand candidates)))))))) + (unless candidates + (user-error "No global marks")) + (nreverse (delete-dups candidates)))) + +;;;###autoload +(defun consult-global-mark (&optional markers) + "Jump to a marker in MARKERS list (defaults to `global-mark-ring'). + +The command supports preview of the currently selected marker position. +The symbol at point is added to the future history." + (interactive) + (consult--read + (consult--global-mark-candidates + (or markers global-mark-ring)) + :prompt "Go to global mark: " + ;; Despite `consult-global-mark' formatting the candidates in grep-like + ;; style, we are not using the `consult-grep' category, since the candidates + ;; have location markers attached. + :category 'consult-location + :sort nil + :require-match t + :lookup #'consult--lookup-location + :history '(:input consult--line-history) + :add-history (thing-at-point 'symbol) + :state (consult--jump-state))) + +;;;;; Command: consult-line + +(defun consult--line-candidates (top curr-line) + "Return list of line candidates. +Start from top if TOP non-nil. +CURR-LINE is the current line number." + (consult--forbid-minibuffer) + (consult--fontify-all) + (let* ((buffer (current-buffer)) + (line (line-number-at-pos (point-min) consult-line-numbers-widen)) + default-cand candidates) + (consult--each-line beg end + (unless (looking-at-p "^\\s-*$") + (push (consult--location-candidate + (consult--buffer-substring beg end) + (cons buffer beg) line line) + candidates) + (when (and (not default-cand) (>= line curr-line)) + (setq default-cand candidates))) + (cl-incf line)) + (unless candidates + (user-error "No lines")) + (nreverse + (if (or top (not default-cand)) + candidates + (let ((before (cdr default-cand))) + (setcdr default-cand nil) + (nconc before candidates)))))) + +(defun consult--line-point-placement (selected candidates highlighted &rest ignored-faces) + "Find point position on matching line. +SELECTED is the currently selected candidate. +CANDIDATES is the list of candidates. +HIGHLIGHTED is the highlighted string to determine the match position. +IGNORED-FACES are ignored when determining the match position." + (when-let (pos (consult--lookup-location selected candidates)) + (if highlighted + (let* ((matches (apply #'consult--point-placement highlighted 0 ignored-faces)) + (dest (+ pos (car matches)))) + ;; Only create a new marker when jumping across buffers (for example + ;; `consult-line-multi'). Avoid creating unnecessary markers, when + ;; scrolling through candidates, since creating markers is not free. + (when (and (markerp pos) (not (eq (marker-buffer pos) (current-buffer)))) + (setq dest (move-marker (make-marker) dest (marker-buffer pos)))) + (cons dest (cdr matches))) + pos))) + +(defun consult--line-match (selected candidates input &rest _) + "Lookup position of match. +SELECTED is the currently selected candidate. +CANDIDATES is the list of candidates. +INPUT is the input string entered by the user." + (consult--line-point-placement selected candidates + (and (not (string-blank-p input)) + (car (consult--completion-filter + input + (list (substring-no-properties selected)) + 'consult-location 'highlight))) + 'completions-first-difference)) + +;;;###autoload +(defun consult-line (&optional initial start) + "Search for a matching line. + +Depending on the setting `consult-point-placement' the command +jumps to the beginning or the end of the first match on the line +or the line beginning. The default candidate is the non-empty +line next to point. This command obeys narrowing. Optional +INITIAL input can be provided. The search starting point is +changed if the START prefix argument is set. The symbol at point +and the last `isearch-string' is added to the future history." + (interactive (list nil (not (not current-prefix-arg)))) + (let* ((curr-line (line-number-at-pos (point) consult-line-numbers-widen)) + (top (not (eq start consult-line-start-from-top))) + (candidates (consult--slow-operation "Collecting lines..." + (consult--line-candidates top curr-line)))) + (consult--read + candidates + :prompt (if top "Go to line from top: " "Go to line: ") + :annotate (consult--line-prefix curr-line) + :category 'consult-location + :sort nil + :require-match t + ;; Always add last `isearch-string' to future history + :add-history (list (thing-at-point 'symbol) isearch-string) + :history '(:input consult--line-history) + :lookup #'consult--line-match + :default (car candidates) + ;; Add `isearch-string' as initial input if starting from Isearch + :initial (or initial + (and isearch-mode + (prog1 isearch-string (isearch-done)))) + :state (consult--location-state candidates)))) + +;;;;; Command: consult-line-multi + +(defun consult--line-multi-match (selected candidates &rest _) + "Lookup position of match. +SELECTED is the currently selected candidate. +CANDIDATES is the list of candidates." + (consult--line-point-placement selected candidates + (car (member selected candidates)))) + +(defun consult--line-multi-group (cand transform) + "Group function used by `consult-line-multi'. +If TRANSFORM non-nil, return transformed CAND, otherwise return title." + (if transform cand + (let* ((marker (car (get-text-property 0 'consult-location cand))) + (buf (if (consp marker) + (car marker) ;; Handle cheap marker + (marker-buffer marker)))) + (if buf (buffer-name buf) "Dead buffer")))) + +(defun consult--line-multi-candidates (buffers input) + "Collect matching candidates from multiple buffers. +INPUT is the user input which should be matched. +BUFFERS is the list of buffers." + (pcase-let ((`(,regexps . ,hl) + (funcall consult--regexp-compiler + input 'emacs completion-ignore-case)) + (candidates nil) + (cand-idx 0)) + (save-match-data + (dolist (buf buffers (nreverse candidates)) + (with-current-buffer buf + (save-excursion + (let ((line (line-number-at-pos (point-min) consult-line-numbers-widen))) + (goto-char (point-min)) + (while (and (not (eobp)) + (save-excursion (re-search-forward (car regexps) nil t))) + (cl-incf line (consult--count-lines (match-beginning 0))) + (let ((bol (pos-bol)) + (eol (pos-eol))) + (goto-char bol) + (when (and (not (looking-at-p "^\\s-*$")) + (seq-every-p (lambda (r) + (goto-char bol) + (re-search-forward r eol t)) + (cdr regexps))) + (push (consult--location-candidate + (funcall hl (buffer-substring-no-properties bol eol)) + (cons buf bol) (1- line) cand-idx) + candidates) + (cl-incf cand-idx)) + (goto-char (1+ eol))))))))))) + +;;;###autoload +(defun consult-line-multi (query &optional initial) + "Search for a matching line in multiple buffers. + +By default search across all project buffers. If the prefix +argument QUERY is non-nil, all buffers are searched. Optional +INITIAL input can be provided. The symbol at point and the last +`isearch-string' is added to the future history. In order to +search a subset of buffers, QUERY can be set to a plist according +to `consult--buffer-query'." + (interactive "P") + (unless (keywordp (car-safe query)) + (setq query (list :sort 'alpha-current :directory (and (not query) 'project)))) + (pcase-let* ((`(,prompt . ,buffers) (consult--buffer-query-prompt "Go to line" query)) + (collection (consult--dynamic-collection + (apply-partially #'consult--line-multi-candidates + buffers)))) + (consult--read + collection + :prompt prompt + :annotate (consult--line-prefix) + :category 'consult-location + :sort nil + :require-match t + ;; Always add last Isearch string to future history + :add-history (mapcar #'consult--async-split-initial + (delq nil (list (thing-at-point 'symbol) + isearch-string))) + :history '(:input consult--line-multi-history) + :lookup #'consult--line-multi-match + ;; Add `isearch-string' as initial input if starting from Isearch + :initial (consult--async-split-initial + (or initial + (and isearch-mode + (prog1 isearch-string (isearch-done))))) + :state (consult--location-state (lambda () (funcall collection nil))) + :group #'consult--line-multi-group))) + +;;;;; Command: consult-keep-lines + +(defun consult--keep-lines-state (filter) + "State function for `consult-keep-lines' with FILTER function." + (let ((font-lock-orig font-lock-mode) + (whitespace-orig (bound-and-true-p whitespace-mode)) + (hl-line-orig (bound-and-true-p hl-line-mode)) + (point-orig (point)) + lines content-orig replace last-input) + (if (use-region-p) + (save-restriction + ;; Use the same behavior as `keep-lines'. + (let ((rbeg (region-beginning)) + (rend (save-excursion + (goto-char (region-end)) + (unless (or (bolp) (eobp)) + (forward-line 0)) + (point)))) + (consult--fontify-region rbeg rend) + (narrow-to-region rbeg rend) + (consult--each-line beg end + (push (consult--buffer-substring beg end) lines)) + (setq content-orig (buffer-string) + replace (lambda (content &optional pos) + (delete-region rbeg rend) + (insert-before-markers content) + (goto-char (or pos rbeg)) + (setq rend (+ rbeg (length content))) + (add-face-text-property rbeg rend 'region t))))) + (consult--fontify-all) + (setq content-orig (buffer-string) + replace (lambda (content &optional pos) + (delete-region (point-min) (point-max)) + (insert content) + (goto-char (or pos (point-min))))) + (consult--each-line beg end + (push (consult--buffer-substring beg end) lines))) + (setq lines (nreverse lines)) + (lambda (action input) + ;; Restoring content and point position + (when (and (eq action 'return) last-input) + ;; No undo recording, modification hooks, buffer modified-status + (with-silent-modifications (funcall replace content-orig point-orig))) + ;; Committing or new input provided -> Update + (when (and input ;; Input has been provided + (or + ;; Committing, but not with empty input + (and (eq action 'return) (not (string-match-p "\\`!? ?\\'" input))) + ;; Input has changed + (not (equal input last-input)))) + (let ((filtered-content + (if (string-match-p "\\`!? ?\\'" input) + ;; Special case the empty input for performance. + ;; Otherwise it could happen that the minibuffer is empty, + ;; but the buffer has not been updated. + content-orig + (if (eq action 'return) + (apply #'concat (mapcan (lambda (x) (list x "\n")) + (funcall filter input lines))) + (while-no-input + ;; Heavy computation is interruptible if *not* committing! + ;; Allocate new string candidates since the matching function mutates! + (apply #'concat (mapcan (lambda (x) (list x "\n")) + (funcall filter input (mapcar #'copy-sequence lines))))))))) + (when (stringp filtered-content) + (when font-lock-mode (font-lock-mode -1)) + (when (bound-and-true-p whitespace-mode) (whitespace-mode -1)) + (when (bound-and-true-p hl-line-mode) (hl-line-mode -1)) + (if (eq action 'return) + (atomic-change-group + ;; Disable modification hooks for performance + (let ((inhibit-modification-hooks t)) + (funcall replace filtered-content))) + ;; No undo recording, modification hooks, buffer modified-status + (with-silent-modifications + (funcall replace filtered-content) + (setq last-input input)))))) + ;; Restore modes + (when (eq action 'return) + (when hl-line-orig (hl-line-mode 1)) + (when whitespace-orig (whitespace-mode 1)) + (when font-lock-orig (font-lock-mode 1)))))) + +;;;###autoload +(defun consult-keep-lines (filter &optional initial) + "Select a subset of the lines in the current buffer with live preview. + +The selected lines are kept and the other lines are deleted. When called +interactively, the lines selected are those that match the minibuffer input. In +order to match the inverse of the input, prefix the input with `! '. When +called from Elisp, the filtering is performed by a FILTER function. This +command obeys narrowing. + +FILTER is the filter function. +INITIAL is the initial input." + (interactive + (list (lambda (pattern cands) + ;; Use consult-location completion category when filtering lines + (consult--completion-filter-dispatch + pattern cands 'consult-location 'highlight)))) + (consult--forbid-minibuffer) + (let ((ro buffer-read-only)) + (unwind-protect + (minibuffer-with-setup-hook + (lambda () + (when ro + (minibuffer-message + (substitute-command-keys + " [Unlocked read-only buffer. \\[minibuffer-keyboard-quit] to quit.]")))) + (setq buffer-read-only nil) + (consult--with-increased-gc + (consult--prompt + :prompt "Keep lines: " + :initial initial + :history 'consult--line-history + :state (consult--keep-lines-state filter)))) + (setq buffer-read-only ro)))) + +;;;;; Command: consult-focus-lines + +(defun consult--focus-lines-state (filter) + "State function for `consult-focus-lines' with FILTER function." + (let (lines overlays last-input pt-orig pt-min pt-max) + (save-excursion + (save-restriction + (if (not (use-region-p)) + (consult--fontify-all) + (consult--fontify-region (region-beginning) (region-end)) + (narrow-to-region + (region-beginning) + ;; Behave the same as `keep-lines'. + ;; Move to the next line. + (save-excursion + (goto-char (region-end)) + (unless (or (bolp) (eobp)) + (forward-line 0)) + (point)))) + (setq pt-orig (point) pt-min (point-min) pt-max (point-max)) + (let ((i 0)) + (consult--each-line beg end + ;; Use "\n" for empty lines, since we need a non-empty string to + ;; attach the text property to. + (let ((line (if (eq beg end) (char-to-string ?\n) + (buffer-substring-no-properties beg end)))) + (put-text-property 0 1 'consult--focus-line (cons (cl-incf i) beg) line) + (push line lines))) + (setq lines (nreverse lines))))) + (lambda (action input) + ;; New input provided -> Update + (when (and input (not (equal input last-input))) + (let (new-overlays) + (pcase (while-no-input + (unless (string-match-p "\\`!? ?\\'" input) ;; Empty input. + (let* ((inhibit-quit (eq action 'return)) ;; Non interruptible, when quitting! + (not (string-prefix-p "! " input)) + (stripped (string-remove-prefix "! " input)) + (matches (funcall filter stripped lines)) + (old-ind 0) + (block-beg pt-min) + (block-end pt-min)) + (while old-ind + (let ((match (pop matches)) (ind nil) (beg pt-max) (end pt-max) prop) + (when match + (setq prop (get-text-property 0 'consult--focus-line match) + ind (car prop) + beg (cdr prop) + ;; Check for empty lines, see above. + end (+ 1 beg (if (equal match "\n") 0 (length match))))) + (unless (eq ind (1+ old-ind)) + (let ((a (if not block-beg block-end)) + (b (if not block-end beg))) + (when (/= a b) + (push (consult--make-overlay a b 'invisible t) new-overlays))) + (setq block-beg beg)) + (setq block-end end old-ind ind))))) + 'commit) + ('commit + (mapc #'delete-overlay overlays) + (setq last-input input overlays new-overlays)) + (_ (mapc #'delete-overlay new-overlays))))) + (when (eq action 'return) + (cond + ((not input) + (mapc #'delete-overlay overlays) + (goto-char pt-orig)) + ((equal input "") + (consult-focus-lines nil 'show) + (goto-char pt-orig)) + (t + ;; Successfully terminated -> Remember invisible overlays + (setq consult--focus-lines-overlays + (nconc consult--focus-lines-overlays overlays)) + ;; move point past invisible + (goto-char (if-let (ov (and (invisible-p pt-orig) + (seq-find (lambda (ov) (overlay-get ov 'invisible)) + (overlays-at pt-orig)))) + (overlay-end ov) + pt-orig)))))))) + +;;;###autoload +(defun consult-focus-lines (filter &optional show initial) + "Hide or show lines using overlays. + +The selected lines are shown and the other lines hidden. When called +interactively, the lines selected are those that match the minibuffer input. In +order to match the inverse of the input, prefix the input with `! '. With +optional prefix argument SHOW reveal the hidden lines. Alternatively the +command can be restarted to reveal the lines. When called from Elisp, the +filtering is performed by a FILTER function. This command obeys narrowing. + +FILTER is the filter function. +INITIAL is the initial input." + (interactive + (list (lambda (pattern cands) + ;; Use consult-location completion category when filtering lines + (consult--completion-filter-dispatch + pattern cands 'consult-location nil)) + current-prefix-arg)) + (if show + (progn + (mapc #'delete-overlay consult--focus-lines-overlays) + (setq consult--focus-lines-overlays nil) + (message "All lines revealed")) + (consult--forbid-minibuffer) + (consult--with-increased-gc + (consult--prompt + :prompt + (if consult--focus-lines-overlays + "Focus on lines (RET to reveal): " + "Focus on lines: ") + :initial initial + :history 'consult--line-history + :state (consult--focus-lines-state filter))))) + +;;;;; Command: consult-goto-line + +(defun consult--goto-line-position (str msg) + "Transform input STR to line number. +Print an error message with MSG function." + (save-match-data + (if (and str (string-match "\\`\\([[:digit:]]+\\):?\\([[:digit:]]*\\)\\'" str)) + (let ((line (string-to-number (match-string 1 str))) + (col (string-to-number (match-string 2 str)))) + (save-excursion + (save-restriction + (when consult-line-numbers-widen + (widen)) + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (min (+ (point) col) (pos-eol))) + (point)))) + (when (and str (not (equal str ""))) + (funcall msg "Please enter a number.")) + nil))) + +;;;###autoload +(defun consult-goto-line (&optional arg) + "Read line number and jump to the line with preview. + +Enter either a line number to jump to the first column of the +given line or line:column in order to jump to a specific column. +Jump directly if a line number is given as prefix ARG. The +command respects narrowing and the settings +`consult-goto-line-numbers' and `consult-line-numbers-widen'." + (interactive "P") + (if arg + (call-interactively #'goto-line) + (consult--forbid-minibuffer) + (consult--local-let ((display-line-numbers consult-goto-line-numbers) + (display-line-numbers-widen consult-line-numbers-widen)) + (while (if-let (pos (consult--goto-line-position + (consult--prompt + :prompt "Go to line: " + :history 'goto-line-history + :state + (let ((preview (consult--jump-preview))) + (lambda (action str) + (funcall preview action + (consult--goto-line-position str #'ignore))))) + #'minibuffer-message)) + (consult--jump pos) + t))))) + +;;;;; Command: consult-recent-file + +(defun consult--file-preview () + "Create preview function for files." + (let ((open (consult--temporary-files)) + (preview (consult--buffer-preview))) + (lambda (action cand) + (unless cand + (funcall open)) + (funcall preview action + (and cand + (eq action 'preview) + (funcall open cand)))))) + +(defun consult--file-action (file) + "Open FILE via `consult--buffer-action'." + ;; Try to preserve the buffer as is, if it has already been opened, for + ;; example in literal or raw mode. + (setq file (abbreviate-file-name (expand-file-name file))) + (consult--buffer-action (or (get-file-buffer file) (find-file-noselect file)))) + +(consult--define-state file) + +;;;###autoload +(defun consult-recent-file () + "Find recent file using `completing-read'." + (interactive) + (find-file + (consult--read + (or + (mapcar #'consult--fast-abbreviate-file-name (bound-and-true-p recentf-list)) + (user-error "No recent files, `recentf-mode' is %s" + (if recentf-mode "enabled" "disabled"))) + :prompt "Find recent file: " + :sort nil + :require-match t + :category 'file + :state (consult--file-preview) + :history 'file-name-history))) + +;;;;; Command: consult-mode-command + +(defun consult--mode-name (mode) + "Return name part of MODE." + (replace-regexp-in-string + "global-\\(.*\\)-mode" "\\1" + (replace-regexp-in-string + "\\(-global\\)?-mode\\'" "" + (if (eq mode 'c-mode) + "cc" + (symbol-name mode)) + 'fixedcase) + 'fixedcase)) + +(defun consult--mode-command-candidates (modes) + "Extract commands from MODES. + +The list of features is searched for files belonging to the modes. +From these files, the commands are extracted." + (let* ((case-fold-search) + (buffer (current-buffer)) + (command-filter (consult--regexp-filter (seq-filter #'stringp consult-mode-command-filter))) + (feature-filter (seq-filter #'symbolp consult-mode-command-filter)) + (minor-hash (consult--string-hash minor-mode-list)) + (minor-local-modes (seq-filter (lambda (m) + (and (gethash m minor-hash) + (local-variable-if-set-p m))) + modes)) + (minor-global-modes (seq-filter (lambda (m) + (and (gethash m minor-hash) + (not (local-variable-if-set-p m)))) + modes)) + (major-modes (seq-remove (lambda (m) + (gethash m minor-hash)) + modes)) + (major-paths-hash (consult--string-hash (mapcar #'symbol-file major-modes))) + (minor-local-paths-hash (consult--string-hash (mapcar #'symbol-file minor-local-modes))) + (minor-global-paths-hash (consult--string-hash (mapcar #'symbol-file minor-global-modes))) + (major-name-regexp (regexp-opt (mapcar #'consult--mode-name major-modes))) + (minor-local-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-local-modes))) + (minor-global-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-global-modes))) + (commands)) + (dolist (feature load-history commands) + (when-let (name (alist-get 'provide feature)) + (let* ((path (car feature)) + (file (file-name-nondirectory path)) + (key (cond + ((memq name feature-filter) nil) + ((or (gethash path major-paths-hash) + (string-match-p major-name-regexp file)) + ?m) + ((or (gethash path minor-local-paths-hash) + (string-match-p minor-local-name-regexp file)) + ?l) + ((or (gethash path minor-global-paths-hash) + (string-match-p minor-global-name-regexp file)) + ?g)))) + (when key + (dolist (cmd (cdr feature)) + (let ((sym (cdr-safe cmd))) + (when (and (consp cmd) + (eq (car cmd) 'defun) + (commandp sym) + (not (get sym 'byte-obsolete-info)) + (or (not read-extended-command-predicate) + (funcall read-extended-command-predicate sym buffer))) + (let ((name (symbol-name sym))) + (unless (string-match-p command-filter name) + (push (propertize name + 'consult--candidate sym + 'consult--type key) + commands)))))))))))) + +;;;###autoload +(defun consult-mode-command (&rest modes) + "Run a command from any of the given MODES. + +If no MODES are specified, use currently active major and minor modes." + (interactive) + (unless modes + (setq modes (cons major-mode + (seq-filter (lambda (m) + (and (boundp m) (symbol-value m))) + minor-mode-list)))) + (let ((narrow `((?m . ,(format "Major: %s" major-mode)) + (?l . "Local Minor") + (?g . "Global Minor")))) + (command-execute + (consult--read + (consult--mode-command-candidates modes) + :prompt "Mode command: " + :predicate + (lambda (cand) + (let ((key (get-text-property 0 'consult--type cand))) + (if consult--narrow + (= key consult--narrow) + (/= key ?g)))) + :lookup #'consult--lookup-candidate + :group (consult--type-group narrow) + :narrow narrow + :require-match t + :history 'extended-command-history + :category 'command)))) + +;;;;; Command: consult-yank + +(defun consult--read-from-kill-ring () + "Open kill ring menu and return selected string." + ;; `current-kill' updates `kill-ring' with interprogram paste, see + ;; gh:minad/consult#443. + (current-kill 0) + ;; Do not specify a :lookup function in order to preserve completion-styles + ;; highlighting of the current candidate. We have to perform a final lookup to + ;; obtain the original candidate which may be propertized with yank-specific + ;; properties, like 'yank-handler. + (consult--lookup-member + (consult--read + (consult--remove-dups + (or (if yank-from-kill-ring-rotate + (append kill-ring-yank-pointer + (butlast kill-ring (length kill-ring-yank-pointer))) + kill-ring) + (user-error "Kill ring is empty"))) + :prompt "Yank from kill-ring: " + :history t ;; disable history + :sort nil + :category 'kill-ring + :require-match t + :state + (consult--insertion-preview + (point) + ;; If previous command is yank, hide previously yanked string + (or (and (eq last-command 'yank) (mark t)) (point)))) + kill-ring)) + +;; Adapted from the Emacs `yank-from-kill-ring' function. +;;;###autoload +(defun consult-yank-from-kill-ring (string &optional arg) + "Select STRING from the kill ring and insert it. +With prefix ARG, put point at beginning, and mark at end, like `yank' does. + +This command behaves like `yank-from-kill-ring', which also offers a +`completing-read' interface to the `kill-ring'. Additionally the +Consult version supports preview of the selected string." + (interactive (list (consult--read-from-kill-ring) current-prefix-arg)) + (when string + (setq yank-window-start (window-start)) + (push-mark) + (insert-for-yank string) + (setq this-command 'yank) + (when yank-from-kill-ring-rotate + (if-let (pos (seq-position kill-ring string)) + (setq kill-ring-yank-pointer (nthcdr pos kill-ring)) + (kill-new string))) + (when (consp arg) + ;; Swap point and mark like in `yank'. + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) (current-buffer))))))) + +(put 'consult-yank-replace 'delete-selection 'yank) +(put 'consult-yank-pop 'delete-selection 'yank) +(put 'consult-yank-from-kill-ring 'delete-selection 'yank) + +;;;###autoload +(defun consult-yank-pop (&optional arg) + "If there is a recent yank act like `yank-pop'. + +Otherwise select string from the kill ring and insert it. +See `yank-pop' for the meaning of ARG. + +This command behaves like `yank-pop', which also offers a +`completing-read' interface to the `kill-ring'. Additionally the +Consult version supports preview of the selected string." + (interactive "*p") + (if (eq last-command 'yank) + (yank-pop (or arg 1)) + (call-interactively #'consult-yank-from-kill-ring))) + +;; Adapted from the Emacs yank-pop function. +;;;###autoload +(defun consult-yank-replace (string) + "Select STRING from the kill ring. + +If there was no recent yank, insert the string. +Otherwise replace the just-yanked string with the selected string." + (interactive (list (consult--read-from-kill-ring))) + (when string + (if (not (eq last-command 'yank)) + (consult-yank-from-kill-ring string) + (let ((inhibit-read-only t) + (pt (point)) + (mk (mark t))) + (setq this-command 'yank) + (funcall (or yank-undo-function 'delete-region) (min pt mk) (max pt mk)) + (setq yank-undo-function nil) + (set-marker (mark-marker) pt (current-buffer)) + (insert-for-yank string) + (set-window-start (selected-window) yank-window-start t) + (if (< pt mk) + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) (current-buffer))))))))) + +;;;;; Command: consult-bookmark + +(defun consult--bookmark-preview () + "Create preview function for bookmarks." + (let ((preview (consult--jump-preview)) + (open (consult--temporary-files))) + (lambda (action cand) + (unless cand + (funcall open)) + (funcall + preview action + ;; Only preview bookmarks with the default handler. + (when-let ((bm (and cand (eq action 'preview) (assoc cand bookmark-alist))) + (handler (or (bookmark-get-handler bm) #'bookmark-default-handler)) + ((eq handler #'bookmark-default-handler)) + (file (bookmark-get-filename bm)) + (pos (bookmark-get-position bm)) + (buf (funcall open file))) + (set-marker (make-marker) pos buf)))))) + +(defun consult--bookmark-action (bm) + "Open BM via `consult--buffer-action'." + (bookmark-jump bm consult--buffer-display)) + +(consult--define-state bookmark) + +(defun consult--bookmark-candidates () + "Return bookmark candidates." + (bookmark-maybe-load-default-file) + (let ((narrow (cl-loop for (y _ . xs) in consult-bookmark-narrow nconc + (cl-loop for x in xs collect (cons x y))))) + (cl-loop for bm in bookmark-alist collect + (propertize (car bm) + 'consult--type + (alist-get + (or (bookmark-get-handler bm) #'bookmark-default-handler) + narrow))))) + +;;;###autoload +(defun consult-bookmark (name) + "If bookmark NAME exists, open it, otherwise create a new bookmark with NAME. + +The command supports preview of file bookmarks and narrowing. See the +variable `consult-bookmark-narrow' for the narrowing configuration." + (interactive + (list + (let ((narrow (cl-loop for (x y . _) in consult-bookmark-narrow collect (cons x y)))) + (consult--read + (consult--bookmark-candidates) + :prompt "Bookmark: " + :state (consult--bookmark-preview) + :category 'bookmark + :history 'bookmark-history + ;; Add default names to future history. + ;; Ignore errors such that `consult-bookmark' can be used in + ;; buffers which are not backed by a file. + :add-history (ignore-errors (bookmark-prop-get (bookmark-make-record) 'defaults)) + :group (consult--type-group narrow) + :narrow (consult--type-narrow narrow))))) + (bookmark-maybe-load-default-file) + (if (assoc name bookmark-alist) + (bookmark-jump name) + (bookmark-set name))) + +;;;;; Command: consult-complex-command + +;;;###autoload +(defun consult-complex-command () + "Select and evaluate command from the command history. + +This command can act as a drop-in replacement for `repeat-complex-command'." + (interactive) + (let* ((history (or (delete-dups (mapcar #'prin1-to-string command-history)) + (user-error "There are no previous complex commands"))) + (cmd (read (consult--read + history + :prompt "Command: " + :default (car history) + :sort nil + :history t ;; disable history + :category 'expression)))) + ;; Taken from `repeat-complex-command' + (add-to-history 'command-history cmd) + (apply #'funcall-interactively + (car cmd) + (mapcar (lambda (e) (eval e t)) (cdr cmd))))) + +;;;;; Command: consult-history + +(declare-function ring-elements "ring") + +(defun consult--current-history () + "Return the history and index variable relevant to the current buffer. +If the minibuffer is active, the minibuffer history is returned, +otherwise the history corresponding to the mode. There is a +special case for `repeat-complex-command', for which the command +history is used." + (cond + ;; In the minibuffer we use the current minibuffer history, + ;; which can be configured by setting `minibuffer-history-variable'. + ((minibufferp) + (when (eq minibuffer-history-variable t) + (user-error "Minibuffer history is disabled for `%s'" this-command)) + (list (mapcar #'consult--tofu-hide + (if (eq minibuffer-history-variable 'command-history) + ;; If pressing "C-x M-:", i.e., `repeat-complex-command', + ;; we are instead querying the `command-history' and get a + ;; full s-expression. Alternatively you might want to use + ;; `consult-complex-command', which can also be bound to + ;; "C-x M-:"! + (mapcar #'prin1-to-string command-history) + (symbol-value minibuffer-history-variable))))) + ;; Otherwise we use a mode-specific history, see `consult-mode-histories'. + (t (let ((found (seq-find (lambda (h) + (and (derived-mode-p (car h)) + (boundp (if (consp (cdr h)) (cadr h) (cdr h))))) + consult-mode-histories))) + (unless found + (user-error "No history configured for `%s', see `consult-mode-histories'" + major-mode)) + (cons (symbol-value (cadr found)) (cddr found)))))) + +;;;###autoload +(defun consult-history (&optional history index bol) + "Insert string from HISTORY of current buffer. +In order to select from a specific HISTORY, pass the history +variable as argument. INDEX is the name of the index variable to +update, if any. BOL is the function which jumps to the beginning +of the prompt. See also `cape-history' from the Cape package." + (interactive) + (pcase-let* ((`(,history ,index ,bol) (if history + (list history index bol) + (consult--current-history))) + (history (if (ring-p history) (ring-elements history) history)) + (`(,beg . ,end) + (if (minibufferp) + (cons (minibuffer-prompt-end) (point-max)) + (if bol + (save-excursion + (funcall bol) + (cons (point) (pos-eol))) + (cons (point) (point))))) + (str (consult--local-let ((enable-recursive-minibuffers t)) + (consult--read + (or (consult--remove-dups history) + (user-error "History is empty")) + :prompt "History: " + :history t ;; disable history + :category ;; Report category depending on history variable + (and (minibufferp) + (pcase minibuffer-history-variable + ('extended-command-history 'command) + ('buffer-name-history 'buffer) + ('face-name-history 'face) + ('read-envvar-name-history 'environment-variable) + ('bookmark-history 'bookmark) + ('file-name-history 'file))) + :sort nil + :initial (buffer-substring-no-properties beg end) + :state (consult--insertion-preview beg end))))) + (delete-region beg end) + (when index + (set index (seq-position history str))) + (insert (substring-no-properties str)))) + +;;;;; Command: consult-isearch-history + +(defun consult-isearch-forward (&optional reverse) + "Continue Isearch forward optionally in REVERSE." + (declare (completion ignore)) + (interactive) + (consult--require-minibuffer) + (setq isearch-new-forward (not reverse) isearch-new-nonincremental nil) + (funcall (or (command-remapping #'exit-minibuffer) #'exit-minibuffer))) + +(defun consult-isearch-backward (&optional reverse) + "Continue Isearch backward optionally in REVERSE." + (declare (completion ignore)) + (interactive) + (consult-isearch-forward (not reverse))) + +(defvar-keymap consult-isearch-history-map + :doc "Additional keymap used by `consult-isearch-history'." + "<remap> <isearch-forward>" #'consult-isearch-forward + "<remap> <isearch-backward>" #'consult-isearch-backward) + +(defun consult--isearch-history-candidates () + "Return Isearch history candidates." + ;; Do not throw an error on empty history, in order to allow starting a + ;; search. We do not :require-match here. + (let ((history (if (eq t search-default-mode) + (append regexp-search-ring search-ring) + (append search-ring regexp-search-ring)))) + (delete-dups + (mapcar + (lambda (cand) + ;; The search type can be distinguished via text properties. + (let* ((props (plist-member (text-properties-at 0 cand) + 'isearch-regexp-function)) + (type (pcase (cadr props) + ((and 'nil (guard (not props))) ?r) + ('nil ?l) + ('word-search-regexp ?w) + ('isearch-symbol-regexp ?s) + ('char-fold-to-regexp ?c) + (_ ?u)))) + ;; Disambiguate history items. The same string could + ;; occur with different search types. + (consult--tofu-append cand type))) + history)))) + +(defconst consult--isearch-history-narrow + '((?c . "Char") + (?u . "Custom") + (?l . "Literal") + (?r . "Regexp") + (?s . "Symbol") + (?w . "Word"))) + +;;;###autoload +(defun consult-isearch-history () + "Read a search string with completion from the Isearch history. + +This replaces the current search string if Isearch is active, and +starts a new Isearch session otherwise." + (interactive) + (consult--forbid-minibuffer) + (let* ((isearch-message-function #'ignore) + (cursor-in-echo-area t) ;; Avoid cursor flickering + (candidates (consult--isearch-history-candidates))) + (unless isearch-mode (isearch-mode t)) + (with-isearch-suspended + (setq isearch-new-string + (consult--read + candidates + :prompt "I-search: " + :category 'consult-isearch-history + :history t ;; disable history + :sort nil + :initial isearch-string + :keymap consult-isearch-history-map + :annotate + (lambda (cand) + (consult--annotate-align + cand + (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) + :group + (lambda (cand transform) + (if transform + cand + (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) + :lookup + (lambda (selected candidates &rest _) + (if-let (found (member selected candidates)) + (substring (car found) 0 -1) + selected)) + :state + (lambda (action cand) + (when (and (eq action 'preview) cand) + (setq isearch-string cand) + (isearch-update-from-string-properties cand) + (isearch-update))) + :narrow + (list :predicate + (lambda (cand) (= (consult--tofu-get cand) consult--narrow)) + :keys consult--isearch-history-narrow)) + isearch-new-message + (mapconcat 'isearch-text-char-description isearch-new-string ""))) + ;; Setting `isearch-regexp' etc only works outside of `with-isearch-suspended'. + (unless (plist-member (text-properties-at 0 isearch-string) 'isearch-regexp-function) + (setq isearch-regexp t + isearch-regexp-function nil)))) + +;;;;; Command: consult-minor-mode-menu + +(defun consult--minor-mode-candidates () + "Return list of minor-mode candidate strings." + (mapcar + (pcase-lambda (`(,name . ,sym)) + (propertize + name + 'consult--candidate sym + 'consult--minor-mode-narrow + (logior + (ash (if (local-variable-if-set-p sym) ?l ?g) 8) + (if (and (boundp sym) (symbol-value sym)) ?i ?o)) + 'consult--minor-mode-group + (concat + (if (local-variable-if-set-p sym) "Local " "Global ") + (if (and (boundp sym) (symbol-value sym)) "On" "Off")))) + (nconc + ;; according to describe-minor-mode-completion-table-for-symbol + ;; the minor-mode-list contains *all* minor modes + (mapcar (lambda (sym) (cons (symbol-name sym) sym)) minor-mode-list) + ;; take the lighters from minor-mode-alist + (delq nil + (mapcar (pcase-lambda (`(,sym ,lighter)) + (when (and lighter (not (equal "" lighter))) + (let (message-log-max) + (setq lighter (string-trim (format-mode-line lighter))) + (unless (string-blank-p lighter) + (cons lighter sym))))) + minor-mode-alist))))) + +(defconst consult--minor-mode-menu-narrow + '((?l . "Local") + (?g . "Global") + (?i . "On") + (?o . "Off"))) + +;;;###autoload +(defun consult-minor-mode-menu () + "Enable or disable minor mode. + +This is an alternative to `minor-mode-menu-from-indicator'." + (interactive) + (call-interactively + (consult--read + (consult--minor-mode-candidates) + :prompt "Minor mode: " + :require-match t + :category 'minor-mode + :group + (lambda (cand transform) + (if transform cand (get-text-property 0 'consult--minor-mode-group cand))) + :narrow + (list :predicate + (lambda (cand) + (let ((narrow (get-text-property 0 'consult--minor-mode-narrow cand))) + (or (= (logand narrow 255) consult--narrow) + (= (ash narrow -8) consult--narrow)))) + :keys + consult--minor-mode-menu-narrow) + :lookup #'consult--lookup-candidate + :history 'consult--minor-mode-menu-history))) + +;;;;; Command: consult-theme + +;;;###autoload +(defun consult-theme (theme) + "Disable current themes and enable THEME from `consult-themes'. + +The command supports previewing the currently selected theme." + (interactive + (list + (let* ((regexp (consult--regexp-filter + (mapcar (lambda (x) (if (stringp x) x (format "\\`%s\\'" x))) + consult-themes))) + (avail-themes (seq-filter + (lambda (x) (string-match-p regexp (symbol-name x))) + (cons 'default (custom-available-themes)))) + (saved-theme (car custom-enabled-themes))) + (consult--read + (mapcar #'symbol-name avail-themes) + :prompt "Theme: " + :require-match t + :category 'theme + :history 'consult--theme-history + :lookup (lambda (selected &rest _) + (setq selected (and selected (intern-soft selected))) + (or (and selected (car (memq selected avail-themes))) + saved-theme)) + :state (lambda (action theme) + (pcase action + ('return (consult-theme (or theme saved-theme))) + ((and 'preview (guard theme)) (consult-theme theme)))) + :default (symbol-name (or saved-theme 'default)))))) + (when (eq theme 'default) (setq theme nil)) + (unless (eq theme (car custom-enabled-themes)) + (mapc #'disable-theme custom-enabled-themes) + (when theme + (if (custom-theme-p theme) + (enable-theme theme) + (load-theme theme :no-confirm))))) + +;;;;; Command: consult-buffer + +(defun consult--buffer-sort-alpha (buffers) + "Sort BUFFERS alphabetically, put starred buffers at the end." + (sort buffers + (lambda (x y) + (setq x (buffer-name x) y (buffer-name y)) + (let ((a (and (length> x 0) (eq (aref x 0) ?*))) + (b (and (length> y 0) (eq (aref y 0) ?*)))) + (if (eq a b) + (string< x y) + (not a)))))) + +(defun consult--buffer-sort-alpha-current (buffers) + "Sort BUFFERS alphabetically, put current at the beginning." + (let ((buffers (consult--buffer-sort-alpha buffers)) + (current (current-buffer))) + (if (memq current buffers) + (cons current (delq current buffers)) + buffers))) + +(defun consult--buffer-sort-visibility (buffers) + "Sort BUFFERS by visibility." + (let ((hidden) + (current (car (memq (current-buffer) buffers)))) + (consult--keep! buffers + (unless (eq it current) + (if (get-buffer-window it 'visible) + it + (push it hidden) + nil))) + (nconc (nreverse hidden) buffers (and current (list current))))) + +(defun consult--normalize-directory (dir) + "Normalize directory DIR. +DIR can be project, nil or a path." + (cond + ((eq dir 'project) (consult--project-root)) + (dir (expand-file-name dir)))) + +(defun consult--buffer-query-prompt (prompt query) + "Return a list of buffers and create an appropriate prompt string. +Return a pair of a prompt string and a list of buffers. PROMPT +is the prefix of the prompt string. QUERY specifies the buffers +to search and is passed to `consult--buffer-query'." + (let* ((dir (plist-get query :directory)) + (ndir (consult--normalize-directory dir)) + (buffers (apply #'consult--buffer-query :directory ndir query)) + (count (length buffers))) + (cons (format "%s (%d buffer%s%s): " prompt count + (if (= count 1) "" "s") + (cond + ((and ndir (eq dir 'project)) + (format ", Project %s" (consult--project-name ndir))) + (ndir (concat ", " (consult--left-truncate-file ndir))) + (t ""))) + buffers))) + +(cl-defun consult--buffer-query (&key sort directory mode as predicate (filter t) + include (exclude consult-buffer-filter) + (buffer-list t)) + "Query for a list of matching buffers. +The function supports filtering by various criteria which are +used throughout Consult. In particular it is the backbone of +most `consult-buffer-sources'. +DIRECTORY can either be the symbol project or a file name. +SORT can be visibility, alpha or nil. +FILTER can be either t, nil or invert. +EXCLUDE is a list of regexps. +INCLUDE is a list of regexps. +MODE can be a mode or a list of modes to restrict the returned buffers. +PREDICATE is a predicate function. +BUFFER-LIST is the unfiltered list of buffers. +AS is a conversion function." + (let ((root (consult--normalize-directory directory))) + (setq buffer-list (if (eq buffer-list t) (buffer-list) (copy-sequence buffer-list))) + (when sort + (setq buffer-list (funcall (intern (format "consult--buffer-sort-%s" sort)) buffer-list))) + (when (or filter mode as root) + (let ((exclude-re (consult--regexp-filter exclude)) + (include-re (consult--regexp-filter include)) + (case-fold-search)) + (consult--keep! buffer-list + (and + (or (not mode) + (let ((mm (buffer-local-value 'major-mode it))) + (if (consp mode) + (seq-some (lambda (m) (provided-mode-derived-p mm m)) mode) + (provided-mode-derived-p mm mode)))) + (pcase-exhaustive filter + ('nil t) + ((or 't 'invert) + (eq (eq filter t) + (and + (or (not exclude) + (not (string-match-p exclude-re (buffer-name it)))) + (or (not include) + (not (not (string-match-p include-re (buffer-name it))))))))) + (or (not root) + (when-let (dir (buffer-local-value 'default-directory it)) + (string-prefix-p root + (if (and (/= 0 (length dir)) (eq (aref dir 0) ?/)) + dir + (expand-file-name dir))))) + (or (not predicate) (funcall predicate it)) + (if as (funcall as it) it))))) + buffer-list)) + +(defun consult--buffer-file-hash () + "Return hash table of all buffer file names." + (consult--string-hash (consult--buffer-query :as #'buffer-file-name))) + +(defun consult--buffer-pair (buffer) + "Return a pair of name of BUFFER and BUFFER." + (cons (buffer-name buffer) buffer)) + +(defun consult--buffer-preview () + "Buffer preview function." + (let ((orig-buf (window-buffer (consult--original-window))) + (orig-prev (copy-sequence (window-prev-buffers))) + (orig-next (copy-sequence (window-next-buffers))) + other-win) + (lambda (action cand) + (pcase action + ('exit + (set-window-prev-buffers other-win orig-prev) + (set-window-next-buffers other-win orig-next)) + ('preview + (when (and (eq consult--buffer-display #'switch-to-buffer-other-window) + (not other-win)) + (switch-to-buffer-other-window orig-buf 'norecord) + (setq other-win (selected-window))) + (let ((win (or other-win (selected-window))) + (buf (or (and cand (get-buffer cand)) orig-buf))) + (when (and (window-live-p win) (buffer-live-p buf) + (not (buffer-match-p consult-preview-excluded-buffers buf))) + (with-selected-window win + (unless (or orig-prev orig-next) + (setq orig-prev (copy-sequence (window-prev-buffers)) + orig-next (copy-sequence (window-next-buffers)))) + (switch-to-buffer buf 'norecord))))))))) + +(defun consult--buffer-action (buffer &optional norecord) + "Switch to BUFFER via `consult--buffer-display' function. +If NORECORD is non-nil, do not record the buffer switch in the buffer list." + (funcall consult--buffer-display buffer norecord)) + +(consult--define-state buffer) + +(defvar consult--source-bookmark + `( :name "Bookmark" + :narrow ?m + :category bookmark + :face consult-bookmark + :history bookmark-history + :items ,#'bookmark-all-names + :state ,#'consult--bookmark-state) + "Bookmark candidate source for `consult-buffer'.") + +(defvar consult--source-project-buffer + `( :name "Project Buffer" + :narrow ?b + :category buffer + :face consult-buffer + :history buffer-name-history + :state ,#'consult--buffer-state + :enabled ,(lambda () consult-project-function) + :items + ,(lambda () + (when-let (root (consult--project-root)) + (consult--buffer-query :sort 'visibility + :directory root + :as #'consult--buffer-pair)))) + "Project buffer candidate source for `consult-buffer'.") + +(defvar consult--source-project-recent-file + `( :name "Project File" + :narrow ?f + :category file + :face consult-file + :history file-name-history + :state ,#'consult--file-state + :new + ,(lambda (file) + (consult--file-action + (expand-file-name file (consult--project-root)))) + :enabled + ,(lambda () + (and consult-project-function + recentf-mode)) + :items + ,(lambda () + (when-let (root (consult--project-root)) + (let ((len (length root)) + (ht (consult--buffer-file-hash)) + items) + (dolist (file (bound-and-true-p recentf-list) (nreverse items)) + ;; Emacs 29 abbreviates file paths by default, see + ;; `recentf-filename-handlers'. I recommend to set + ;; `recentf-filename-handlers' to nil to avoid any slow down. + (unless (eq (aref file 0) ?/) + (let (file-name-handler-alist) ;; No Tramp slowdown please. + (setq file (expand-file-name file)))) + (when (and (not (gethash file ht)) (string-prefix-p root file)) + (let ((part (substring file len))) + (when (equal part "") (setq part "./")) + (put-text-property 0 1 'multi-category `(file . ,file) part) + (push part items)))))))) + "Project file candidate source for `consult-buffer'.") + +(defvar consult--source-project-buffer-hidden + `(:hidden t :narrow (?p . "Project") ,@consult--source-project-buffer) + "Like `consult--source-project-buffer' but hidden by default.") + +(defvar consult--source-project-recent-file-hidden + `(:hidden t :narrow (?p . "Project") ,@consult--source-project-recent-file) + "Like `consult--source-project-recent-file' but hidden by default.") + +(defvar consult--source-hidden-buffer + `( :name "Hidden Buffer" + :narrow ?\s + :hidden t + :category buffer + :face consult-buffer + :history buffer-name-history + :action ,#'consult--buffer-action + :items + ,(lambda () (consult--buffer-query :sort 'visibility + :filter 'invert + :as #'consult--buffer-pair))) + "Hidden buffer candidate source for `consult-buffer'.") + +(defvar consult--source-modified-buffer + `( :name "Modified Buffer" + :narrow ?* + :hidden t + :category buffer + :face consult-buffer + :history buffer-name-history + :state ,#'consult--buffer-state + :items + ,(lambda () (consult--buffer-query :sort 'visibility + :as #'consult--buffer-pair + :predicate + (lambda (buf) + (and (buffer-modified-p buf) + (buffer-file-name buf)))))) + "Modified buffer candidate source for `consult-buffer'.") + +(defvar consult--source-buffer + `( :name "Buffer" + :narrow ?b + :category buffer + :face consult-buffer + :history buffer-name-history + :state ,#'consult--buffer-state + :default t + :items + ,(lambda () (consult--buffer-query :sort 'visibility + :as #'consult--buffer-pair))) + "Buffer candidate source for `consult-buffer'.") + +(defun consult--file-register-p (reg) + "Return non-nil if REG is a file register." + (memq (car-safe (cdr reg)) '(file-query file))) + +(autoload 'consult-register--candidates "consult-register") +(defvar consult--source-file-register + `( :name "File Register" + :narrow (?r . "Register") + :category file + :state ,#'consult--file-state + :enabled ,(lambda () (seq-some #'consult--file-register-p register-alist)) + :items ,(lambda () (consult-register--candidates #'consult--file-register-p))) + "File register source.") + +(defvar consult--source-recent-file + `( :name "File" + :narrow ?f + :category file + :face consult-file + :history file-name-history + :state ,#'consult--file-state + :new ,#'consult--file-action + :enabled ,(lambda () recentf-mode) + :items + ,(lambda () + (let ((ht (consult--buffer-file-hash)) + items) + (dolist (file (bound-and-true-p recentf-list) (nreverse items)) + ;; Emacs 29 abbreviates file paths by default, see + ;; `recentf-filename-handlers'. I recommend to set + ;; `recentf-filename-handlers' to nil to avoid any slow down. + (unless (eq (aref file 0) ?/) + (let (file-name-handler-alist) ;; No Tramp slowdown please. + (setq file (expand-file-name file)))) + (unless (gethash file ht) + (push (consult--fast-abbreviate-file-name file) items)))))) + "Recent file candidate source for `consult-buffer'.") + +;;;###autoload +(defun consult-buffer (&optional sources) + "Enhanced `switch-to-buffer' command with support for virtual buffers. + +The command supports recent files, bookmarks, views and project files as +virtual buffers. Buffers are previewed. Narrowing to buffers (b), files (f), +bookmarks (m) and project files (p) is supported via the corresponding +keys. In order to determine the project-specific files and buffers, the +`consult-project-function' is used. The virtual buffer SOURCES +default to `consult-buffer-sources'. See `consult--multi' for the +configuration of the virtual buffer sources." + (interactive) + (let ((selected (consult--multi (or sources consult-buffer-sources) + :require-match + (confirm-nonexistent-file-or-buffer) + :prompt "Switch to: " + :history 'consult--buffer-history + :sort nil))) + ;; For non-matching candidates, fall back to buffer creation. + (unless (plist-get (cdr selected) :match) + (consult--buffer-action (car selected))))) + +(defmacro consult--with-project (&rest body) + "Ensure that BODY is executed with a project root." + ;; We have to work quite hard here to ensure that the project root is + ;; only overridden at the current recursion level. When entering a + ;; recursive minibuffer session, we should be able to still switch the + ;; project. But who does that? Working on the first level on project A + ;; and on the second level on project B and on the third level on project C? + ;; You mustn't be afraid to dream a little bigger, darling. + `(let ((consult-project-function + (let ((root (or (consult--project-root t) (user-error "No project found"))) + (depth (recursion-depth)) + (orig consult-project-function)) + (lambda (may-prompt) + (if (= depth (recursion-depth)) + root + (funcall orig may-prompt)))))) + ,@body)) + +;;;###autoload +(defun consult-project-buffer () + "Enhanced `project-switch-to-buffer' command with support for virtual buffers. +The command may prompt you for a project directory if it is invoked from +outside a project. See `consult-buffer' for more details." + (interactive) + (consult--with-project + (consult-buffer consult-project-buffer-sources))) + +;;;###autoload +(defun consult-buffer-other-window () + "Variant of `consult-buffer', switching to a buffer in another window." + (interactive) + (let ((consult--buffer-display #'switch-to-buffer-other-window)) + (consult-buffer))) + +;;;###autoload +(defun consult-buffer-other-frame () + "Variant of `consult-buffer', switching to a buffer in another frame." + (interactive) + (let ((consult--buffer-display #'switch-to-buffer-other-frame)) + (consult-buffer))) + +;;;###autoload +(defun consult-buffer-other-tab () + "Variant of `consult-buffer', switching to a buffer in another tab." + (interactive) + (let ((consult--buffer-display #'switch-to-buffer-other-tab)) + (consult-buffer))) + +;;;;; Command: consult-grep + +(defun consult--grep-format (async builder) + "Return ASYNC function highlighting grep match results. +BUILDER is the command line builder function." + (let (highlight) + (lambda (action) + (cond + ((stringp action) + (setq highlight (cdr (funcall builder action))) + (funcall async action)) + ((consp action) + (let ((file "") (file-len 0) result) + (save-match-data + (dolist (str action) + (when (and (string-match consult--grep-match-regexp str) + ;; Filter out empty context lines + (or (/= (aref str (match-beginning 3)) ?-) + (/= (match-end 0) (length str)))) + ;; We share the file name across candidates to reduce + ;; the amount of allocated memory. + (unless (and (= file-len (- (match-end 1) (match-beginning 1))) + (eq t (compare-strings + file 0 file-len + str (match-beginning 1) (match-end 1) nil))) + (setq file (match-string 1 str) + file-len (length file))) + (let* ((line (match-string 2 str)) + (ctx (= (aref str (match-beginning 3)) ?-)) + (sep (if ctx "-" ":")) + (content (substring str (match-end 0))) + (line-len (length line))) + (when (and consult-grep-max-columns + (length> content consult-grep-max-columns)) + (setq content (substring content 0 consult-grep-max-columns))) + (when highlight + (funcall highlight content)) + (setq str (concat file sep line sep content)) + ;; Store file name in order to avoid allocations in `consult--prefix-group' + (add-text-properties 0 file-len `(face consult-file consult--prefix-group ,file) str) + (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str) + (when ctx + (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str)) + (push str result))))) + (funcall async (nreverse result)))) + (t (funcall async action)))))) + +(defun consult--grep-position (cand &optional find-file) + "Return the grep position marker for CAND. +FIND-FILE is the file open function, defaulting to `find-file-noselect'." + (when cand + (let* ((file-end (next-single-property-change 0 'face cand)) + (line-end (next-single-property-change (1+ file-end) 'face cand)) + (matches (consult--point-placement cand (1+ line-end) 'consult-grep-context)) + (file (substring-no-properties cand 0 file-end)) + (line (string-to-number (substring-no-properties cand (+ 1 file-end) line-end)))) + (when-let (pos (consult--marker-from-line-column + (funcall (or find-file #'consult--file-action) file) + line (or (car matches) 0))) + (cons pos (cdr matches)))))) + +(defun consult--grep-state () + "Grep state function." + (let ((open (consult--temporary-files)) + (jump (consult--jump-state))) + (lambda (action cand) + (unless cand + (funcall open)) + (funcall jump action (consult--grep-position + cand + (and (not (eq action 'return)) open)))))) + +(defun consult--grep-exclude-args () + "Produce grep exclude arguments. +Take the variables `grep-find-ignored-directories' and +`grep-find-ignored-files' into account." + (unless (boundp 'grep-find-ignored-files) (require 'grep)) + (nconc (mapcar (lambda (s) (concat "--exclude=" s)) + (bound-and-true-p grep-find-ignored-files)) + (mapcar (lambda (s) (concat "--exclude-dir=" s)) + (bound-and-true-p grep-find-ignored-directories)))) + +(defun consult--grep (prompt make-builder dir initial) + "Run asynchronous grep. + +MAKE-BUILDER is the function that returns the command line +builder function. DIR is a directory or a list of file or +directories. PROMPT is the prompt string. INITIAL is initial +input." + (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt prompt dir)) + (default-directory dir) + (builder (funcall make-builder paths))) + (consult--read + (consult--async-command builder + (consult--grep-format builder) + :file-handler t) ;; allow tramp + :prompt prompt + :lookup #'consult--lookup-member + :state (consult--grep-state) + :initial (consult--async-split-initial initial) + :add-history (consult--async-split-thingatpt 'symbol) + :require-match t + :category 'consult-grep + :group #'consult--prefix-group + :history '(:input consult--grep-history) + :sort nil))) + +(defun consult--grep-lookahead-p (&rest cmd) + "Return t if grep CMD supports look-ahead." + (eq 0 (process-file-shell-command + (concat "echo xaxbx | " + (mapconcat #'shell-quote-argument `(,@cmd "^(?=.*b)(?=.*a)") " "))))) + +(defun consult--grep-make-builder (paths) + "Build grep command line and grep across PATHS." + (let* ((cmd (consult--build-args consult-grep-args)) + (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) + (lambda (input) + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + (flags (append cmd opts)) + (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) + (if (or (member "-F" flags) (member "--fixed-strings" flags)) + (cons (append cmd (list "-e" arg) opts paths) + (apply-partially #'consult--highlight-regexps + (list (regexp-quote arg)) ignore-case)) + (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) + (when re + (cons (append cmd + (list (if (eq type 'pcre) "-P" "-E") ;; perl or extended + "-e" (consult--join-regexps re type)) + opts paths) + hl)))))))) + +;;;###autoload +(defun consult-grep (&optional dir initial) + "Search with `grep' for files in DIR where the content matches a regexp. + +The initial input is given by the INITIAL argument. DIR can be nil, a +directory string or a list of file/directory paths. If `consult-grep' +is called interactively with a prefix argument, the user can specify the +directories or files to search in. Multiple directories or files must +be separated by comma in the minibuffer, since they are read via +`completing-read-multiple'. By default the project directory is used if +`consult-project-function' is defined and returns non-nil. Otherwise +the `default-directory' is searched. If the command is invoked with a +double prefix argument (twice `C-u') the user is asked for a project, if +not yet inside a project, or the current project is searched. + +The input string is split, the first part of the string (grep input) is +passed to the asynchronous grep process and the second part of the +string is passed to the completion-style filtering. + +The input string is split at a punctuation character, which is given as +the first character of the input string. The format is similar to +Perl-style regular expressions, e.g., /regexp/. Furthermore command +line options can be passed to grep, specified behind --. The overall +prompt input has the form `#async-input -- grep-opts#filter-string'. + +Note that the grep input string is transformed from Emacs regular +expressions to Posix regular expressions. Always enter Emacs regular +expressions at the prompt. `consult-grep' behaves like builtin Emacs +search commands, e.g., Isearch, which take Emacs regular expressions. +Furthermore the asynchronous input split into words, each word must +match separately and in any order. See `consult--regexp-compiler' for +the inner workings. In order to disable transformations of the grep +input, adjust `consult--regexp-compiler' accordingly. + +Here we give a few example inputs: + +#alpha beta : Search for alpha and beta in any order. +#alpha.*beta : Search for alpha before beta. +#\\(alpha\\|beta\\) : Search for alpha or beta (Note Emacs syntax!) +#word -- -C3 : Search for word, include 3 lines as context +#first#second : Search for first, quick filter for second. + +The symbol at point is added to the future history." + (interactive "P") + (consult--grep "Grep" #'consult--grep-make-builder dir initial)) + +;;;;; Command: consult-git-grep + +(defun consult--git-grep-make-builder (paths) + "Create grep command line builder given PATHS." + (let ((cmd (consult--build-args consult-git-grep-args))) + (lambda (input) + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + (flags (append cmd opts)) + (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) + (if (or (member "-F" flags) (member "--fixed-strings" flags)) + (cons (append cmd (list "-e" arg) opts paths) + (apply-partially #'consult--highlight-regexps + (list (regexp-quote arg)) ignore-case)) + (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended ignore-case))) + (when re + (cons (append cmd + (cdr (mapcan (lambda (x) (list "--and" "-e" x)) re)) + opts paths) + hl)))))))) + +;;;###autoload +(defun consult-git-grep (&optional dir initial) + "Search with `git grep' for files in DIR with INITIAL input. +See `consult-grep' for details." + (interactive "P") + (consult--grep "Git-grep" #'consult--git-grep-make-builder dir initial)) + +;;;;; Command: consult-ripgrep + +(defun consult--ripgrep-make-builder (paths) + "Create ripgrep command line builder given PATHS." + (let* ((cmd (consult--build-args consult-ripgrep-args)) + (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) + (lambda (input) + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + (flags (append cmd opts)) + (ignore-case + (and (not (or (member "-s" flags) (member "--case-sensitive" flags))) + (or (member "-i" flags) (member "--ignore-case" flags) + (and (or (member "-S" flags) (member "--smart-case" flags)) + (let (case-fold-search) + ;; Case insensitive if there are no uppercase letters + (not (string-match-p "[[:upper:]]" arg)))))))) + (if (or (member "-F" flags) (member "--fixed-strings" flags)) + (cons (append cmd (list "-e" arg) opts paths) + (apply-partially #'consult--highlight-regexps + (list (regexp-quote arg)) ignore-case)) + (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) + (when re + (cons (append cmd (and (eq type 'pcre) '("-P")) + (list "-e" (consult--join-regexps re type)) + opts paths) + hl)))))))) + +;;;###autoload +(defun consult-ripgrep (&optional dir initial) + "Search with `rg' for files in DIR with INITIAL input. +See `consult-grep' for details." + (interactive "P") + (consult--grep "Ripgrep" #'consult--ripgrep-make-builder dir initial)) + +;;;;; Command: consult-find + +(defun consult--find (prompt builder initial) + "Run find command in current directory. + +The function returns the selected file. +The filename at point is added to the future history. + +BUILDER is the command line builder function. +PROMPT is the prompt. +INITIAL is initial input." + (consult--read + (consult--async-command builder + (consult--async-map (lambda (x) (string-remove-prefix "./" x))) + (consult--async-highlight builder) + :file-handler t) ;; allow tramp + :prompt prompt + :sort nil + :require-match t + :initial (consult--async-split-initial initial) + :add-history (consult--async-split-thingatpt 'filename) + :category 'file + :history '(:input consult--find-history))) + +(defun consult--find-make-builder (paths) + "Build find command line, finding across PATHS." + (let* ((cmd (seq-mapcat (lambda (x) + (if (equal x ".") paths (list x))) + (consult--build-args consult-find-args))) + (type (if (eq 0 (process-file-shell-command + (concat (car cmd) " -regextype emacs -version"))) + 'emacs 'basic))) + (lambda (input) + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + ;; ignore-case=t since -iregex is used below + (`(,re . ,hl) (funcall consult--regexp-compiler arg type t))) + (when re + (cons (append cmd + (cdr (mapcan + (lambda (x) + `("-and" "-iregex" + ,(format ".*%s.*" + ;; Replace non-capturing groups with capturing groups. + ;; GNU find does not support non-capturing groups. + (replace-regexp-in-string + "\\\\(\\?:" "\\(" x 'fixedcase 'literal)))) + re)) + opts) + hl)))))) + +;;;###autoload +(defun consult-find (&optional dir initial) + "Search for files with `find' in DIR. +The file names must match the input regexp. INITIAL is the +initial minibuffer input. See `consult-grep' for details +regarding the asynchronous search and the arguments." + (interactive "P") + (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Find" dir)) + (default-directory dir) + (builder (consult--find-make-builder paths))) + (find-file (consult--find prompt builder initial)))) + +;;;;; Command: consult-fd + +(defun consult--fd-make-builder (paths) + "Build find command line, finding across PATHS." + (let ((cmd (consult--build-args consult-fd-args))) + (lambda (input) + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + (flags (append cmd opts)) + (ignore-case + (and (not (or (member "-s" flags) (member "--case-sensitive" flags))) + (or (member "-i" flags) (member "--ignore-case" flags) + (let (case-fold-search) + ;; Case insensitive if there are no uppercase letters + (not (string-match-p "[[:upper:]]" arg))))))) + (if (or (member "-F" flags) (member "--fixed-strings" flags)) + (cons (append cmd (list arg) opts paths) + (apply-partially #'consult--highlight-regexps + (list (regexp-quote arg)) ignore-case)) + (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg 'pcre ignore-case))) + (when re + (cons (append cmd + (mapcan (lambda (x) `("--and" ,x)) re) + opts + (mapcan (lambda (x) `("--search-path" ,x)) paths)) + hl)))))))) + +;;;###autoload +(defun consult-fd (&optional dir initial) + "Search for files with `fd' in DIR. +The file names must match the input regexp. INITIAL is the +initial minibuffer input. See `consult-grep' for details +regarding the asynchronous search and the arguments." + (interactive "P") + (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Fd" dir)) + (default-directory dir) + (builder (consult--fd-make-builder paths))) + (find-file (consult--find prompt builder initial)))) + +;;;;; Command: consult-locate + +(defun consult--locate-builder (input) + "Build command line from INPUT." + (pcase-let ((`(,arg . ,opts) (consult--command-split input))) + (unless (string-blank-p arg) + (cons (append (consult--build-args consult-locate-args) + (consult--split-escaped arg) opts) + (cdr (consult--default-regexp-compiler input 'basic t)))))) + +;;;###autoload +(defun consult-locate (&optional initial) + "Search with `locate' for files which match input given INITIAL input. + +The input is treated literally such that locate can take advantage of +the locate database index. Regular expressions would often force a slow +linear search through the entire database. The locate process is started +asynchronously, similar to `consult-grep'. See `consult-grep' for more +details regarding the asynchronous search." + (interactive) + (find-file (consult--find "Locate: " #'consult--locate-builder initial))) + +;;;;; Command: consult-man + +(defun consult--man-builder (input) + "Build command line from INPUT." + (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) + (`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended t))) + (when re + (cons (append (consult--build-args consult-man-args) + (list (consult--join-regexps re 'extended)) + opts) + hl)))) + +(defun consult--man-format (lines) + "Format man candidates from LINES." + (let ((candidates)) + (save-match-data + (dolist (str lines) + (when (string-match "\\`\\(.*?\\([^ ]+\\) *(\\([^,)]+\\)[^)]*).*?\\) +- +\\(.*\\)\\'" str) + (let* ((names (match-string 1 str)) + (name (match-string 2 str)) + (section (match-string 3 str)) + (desc (match-string 4 str)) + (cand (format "%s - %s" names desc))) + (add-text-properties 0 (length names) + (list 'face 'consult-file + 'consult-man (concat section " " name)) + cand) + (push cand candidates))))) + (nreverse candidates))) + +;;;###autoload +(defun consult-man (&optional initial) + "Search for man page given INITIAL input. + +The input string is not preprocessed and passed literally to the +underlying man commands. The man process is started asynchronously, +similar to `consult-grep'. See `consult-grep' for more details regarding +the asynchronous search." + (interactive) + (man (consult--read + (consult--async-command #'consult--man-builder + (consult--async-transform consult--man-format) + (consult--async-highlight #'consult--man-builder)) + :prompt "Manual entry: " + :require-match t + :category 'consult-man + :lookup (apply-partially #'consult--lookup-prop 'consult-man) + :initial (consult--async-split-initial initial) + :add-history (consult--async-split-thingatpt 'symbol) + :history '(:input consult--man-history)))) + +;;;; Preview at point in completions buffers + +(define-minor-mode consult-preview-at-point-mode + "Preview minor mode for *Completions* buffers. +When moving around in the *Completions* buffer, the candidate at point is +automatically previewed." + :group 'consult + (if consult-preview-at-point-mode + (add-hook 'post-command-hook #'consult-preview-at-point nil 'local) + (remove-hook 'post-command-hook #'consult-preview-at-point 'local))) + +(defun consult-preview-at-point () + "Preview candidate at point in *Completions* buffer." + (interactive) + (when-let ((win (active-minibuffer-window)) + (buf (window-buffer win)) + (fun (buffer-local-value 'consult--preview-function buf))) + (funcall fun))) + +;;;; Integration with completion systems + +;;;;; Integration: Default *Completions* + +(defun consult--default-completion-minibuffer-candidate () + "Return current minibuffer candidate from default completion system or Icomplete." + (when (and (minibufferp) + (eq completing-read-function #'completing-read-default)) + (let ((content (minibuffer-contents-no-properties))) + ;; When the current minibuffer content matches a candidate, return it! + (if (test-completion content + minibuffer-completion-table + minibuffer-completion-predicate) + content + ;; Return the full first candidate of the sorted completion list. + (when-let ((completions (completion-all-sorted-completions))) + (concat + (substring content 0 (or (cdr (last completions)) 0)) + (car completions))))))) + +(defun consult--default-completion-list-candidate () + "Return current candidate at point from completions buffer." + (let (beg) + (when (and + (derived-mode-p 'completion-list-mode) + ;; Logic taken from `choose-completion'. + ;; TODO Upstream a `completion-list-get-candidate' function. + (cond + ((and (not (eobp)) (get-text-property (point) 'completion--string)) + (setq beg (1+ (point)))) + ((and (not (bobp)) (get-text-property (1- (point)) 'completion--string)) + (setq beg (point))))) + (get-text-property (previous-single-property-change beg 'completion--string) + 'completion--string)))) + +;;;;; Integration: Vertico + +(defvar vertico--input) +(declare-function vertico--exhibit "ext:vertico") +(declare-function vertico--candidate "ext:vertico") +(declare-function vertico--filter-completions "ext:vertico") + +(defun consult--vertico-candidate () + "Return current candidate for Consult preview." + (and vertico--input (vertico--candidate 'highlight))) + +(defun consult--vertico-refresh () + "Refresh completion UI." + (when vertico--input + (setq vertico--input t) + (vertico--exhibit))) + +(defun consult--vertico-filter-adv (orig pattern cands category highlight) + "Advice for ORIG `consult--completion-filter' function. +See `consult--completion-filter' for arguments PATTERN, CANDS, CATEGORY +and HIGHLIGHT." + (if (and (not highlight) (bound-and-true-p vertico-mode)) + ;; Optimize `consult--completion-filter' using the deferred highlighting + ;; from Vertico. The advice is not necessary - it is a pure optimization. + (nconc (car (vertico--filter-completions pattern cands nil (length pattern) + `(metadata (category . ,category)))) + nil) + (funcall orig pattern cands category highlight))) + +(with-eval-after-load 'vertico + (advice-add #'consult--completion-filter :around #'consult--vertico-filter-adv) + (add-hook 'consult--completion-candidate-hook #'consult--vertico-candidate) + (add-hook 'consult--completion-refresh-hook #'consult--vertico-refresh) + (define-key consult-async-map [remap vertico-insert] 'vertico-next-group)) + +;;;;; Integration: Mct + +(with-eval-after-load 'mct (add-hook 'consult--completion-refresh-hook + 'mct--live-completions-refresh)) + +;;;;; Integration: Icomplete + +(defvar icomplete-mode) +(declare-function icomplete-exhibit "icomplete") + +(defun consult--icomplete-refresh () + "Refresh icomplete view." + (when icomplete-mode + (let ((top (car completion-all-sorted-completions))) + (completion--flush-all-sorted-completions) + ;; force flushing, otherwise narrowing is broken! + (setq completion-all-sorted-completions nil) + (when top + (let* ((completions (completion-all-sorted-completions)) + (last (last completions)) + (before)) ;; completions before top + ;; warning: completions is an improper list + (while (consp completions) + (if (equal (car completions) top) + (progn + (setcdr last (append (nreverse before) (cdr last))) + (setq completion-all-sorted-completions completions + completions nil)) + (push (car completions) before) + (setq completions (cdr completions))))))) + (icomplete-exhibit))) + +(with-eval-after-load 'icomplete + (add-hook 'consult--completion-refresh-hook #'consult--icomplete-refresh)) + +(provide 'consult) +;;; consult.el ends here diff --git a/emacs/elpa/consult-20241115.517/consult.elc b/emacs/elpa/consult-20241115.517/consult.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-pkg.el b/emacs/elpa/corfu-20241112.830/corfu-pkg.el @@ -1,11 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "corfu" "20241112.830" - "COmpletion in Region FUnction." - '((emacs "28.1") - (compat "30")) - :url "https://github.com/minad/corfu" - :commit "3f468e9f355bb4e9a3e48d6323a51cc64eee3cc2" - :revdesc "3f468e9f355b" - :keywords '("abbrev" "convenience" "matching" "completion" "text") - :authors '(("Daniel Mendler" . "mail@daniel-mendler.de")) - :maintainers '(("Daniel Mendler" . "mail@daniel-mendler.de"))) diff --git a/emacs/elpa/corfu-20241112.830/corfu.el b/emacs/elpa/corfu-20241112.830/corfu.el @@ -1,1469 +0,0 @@ -;;; corfu.el --- COmpletion in Region FUnction -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2024 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Package-Version: 20241112.830 -;; Package-Revision: 3f468e9f355b -;; Package-Requires: ((emacs "28.1") (compat "30")) -;; URL: https://github.com/minad/corfu -;; Keywords: abbrev, convenience, matching, completion, text - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Corfu enhances in-buffer completion with a small completion popup. -;; The current candidates are shown in a popup below or above the -;; point. The candidates can be selected by moving up and down. -;; Corfu is the minimalistic in-buffer completion counterpart of the -;; Vertico minibuffer UI. - -;;; Code: - -(require 'compat) -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) - -(defgroup corfu nil - "COmpletion in Region FUnction." - :link '(info-link :tag "Info Manual" "(corfu)") - :link '(url-link :tag "Website" "https://github.com/minad/corfu") - :link '(url-link :tag "Wiki" "https://github.com/minad/corfu/wiki") - :link '(emacs-library-link :tag "Library Source" "corfu.el") - :group 'convenience - :group 'tools - :group 'matching - :prefix "corfu-") - -(defcustom corfu-count 10 - "Maximal number of candidates to show." - :type 'natnum) - -(defcustom corfu-scroll-margin 2 - "Number of lines at the top and bottom when scrolling. -The value should lie between 0 and corfu-count/2." - :type 'natnum) - -(defcustom corfu-min-width 15 - "Popup minimum width in characters." - :type 'natnum) - -(defcustom corfu-max-width 100 - "Popup maximum width in characters." - :type 'natnum) - -(defcustom corfu-cycle nil - "Enable cycling for `corfu-next' and `corfu-previous'." - :type 'boolean) - -(defcustom corfu-on-exact-match 'insert - "Configure how a single exact match should be handled. -- nil: No special handling, continue completion. -- insert: Insert candidate, quit and call the `:exit-function'. -- quit: Quit completion without further action. -- show: Initiate completion even for a single match only." - :type '(choice (const insert) (const show) (const quit) (const nil))) - -(defcustom corfu-continue-commands - ;; nil is undefined command - '(nil ignore universal-argument universal-argument-more digit-argument - "\\`corfu-" "\\`scroll-other-window") - "Continue Corfu completion after executing these commands. -The list can container either command symbols or regular expressions." - :type '(repeat (choice regexp symbol))) - -(defcustom corfu-preview-current 'insert - "Preview currently selected candidate. -If the variable has the value `insert', the candidate is automatically -inserted on further input." - :type '(choice boolean (const insert))) - -(defcustom corfu-preselect 'valid - "Configure if the prompt or first candidate is preselected. -- prompt: Always select the prompt. -- first: Always select the first candidate. -- valid: Only select the prompt if valid and not equal to the first candidate. -- directory: Like first, but select the prompt if it is a directory." - :type '(choice (const prompt) (const valid) (const first) (const directory))) - -(defcustom corfu-separator ?\s - "Component separator character. -The character used for separating components in the input. The presence -of this separator character will inhibit quitting at completion -boundaries, so that any further characters can be entered. To enter the -first separator character, call `corfu-insert-separator' (bound to M-SPC -by default). Useful for multi-component completion styles such as -Orderless." - :type 'character) - -(defcustom corfu-quit-at-boundary 'separator - "Automatically quit at completion boundary. -nil: Never quit at completion boundary. -t: Always quit at completion boundary. -separator: Quit at boundary if no `corfu-separator' has been inserted." - :type '(choice boolean (const separator))) - -(defcustom corfu-quit-no-match 'separator - "Automatically quit if no matching candidate is found. -When staying alive even if there is no match a warning message is -shown in the popup. -nil: Stay alive even if there is no match. -t: Quit if there is no match. -separator: Only stay alive if there is no match and -`corfu-separator' has been inserted." - :type '(choice boolean (const separator))) - -(defcustom corfu-left-margin-width 0.5 - "Width of the left margin in units of the character width." - :type 'float) - -(defcustom corfu-right-margin-width 0.5 - "Width of the right margin in units of the character width." - :type 'float) - -(defcustom corfu-bar-width 0.2 - "Width of the bar in units of the character width." - :type 'float) - -(defcustom corfu-margin-formatters nil - "Registry for margin formatter functions. -Each function of the list is called with the completion metadata as -argument until an appropriate formatter is found. The function should -return a formatter function, which takes the candidate string and must -return a string, possibly an icon. In order to preserve correct popup -alignment, the length and display width of the returned string must -precisely span the same number of characters of the fixed-width popup -font. For example the kind-icon package returns a string of length 3 -with a display width of 3 characters." - :type 'hook) - -(defcustom corfu-sort-function #'corfu-sort-length-alpha - "Default sorting function. -This function is used if the completion table does not specify a -`display-sort-function'." - :type `(choice - (const :tag "No sorting" nil) - (const :tag "By length and alpha" ,#'corfu-sort-length-alpha) - (function :tag "Custom function"))) - -(defcustom corfu-sort-override-function nil - "Override sort function which overrides the `display-sort-function'. -This function is used even if a completion table specifies its -own sort function." - :type '(choice (const nil) function)) - -(defcustom corfu-auto-prefix 3 - "Minimum length of prefix for auto completion. -The completion backend can override this with -:company-prefix-length. It is *not recommended* to use a small -prefix length (below 2), since this will create high load for -Emacs. See also `corfu-auto-delay'." - :type 'natnum) - -(defcustom corfu-auto-delay 0.2 - "Delay for auto completion. -It is *not recommended* to use a short delay or even 0, since -this will create high load for Emacs, in particular if executing -the completion backend is costly." - :type 'float) - -(defcustom corfu-auto-commands - '("self-insert-command\\'" "delete-backward-char\\'" "\\`backward-delete-char" - c-electric-colon c-electric-lt-gt c-electric-slash c-scope-operator) - "Commands which initiate auto completion. -The list can container either command symbols or regular expressions." - :type '(repeat (choice regexp symbol))) - -(defcustom corfu-auto nil - "Enable auto completion. -See also the settings `corfu-auto-delay', `corfu-auto-prefix' and -`corfu-auto-commands'." - :type 'boolean) - -(defgroup corfu-faces nil - "Faces used by Corfu." - :group 'corfu - :group 'faces) - -(defface corfu-default - '((((class color) (min-colors 88) (background dark)) :background "#191a1b") - (((class color) (min-colors 88) (background light)) :background "#f0f0f0") - (t :background "gray")) - "Default face, foreground and background colors used for the popup.") - -(defface corfu-current - '((((class color) (min-colors 88) (background dark)) - :background "#00415e" :foreground "white" :extend t) - (((class color) (min-colors 88) (background light)) - :background "#c0efff" :foreground "black" :extend t) - (t :background "blue" :foreground "white" :extend t)) - "Face used to highlight the currently selected candidate.") - -(defface corfu-bar - '((((class color) (min-colors 88) (background dark)) :background "#a8a8a8") - (((class color) (min-colors 88) (background light)) :background "#505050") - (t :background "gray")) - "The background color is used for the scrollbar indicator.") - -(defface corfu-border - '((((class color) (min-colors 88) (background dark)) :background "#323232") - (((class color) (min-colors 88) (background light)) :background "#d7d7d7") - (t :background "gray")) - "The background color used for the thin border.") - -(defface corfu-annotations - '((t :inherit completions-annotations)) - "Face used for annotations.") - -(defface corfu-deprecated - '((t :inherit shadow :strike-through t)) - "Face used for deprecated candidates.") - -(defvar-keymap corfu-mode-map - :doc "Keymap used when `corfu-mode' is active.") - -(defvar-keymap corfu-map - :doc "Keymap used when popup is shown." - "<remap> <move-beginning-of-line>" #'corfu-prompt-beginning - "<remap> <move-end-of-line>" #'corfu-prompt-end - "<remap> <beginning-of-buffer>" #'corfu-first - "<remap> <end-of-buffer>" #'corfu-last - "<remap> <scroll-down-command>" #'corfu-scroll-down - "<remap> <scroll-up-command>" #'corfu-scroll-up - "<remap> <next-line>" #'corfu-next - "<remap> <previous-line>" #'corfu-previous - "<remap> <completion-at-point>" #'corfu-complete - "<remap> <keyboard-escape-quit>" #'corfu-reset - "<down>" #'corfu-next - "<up>" #'corfu-previous - "M-n" #'corfu-next - "M-p" #'corfu-previous - "C-g" #'corfu-quit - "RET" #'corfu-insert - "TAB" #'corfu-complete - "M-TAB" #'corfu-expand - "M-g" 'corfu-info-location - "M-h" 'corfu-info-documentation - "M-SPC" #'corfu-insert-separator) - -(defvar corfu--auto-timer (timer-create) - "Auto completion timer.") - -(defvar corfu--candidates nil - "List of candidates.") - -(defvar corfu--metadata nil - "Completion metadata.") - -(defvar corfu--base "" - "Base string, which is concatenated with the candidate.") - -(defvar corfu--total 0 - "Length of the candidate list `corfu--candidates'.") - -(defvar corfu--hilit #'identity - "Lazy candidate highlighting function.") - -(defvar corfu--index -1 - "Index of current candidate or negative for prompt selection.") - -(defvar corfu--preselect -1 - "Index of preselected candidate, negative for prompt selection.") - -(defvar corfu--scroll 0 - "Scroll position.") - -(defvar corfu--input nil - "Cons of last prompt contents and point.") - -(defvar corfu--preview-ov nil - "Current candidate overlay.") - -(defvar corfu--change-group nil - "Undo change group.") - -(defvar corfu--frame nil - "Popup frame.") - -(defvar corfu--width 0 - "Popup width of current completion to reduce width fluctuations.") - -(defconst corfu--initial-state - (mapcar - (lambda (k) (cons k (symbol-value k))) - '(corfu--base - corfu--candidates - corfu--hilit - corfu--index - corfu--preselect - corfu--scroll - corfu--input - corfu--total - corfu--preview-ov - corfu--change-group - corfu--metadata - corfu--width)) - "Initial Corfu state.") - -(defvar corfu--frame-parameters - '((no-accept-focus . t) - (no-focus-on-map . t) - (min-width . t) - (min-height . t) - (border-width . 0) - (outer-border-width . 0) - (internal-border-width . 1) - (child-frame-border-width . 1) - (vertical-scroll-bars . nil) - (horizontal-scroll-bars . nil) - (menu-bar-lines . 0) - (tool-bar-lines . 0) - (tab-bar-lines . 0) - (no-other-frame . t) - (unsplittable . t) - (undecorated . t) - (cursor-type . nil) - (no-special-glyphs . t) - (desktop-dont-save . t)) - "Default child frame parameters.") - -(defvar corfu--buffer-parameters - '((mode-line-format . nil) - (header-line-format . nil) - (tab-line-format . nil) - (tab-bar-format . nil) - (frame-title-format . "") - (truncate-lines . t) - (cursor-in-non-selected-windows . nil) - (cursor-type . nil) - (show-trailing-whitespace . nil) - (display-line-numbers . nil) - (left-fringe-width . 0) - (right-fringe-width . 0) - (left-margin-width . 0) - (right-margin-width . 0) - (fringes-outside-margins . 0) - (fringe-indicator-alist (continuation) (truncation)) - (indicate-empty-lines . nil) - (indicate-buffer-boundaries . nil) - (buffer-read-only . t)) - "Default child frame buffer parameters.") - -(defvar corfu--mouse-ignore-map - (let ((map (make-sparse-keymap))) - (dotimes (i 7) - (dolist (k '(mouse down-mouse drag-mouse double-mouse triple-mouse)) - (keymap-set map (format "<%s-%s>" k (1+ i)) #'ignore))) - map) - "Ignore all mouse clicks.") - -(defun corfu--replace (beg end str) - "Replace range between BEG and END with STR." - (unless (equal str (buffer-substring-no-properties beg end)) - ;; bug#55205: completion--replace removed properties as an unwanted - ;; side-effect. We also don't want to leave text properties. - (completion--replace beg end (substring-no-properties str)))) - -(defun corfu--capf-wrapper (fun &optional prefix) - "Wrapper for `completion-at-point' FUN. -The wrapper determines if the Capf is applicable at the current -position and performs sanity checking on the returned result. -For non-exclusive Capfs wrapper additionally checks if the -current input can be completed successfully. PREFIX is a prefix -length override, set to t for manual completion." - (pcase (funcall fun) - ((and res `(,beg ,end ,table . ,plist)) - (and (integer-or-marker-p beg) ;; Valid Capf result - (<= beg (point) end) ;; Sanity checking - ;; When auto completing, check the prefix length! - (let ((len (or prefix - (plist-get plist :company-prefix-length) - (- (point) beg)))) - (or (eq len t) (>= len corfu-auto-prefix))) - ;; For non-exclusive Capfs, check for valid completion. - (or (not (eq 'no (plist-get plist :exclusive))) - (let* ((str (buffer-substring-no-properties beg end)) - (pt (- (point) beg)) - (pred (plist-get plist :predicate)) - (md (completion-metadata (substring str 0 pt) table pred))) - ;; We use `completion-try-completion' to check if there are - ;; completions. The upstream `completion--capf-wrapper' uses - ;; `try-completion' which is incorrect since it only checks for - ;; prefix completions. - (completion-try-completion str table pred pt md))) - (cons fun res))))) - -(defun corfu--make-buffer (name) - "Create buffer with NAME." - (let ((fr face-remapping-alist) - (ls line-spacing) - (buffer (get-buffer-create name))) - (with-current-buffer buffer - ;;; XXX HACK install mouse ignore map - (use-local-map corfu--mouse-ignore-map) - (dolist (var corfu--buffer-parameters) - (set (make-local-variable (car var)) (cdr var))) - (setq-local face-remapping-alist (copy-tree fr) - line-spacing ls) - (cl-pushnew 'corfu-default (alist-get 'default face-remapping-alist)) - buffer))) - -(defvar x-gtk-resize-child-frames) ;; Not present on non-gtk builds -(defvar corfu--gtk-resize-child-frames - (let ((case-fold-search t)) - ;; XXX HACK to fix resizing on gtk3/gnome taken from posframe.el - ;; More information: - ;; * https://github.com/minad/corfu/issues/17 - ;; * https://gitlab.gnome.org/GNOME/mutter/-/issues/840 - ;; * https://lists.gnu.org/archive/html/emacs-devel/2020-02/msg00001.html - (and (string-match-p "gtk3" system-configuration-features) - (string-match-p "gnome\\|cinnamon" - (or (getenv "XDG_CURRENT_DESKTOP") - (getenv "DESKTOP_SESSION") "")) - 'resize-mode))) - -;; Function adapted from posframe.el by tumashu -(defun corfu--make-frame (frame x y width height) - "Show current buffer in child frame at X/Y with WIDTH/HEIGHT. -FRAME is the existing frame." - (when-let (((frame-live-p frame)) - (timer (frame-parameter frame 'corfu--hide-timer))) - (cancel-timer timer) - (set-frame-parameter frame 'corfu--hide-timer nil)) - (let* ((window-min-height 1) - (window-min-width 1) - (inhibit-redisplay t) - (x-gtk-resize-child-frames corfu--gtk-resize-child-frames) - (before-make-frame-hook) - (after-make-frame-functions) - (parent (window-frame))) - (unless (and (frame-live-p frame) - (eq (frame-parent frame) - (and (not (bound-and-true-p exwm--connection)) parent)) - ;; If there is more than one window, `frame-root-window' may - ;; return nil. Recreate the frame in this case. - (window-live-p (frame-root-window frame))) - (when frame (delete-frame frame)) - (setq frame (make-frame - `((parent-frame . ,parent) - (minibuffer . ,(minibuffer-window parent)) - (width . 0) (height . 0) (visibility . nil) - (right-fringe . ,right-fringe-width) - (left-fringe . ,left-fringe-width) - ,@corfu--frame-parameters)))) - ;; XXX HACK Setting the same frame-parameter/face-background is not a nop. - ;; Check before applying the setting. Without the check, the frame flickers - ;; on Mac. We have to apply the face background before adjusting the frame - ;; parameter, otherwise the border is not updated. - (let ((new (face-attribute 'corfu-border :background nil 'default))) - (unless (equal (face-attribute 'internal-border :background frame 'default) new) - (set-face-background 'internal-border new frame)) - ;; XXX The Emacs Mac Port does not support `internal-border', we also have - ;; to set `child-frame-border'. - (unless (or (not (facep 'child-frame-border)) - (equal (face-attribute 'child-frame-border :background frame 'default) new)) - (set-face-background 'child-frame-border new frame))) - ;; Reset frame parameters if they changed. For example `tool-bar-mode' - ;; overrides the parameter `tool-bar-lines' for every frame, including child - ;; frames. The child frame API is a pleasure to work with. It is full of - ;; lovely surprises. - (let* ((win (frame-root-window frame)) - (is (frame-parameters frame)) - (should `((background-color - . ,(face-attribute 'corfu-default :background nil 'default)) - (font . ,(frame-parameter parent 'font)) - (right-fringe . ,right-fringe-width) - (left-fringe . ,left-fringe-width) - ,@corfu--frame-parameters)) - (diff (cl-loop for p in should for (k . v) = p - unless (equal (alist-get k is) v) collect p))) - (when diff (modify-frame-parameters frame diff)) - ;; XXX HACK: `set-window-buffer' must be called to force fringe update. - (when (or diff (eq (window-buffer win) (current-buffer))) - (set-window-buffer win (current-buffer))) - ;; Disallow selection of root window (gh:minad/corfu#63) - (set-window-parameter win 'no-delete-other-windows t) - (set-window-parameter win 'no-other-window t) - ;; Mark window as dedicated to prevent frame reuse (gh:minad/corfu#60) - (set-window-dedicated-p win t)) - (redirect-frame-focus frame parent) - (set-frame-size frame width height t) - (pcase-let ((`(,px . ,py) (frame-position frame))) - (unless (and (= x px) (= y py)) - (set-frame-position frame x y)))) - (make-frame-visible frame) - ;; Unparent child frame if EXWM is used, otherwise EXWM buffers are drawn on - ;; top of the Corfu child frame. - (when (and (bound-and-true-p exwm--connection) (frame-parent frame)) - (set-frame-parameter frame 'parent-frame nil)) - frame) - -(defun corfu--hide-frame-deferred (frame) - "Deferred hiding of child FRAME." - (when (and (frame-live-p frame) (frame-visible-p frame)) - (set-frame-parameter frame 'corfu--hide-timer nil) - (make-frame-invisible frame) - (with-current-buffer (window-buffer (frame-root-window frame)) - (with-silent-modifications - (delete-region (point-min) (point-max)))))) - -(defun corfu--hide-frame (frame) - "Hide child FRAME." - (when (and (frame-live-p frame) (frame-visible-p frame) - (not (frame-parameter frame 'corfu--hide-timer))) - (set-frame-parameter frame 'corfu--hide-timer - (run-at-time 0 nil #'corfu--hide-frame-deferred frame)))) - -(defun corfu--move-to-front (elem list) - "Move ELEM to front of LIST." - ;; In contrast to Vertico, this function handles duplicates. See also the - ;; special deduplication function `corfu--delete-dups' based on - ;; `equal-including-properties' - (nconc (cl-loop for x in list if (equal x elem) collect x) - (delete elem list))) - -(defun corfu--filter-completions (&rest args) - "Compute all completions for ARGS with lazy highlighting." - (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) - (static-if (>= emacs-major-version 30) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) - (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) - (orig-flex (symbol-function #'completion-flex-all-completions)) - ((symbol-function #'completion-flex-all-completions) - (lambda (&rest args) - ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses - ;; the completion-score for sorting, which is applied during highlighting. - (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) - (apply orig-flex args)))) - ((symbol-function #'completion-pcm--hilit-commonality) - (lambda (pattern cands) - (setq completion-lazy-hilit-fn - (lambda (x) - ;; `completion-pcm--hilit-commonality' sometimes throws an internal error - ;; for example when entering "/sudo:://u". - (condition-case nil - (car (completion-pcm--hilit-commonality pattern (list x))) - (t x)))) - cands)) - ((symbol-function #'completion-hilit-commonality) - (lambda (cands prefix &optional base) - (setq completion-lazy-hilit-fn - (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) - (and cands (nconc cands base))))) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) - -(defsubst corfu--length-string< (x y) - "Sorting predicate which compares X and Y first by length then by `string<'." - (or (< (length x) (length y)) (and (= (length x) (length y)) (string< x y)))) - -(defmacro corfu--partition! (list form) - "Evaluate FORM for every element and partition LIST." - (cl-with-gensyms (head1 head2 tail1 tail2) - `(let* ((,head1 (cons nil nil)) - (,head2 (cons nil nil)) - (,tail1 ,head1) - (,tail2 ,head2)) - (while ,list - (if (let ((it (car ,list))) ,form) - (progn - (setcdr ,tail1 ,list) - (pop ,tail1)) - (setcdr ,tail2 ,list) - (pop ,tail2)) - (pop ,list)) - (setcdr ,tail1 (cdr ,head2)) - (setcdr ,tail2 nil) - (setq ,list (cdr ,head1))))) - -(defun corfu--move-prefix-candidates-to-front (field cands) - "Move CANDS which match prefix of FIELD to the beginning." - (let* ((word (substring field 0 - (seq-position field corfu-separator))) - (len (length word))) - (corfu--partition! - cands - (and (>= (length it) len) - (eq t (compare-strings word 0 len it 0 len - completion-ignore-case)))))) - -;; bug#6581: `equal-including-properties' uses `eq' for properties until 29.1. -;; Approximate by comparing `text-properties-at' position 0. -(defalias 'corfu--equal-including-properties - (static-if (< emacs-major-version 29) - (lambda (x y) - (and (equal x y) - (equal (text-properties-at 0 x) (text-properties-at 0 y)))) - #'equal-including-properties)) - -(defun corfu--delete-dups (list) - "Delete `equal-including-properties' consecutive duplicates from LIST." - (let ((beg list)) - (while (cdr beg) - (let ((end (cdr beg))) - (while (equal (car beg) (car end)) (pop end)) - ;; The deduplication is quadratic in the number of duplicates. We can - ;; avoid the quadratic complexity with a hash table which takes - ;; properties into account (available since Emacs 28). - (while (not (eq beg end)) - (let ((dup beg)) - (while (not (eq (cdr dup) end)) - (if (corfu--equal-including-properties (car beg) (cadr dup)) - (setcdr dup (cddr dup)) - (pop dup)))) - (pop beg))))) - list) - -(defun corfu--sort-function () - "Return the sorting function." - (or corfu-sort-override-function - (corfu--metadata-get 'display-sort-function) - corfu-sort-function)) - -(defun corfu--recompute (str pt table pred) - "Recompute state from STR, PT, TABLE and PRED." - (pcase-let* ((before (substring str 0 pt)) - (after (substring str pt)) - (corfu--metadata (completion-metadata before table pred)) - ;; bug#47678: `completion-boundaries' fails for `partial-completion' - ;; if the cursor is moved before the slashes of "~//". - ;; See also vertico.el which has the same issue. - (bounds (condition-case nil - (completion-boundaries before table pred after) - (t (cons 0 (length after))))) - (field (substring str (car bounds) (+ pt (cdr bounds)))) - (completing-file (eq (corfu--metadata-get 'category) 'file)) - (`(,all . ,hl) (corfu--filter-completions str table pred pt corfu--metadata)) - (base (or (when-let ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) - (corfu--base (substring str 0 base)) - (pre nil)) - ;; Filter the ignored file extensions. We cannot use modified predicate for - ;; this filtering, since this breaks the special casing in the - ;; `completion-file-name-table' for `file-exists-p' and `file-directory-p'. - (when completing-file (setq all (completion-pcm--filename-try-filter all))) - ;; Sort using the `display-sort-function' or the Corfu sort functions, and - ;; delete duplicates with respect to `equal-including-properties'. This is - ;; a deviation from the Vertico completion UI with more aggressive - ;; deduplication, where candidates are compared with `equal'. Corfu - ;; preserves candidates which differ in their text properties. Corfu tries - ;; to preserve text properties as much as possible, when calling the - ;; `:exit-function' to help Capfs with candidate disambiguation. This - ;; matters in particular for Lsp backends, which produce duplicates for - ;; overloaded methods. - (setq all (corfu--delete-dups (funcall (or (corfu--sort-function) #'identity) all)) - all (corfu--move-prefix-candidates-to-front field all)) - (when (and completing-file (not (string-suffix-p "/" field))) - (setq all (corfu--move-to-front (concat field "/") all))) - (setq all (corfu--move-to-front field all) - pre (if (or (eq corfu-preselect 'prompt) (not all) - (and completing-file (eq corfu-preselect 'directory) - (= (length corfu--base) (length str)) - (test-completion str table pred)) - (and (eq corfu-preselect 'valid) - (not (equal field (car all))) - (not (and completing-file (equal (concat field "/") (car all)))) - (test-completion str table pred))) - -1 0)) - `((corfu--base . ,corfu--base) - (corfu--metadata . ,corfu--metadata) - (corfu--candidates . ,all) - (corfu--total . ,(length all)) - (corfu--hilit . ,(or hl #'identity)) - (corfu--preselect . ,pre) - (corfu--index . ,(or (and (>= corfu--index 0) (/= corfu--index corfu--preselect) - (seq-position all (nth corfu--index corfu--candidates))) - pre))))) - -(defun corfu--update (&optional interruptible) - "Update state, optionally INTERRUPTIBLE." - (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (pt (- (point) beg)) - (str (buffer-substring-no-properties beg end)) - (input (cons str pt))) - (unless (equal corfu--input input) - ;; Redisplay such that the input is immediately shown before the expensive - ;; candidate recomputation (gh:minad/corfu#48). See also corresponding - ;; issue gh:minad/vertico#89. - (when interruptible (redisplay)) - ;; Bind non-essential=t to prevent Tramp from opening new connections, - ;; without the user explicitly requesting it via M-TAB. - (pcase (let ((non-essential t)) - ;; XXX Guard against errors during candidate generation. - ;; bug#61274: `dabbrev-capf' signals errors. - (condition-case err - (if interruptible - (while-no-input (corfu--recompute str pt table pred)) - (corfu--recompute str pt table pred)) - (error - (message "Corfu completion error: %s" (error-message-string err)) - t))) - ('nil (keyboard-quit)) - ((and state (pred consp)) - (setq corfu--input input) - (dolist (s state) (set (car s) (cdr s)))))) - input)) - -(defun corfu--match-symbol-p (pattern sym) - "Return non-nil if SYM is matching an element of the PATTERN list." - (cl-loop with case-fold-search = nil - for x in (and (symbolp sym) pattern) - thereis (if (symbolp x) - (eq sym x) - (string-match-p x (symbol-name sym))))) - -(defun corfu--metadata-get (prop) - "Return PROP from completion metadata." - ;; Marginalia and various icon packages advise `completion-metadata-get' to - ;; inject their annotations, but are meant only for minibuffer completion. - ;; Therefore call `completion-metadata-get' without advices here. - (let ((completion-extra-properties (nth 4 completion-in-region--data))) - (funcall (advice--cd*r (symbol-function (compat-function completion-metadata-get))) - corfu--metadata prop))) - -(defun corfu--format-candidates (cands) - "Format annotated CANDS." - (cl-loop for c in cands do - (cl-loop for s in-ref c do - (setf s (replace-regexp-in-string "[ \t]*\n[ \t]*" " " s)))) - (let* ((cw (cl-loop for x in cands maximize (string-width (car x)))) - (pw (cl-loop for x in cands maximize (string-width (cadr x)))) - (sw (cl-loop for x in cands maximize (string-width (caddr x)))) - (width (min (max corfu--width corfu-min-width (+ pw cw sw)) - ;; -4 because of margins and some additional safety - corfu-max-width (- (frame-width) 4))) - (trunc (not (display-graphic-p)))) - (setq corfu--width width) - (list pw width - (cl-loop - for (cand prefix suffix) in cands collect - (let ((s (concat - prefix (make-string (- pw (string-width prefix)) ?\s) cand - (when (> sw 0) - (make-string (max 0 (- width pw (string-width cand) - (string-width suffix))) - ?\s)) - suffix))) - (if trunc (truncate-string-to-width s width) s)))))) - -(defun corfu--compute-scroll () - "Compute new scroll position." - (let ((off (max (min corfu-scroll-margin (/ corfu-count 2)) 0)) - (corr (if (= corfu-scroll-margin (/ corfu-count 2)) (1- (mod corfu-count 2)) 0))) - (setq corfu--scroll (min (max 0 (- corfu--total corfu-count)) - (max 0 (+ corfu--index off 1 (- corfu-count)) - (min (- corfu--index off corr) corfu--scroll)))))) - -(defun corfu--candidates-popup (pos) - "Show candidates popup at POS." - (corfu--compute-scroll) - (pcase-let* ((last (min (+ corfu--scroll corfu-count) corfu--total)) - (bar (ceiling (* corfu-count corfu-count) corfu--total)) - (lo (min (- corfu-count bar 1) (floor (* corfu-count corfu--scroll) corfu--total))) - (`(,mf . ,acands) (corfu--affixate - (cl-loop repeat corfu-count - for c in (nthcdr corfu--scroll corfu--candidates) - collect (funcall corfu--hilit (substring c))))) - (`(,pw ,width ,fcands) (corfu--format-candidates acands)) - ;; Disable the left margin if a margin formatter is active. - (corfu-left-margin-width (if mf 0 corfu-left-margin-width))) - ;; Nonlinearity at the end and the beginning - (when (/= corfu--scroll 0) - (setq lo (max 1 lo))) - (when (/= last corfu--total) - (setq lo (min (- corfu-count bar 2) lo))) - (corfu--popup-show pos pw width fcands (- corfu--index corfu--scroll) - (and (> corfu--total corfu-count) lo) bar))) - -(defun corfu--range-valid-p () - "Check the completion range, return non-nil if valid." - (pcase-let ((buf (current-buffer)) - (pt (point)) - (`(,beg ,end . ,_) completion-in-region--data)) - (and beg end - (eq buf (marker-buffer beg)) (eq buf (window-buffer)) - (<= beg pt end) - (save-excursion (goto-char beg) (<= (pos-bol) pt (pos-eol)))))) - -(defun corfu--continue-p () - "Check if completion should continue after a command. -Corfu bails out if the current buffer changed unexpectedly or if -point moved out of range, see `corfu--range-valid-p'. Also the -input must satisfy the `completion-in-region-mode--predicate' and -the last command must be listed in `corfu-continue-commands'." - (and (corfu--range-valid-p) - ;; We keep Corfu alive if a `overriding-terminal-local-map' is - ;; installed, e.g., the `universal-argument-map'. It would be good to - ;; think about a better criterion instead. Unfortunately relying on - ;; `this-command' alone is insufficient, since the value of - ;; `this-command' gets clobbered in the case of transient keymaps. - (or overriding-terminal-local-map - ;; Check if it is an explicitly listed continue command - (corfu--match-symbol-p corfu-continue-commands this-command) - (pcase-let ((`(,beg ,end . ,_) completion-in-region--data)) - (and (or (not corfu--input) (< beg end)) ;; Check for empty input - (or (not corfu-quit-at-boundary) ;; Check separator or predicate - (and (eq corfu-quit-at-boundary 'separator) - (or (eq this-command #'corfu-insert-separator) - ;; with separator, any further chars allowed - (seq-contains-p (car corfu--input) corfu-separator))) - (funcall completion-in-region-mode--predicate))))))) - -(defun corfu--preview-current-p () - "Return t if the selected candidate is previewed." - (and corfu-preview-current (>= corfu--index 0) (/= corfu--index corfu--preselect))) - -(defun corfu--preview-current (beg end) - "Show current candidate as overlay given BEG and END." - (when (corfu--preview-current-p) - (setq beg (+ beg (length corfu--base)) - corfu--preview-ov (make-overlay beg end nil)) - (overlay-put corfu--preview-ov 'priority 1000) - (overlay-put corfu--preview-ov 'window (selected-window)) - (overlay-put corfu--preview-ov (if (= beg end) 'after-string 'display) - (nth corfu--index corfu--candidates)))) - -(defun corfu--window-change (_) - "Window and buffer change hook which quits Corfu." - (unless (corfu--range-valid-p) - (corfu-quit))) - -(defun corfu--post-command () - "Refresh Corfu after last command." - (if (corfu--continue-p) - (corfu--exhibit) - (corfu-quit)) - (when corfu-auto - (corfu--auto-post-command))) - -(defun corfu--goto (index) - "Go to candidate with INDEX." - (setq corfu--index (max corfu--preselect (min index (1- corfu--total))))) - -(defun corfu--exit-function (str status cands) - "Call the `:exit-function' with STR and STATUS. -Lookup STR in CANDS to restore text properties." - (when-let ((exit (plist-get completion-extra-properties :exit-function))) - (funcall exit (or (car (member str cands)) str) status))) - -(defun corfu--done (str status cands) - "Exit completion and call the exit function with STR and STATUS. -Lookup STR in CANDS to restore text properties." - (let ((completion-extra-properties (nth 4 completion-in-region--data))) - ;; For successful completions, amalgamate undo operations, - ;; such that completion can be undone in a single step. - (undo-amalgamate-change-group corfu--change-group) - (corfu-quit) - (corfu--exit-function str status cands))) - -(defun corfu--setup (beg end table pred) - "Setup Corfu completion state. -See `completion-in-region' for the arguments BEG, END, TABLE, PRED." - (setq beg (if (markerp beg) beg (copy-marker beg)) - end (if (and (markerp end) (marker-insertion-type end)) end (copy-marker end t)) - completion-in-region--data (list beg end table pred completion-extra-properties)) - (completion-in-region-mode 1) - (activate-change-group (setq corfu--change-group (prepare-change-group))) - (setcdr (assq #'completion-in-region-mode minor-mode-overriding-map-alist) corfu-map) - (add-hook 'pre-command-hook #'corfu--prepare nil 'local) - (add-hook 'window-selection-change-functions #'corfu--window-change nil 'local) - (add-hook 'window-buffer-change-functions #'corfu--window-change nil 'local) - (add-hook 'post-command-hook #'corfu--post-command) - ;; Disable default post-command handling, since we have our own - ;; checks in `corfu--post-command'. - (remove-hook 'post-command-hook #'completion-in-region--postch) - (let ((sym (make-symbol "corfu--teardown")) - (buf (current-buffer))) - (fset sym (lambda () - ;; Ensure that the tear-down runs in the correct buffer, if still alive. - (unless completion-in-region-mode - (remove-hook 'completion-in-region-mode-hook sym) - (corfu--teardown buf)))) - (add-hook 'completion-in-region-mode-hook sym))) - -(defun corfu--in-region (&rest args) - "Corfu completion in region function called with ARGS." - ;; XXX We can get an endless loop when `completion-in-region-function' is set - ;; globally to `corfu--in-region'. This should never happen. - (apply (if (corfu--popup-support-p) #'corfu--in-region-1 - (default-value 'completion-in-region-function)) - args)) - -(defun corfu--in-region-1 (beg end table &optional pred) - "Complete in region, see `completion-in-region' for BEG, END, TABLE, PRED." - (barf-if-buffer-read-only) - ;; Restart the completion. This can happen for example if C-M-/ - ;; (`dabbrev-completion') is pressed while the Corfu popup is already open. - (when completion-in-region-mode (corfu-quit)) - (let* ((pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (metadata (completion-metadata (substring str 0 pt) table pred)) - (threshold (completion--cycle-threshold metadata)) - (completion-in-region-mode-predicate - (or completion-in-region-mode-predicate #'always))) - (pcase (completion-try-completion str table pred pt metadata) - ('nil (corfu--message "No match") nil) - ('t (goto-char end) - (corfu--message "Sole match") - (if (eq corfu-on-exact-match 'show) - (corfu--setup beg end table pred) - (corfu--exit-function - str 'finished - (alist-get 'corfu--candidates (corfu--recompute str pt table pred)))) - t) - (`(,newstr . ,newpt) - (setq beg (if (markerp beg) beg (copy-marker beg)) - end (copy-marker end t)) - (corfu--replace beg end newstr) - (goto-char (+ beg newpt)) - (let* ((state (corfu--recompute newstr newpt table pred)) - (base (alist-get 'corfu--base state)) - (total (alist-get 'corfu--total state)) - (candidates (alist-get 'corfu--candidates state))) - (if (= total 1) - ;; If completion is finished and cannot be further completed, and - ;; the value of `corfu-on-exact-match' is not 'show, return - ;; 'finished. Otherwise setup the Corfu popup. - (if (or (eq corfu-on-exact-match 'show) - (consp (completion-try-completion - newstr table pred newpt - (completion-metadata newstr table pred)))) - (corfu--setup beg end table pred) - (corfu--exit-function newstr 'finished candidates)) - (if (or (= total 0) (not threshold) - (and (not (eq threshold t)) (< threshold total))) - (corfu--setup beg end table pred) - (corfu--cycle-candidates total candidates (+ (length base) beg) end) - ;; Do not show Corfu when "trivially" cycling, i.e., - ;; when the completion is finished after the candidate. - (unless (equal (completion-boundaries (car candidates) table pred "") - '(0 . 0)) - (corfu--setup beg end table pred))))) - t)))) - -(defun corfu--message (&rest msg) - "Show completion MSG." - (let (message-log-max) (apply #'message msg))) - -(defun corfu--cycle-candidates (total cands beg end) - "Cycle between TOTAL number of CANDS. -See `completion-in-region' for the arguments BEG, END, TABLE, PRED." - (let* ((idx 0) - (map (make-sparse-keymap)) - (replace (lambda () - (interactive) - (corfu--replace beg end (nth idx cands)) - (corfu--message "Cycling %d/%d..." (1+ idx) total) - (setq idx (mod (1+ idx) total)) - (set-transient-map map)))) - (define-key map [remap completion-at-point] replace) - (define-key map [remap corfu-complete] replace) - (define-key map (vector last-command-event) replace) - (funcall replace))) - -(defun corfu--auto-complete-deferred (&optional tick) - "Initiate auto completion if TICK did not change." - (when (and (not completion-in-region-mode) - (or (not tick) (equal tick (corfu--auto-tick)))) - (pcase (while-no-input ;; Interruptible Capf query - (run-hook-wrapped 'completion-at-point-functions #'corfu--capf-wrapper)) - (`(,fun ,beg ,end ,table . ,plist) - (let ((completion-in-region-mode-predicate - (lambda () - (when-let ((newbeg (car-safe (funcall fun)))) - (= newbeg beg)))) - (completion-extra-properties plist)) - (corfu--setup beg end table (plist-get plist :predicate)) - (corfu--exhibit 'auto)))))) - -(defun corfu--auto-post-command () - "Post command hook which initiates auto completion." - (cancel-timer corfu--auto-timer) - (if (and (not completion-in-region-mode) - (not defining-kbd-macro) - (not buffer-read-only) - (corfu--match-symbol-p corfu-auto-commands this-command) - (corfu--popup-support-p)) - (if (<= corfu-auto-delay 0) - (corfu--auto-complete-deferred) - ;; Do not use `timer-set-idle-time' since this leads to - ;; unpredictable pauses, in particular with `flyspell-mode'. - (timer-set-time corfu--auto-timer - (timer-relative-time nil corfu-auto-delay)) - (timer-set-function corfu--auto-timer #'corfu--auto-complete-deferred - (list (corfu--auto-tick))) - (timer-activate corfu--auto-timer)))) - -(defun corfu--auto-tick () - "Return the current tick/status of the buffer. -Auto completion is only performed if the tick did not change." - (list (selected-window) (current-buffer) (buffer-chars-modified-tick) (point))) - -(cl-defgeneric corfu--popup-show (pos off width lines &optional curr lo bar) - "Show LINES as popup at POS - OFF. -WIDTH is the width of the popup. -The current candidate CURR is highlighted. -A scroll bar is displayed from LO to LO+BAR." - (let ((lh (default-line-height))) - (with-current-buffer (corfu--make-buffer " *corfu*") - (let* ((ch (default-line-height)) - (cw (default-font-width)) - ;; bug#74214, bug#37755, bug#37689: Even for larger fringes, fringe - ;; bitmaps can only have a width between 1 and 16. Therefore we - ;; restrict the fringe width to 16 pixel. This restriction may - ;; cause problem on HDPi systems. Hopefully Emacs will adopt - ;; larger fringe bitmaps in the future and lift the restriction. - (ml (min 16 (ceiling (* cw corfu-left-margin-width)))) - (mr (min 16 (ceiling (* cw corfu-right-margin-width)))) - (bw (min mr (ceiling (* cw corfu-bar-width)))) - (fringe (display-graphic-p)) - (marginl (and (not fringe) (propertize " " 'display `(space :width (,ml))))) - (sbar (if fringe - #(" " 0 1 (display (right-fringe corfu--bar corfu--bar))) - (concat - (propertize " " 'display `(space :align-to (- right (,bw)))) - (propertize " " 'face 'corfu-bar 'display `(space :width (,bw)))))) - (cbar (if fringe - #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) - 1 2 (display (right-fringe corfu--bar corfu--cbar))) - sbar)) - (cmargin (and fringe - #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) - 1 2 (display (right-fringe corfu--nil corfu-current))))) - (pos (posn-x-y pos)) - (width (+ (* width cw) (if fringe 0 (+ ml mr)))) - ;; XXX HACK: Minimum popup height must be at least 1 line of the - ;; parent frame (gh:minad/corfu#261). - (height (max lh (* (length lines) ch))) - (edge (window-inside-pixel-edges)) - (border (alist-get 'internal-border-width corfu--frame-parameters)) - (x (max 0 (min (+ (car edge) (- (or (car pos) 0) ml (* cw off) border)) - (- (frame-pixel-width) width)))) - (yb (+ (cadr edge) (window-tab-line-height) (or (cdr pos) 0) lh)) - (y (if (> (+ yb (* corfu-count ch) lh lh) (frame-pixel-height)) - (- yb height lh border border) - yb)) - (row 0) - (bmp (logxor (1- (ash 1 mr)) (1- (ash 1 bw))))) - (setq left-fringe-width (if fringe ml 0) right-fringe-width (if fringe mr 0)) - ;; Define an inverted corfu--bar face - (unless (equal (and (facep 'corfu--bar) (face-attribute 'corfu--bar :foreground)) - (face-attribute 'corfu-bar :background)) - (set-face-attribute (make-face 'corfu--bar) nil - :foreground (face-attribute 'corfu-bar :background))) - (unless (or (= right-fringe-width 0) (eq (get 'corfu--bar 'corfu--bmp) bmp)) - (put 'corfu--bar 'corfu--bmp bmp) - (define-fringe-bitmap 'corfu--bar (vector (lognot bmp)) 1 mr '(top periodic)) - (define-fringe-bitmap 'corfu--nil []) - ;; Fringe bitmaps require symbol face specification, define internal face. - (set-face-attribute (make-face 'corfu--cbar) nil - :inherit '(corfu--bar corfu-current))) - (with-silent-modifications - (delete-region (point-min) (point-max)) - (apply #'insert - (cl-loop for line in lines collect - (let ((str (concat - marginl line - (if (and lo (<= lo row (+ lo bar))) - (if (eq row curr) cbar sbar) - (and (eq row curr) cmargin)) - "\n"))) - (when (eq row curr) - (add-face-text-property - 0 (length str) 'corfu-current 'append str)) - (cl-incf row) - str))) - (goto-char (point-min))) - (setq corfu--frame (corfu--make-frame corfu--frame x y width height)))))) - -(cl-defgeneric corfu--popup-hide () - "Hide Corfu popup." - (corfu--hide-frame corfu--frame)) - -(cl-defgeneric corfu--popup-support-p () - "Return non-nil if child frames are supported." - (or (display-graphic-p) - ;; Upcoming feature: Gerd Möllmann's child frame support on TTY. - (featurep 'tty-child-frames))) - -(cl-defgeneric corfu--insert (status) - "Insert current candidate, exit with STATUS if non-nil." - ;; XXX There is a small bug here, depending on interpretation. - ;; When completing "~/emacs/master/li|/calc" where "|" is the - ;; cursor, then the candidate only includes the prefix - ;; "~/emacs/master/lisp/", but not the suffix "/calc". Default - ;; completion has the same problem when selecting in the - ;; *Completions* buffer. See bug#48356. - (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) - (str (concat corfu--base (nth corfu--index corfu--candidates)))) - (corfu--replace beg end str) - (corfu--goto -1) ;; Reset selection, completion may continue. - (when status (corfu--done str status nil)) - str)) - -(cl-defgeneric corfu--affixate (cands) - "Annotate CANDS with annotation function." - (let* ((extras (nth 4 completion-in-region--data)) - (dep (plist-get extras :company-deprecated)) - (mf (let ((completion-extra-properties extras)) - (run-hook-with-args-until-success 'corfu-margin-formatters corfu--metadata)))) - (setq cands - (if-let ((aff (corfu--metadata-get 'affixation-function))) - (funcall aff cands) - (if-let ((ann (corfu--metadata-get 'annotation-function))) - (cl-loop for cand in cands collect - (let ((suff (or (funcall ann cand) ""))) - ;; The default completion UI adds the - ;; `completions-annotations' face if no other faces are - ;; present. We use a custom `corfu-annotations' face to - ;; allow further styling which fits better for popups. - (unless (text-property-not-all 0 (length suff) 'face nil suff) - (setq suff (propertize suff 'face 'corfu-annotations))) - (list cand "" suff))) - (cl-loop for cand in cands collect (list cand "" ""))))) - (cl-loop for x in cands for (c . _) = x do - (when mf - (setf (cadr x) (funcall mf c))) - (when (and dep (funcall dep c)) - (setcar x (setq c (substring c))) - (add-face-text-property 0 (length c) 'corfu-deprecated 'append c))) - (cons mf cands))) - -(cl-defgeneric corfu--prepare () - "Insert selected candidate unless command is marked to continue completion." - (when corfu--preview-ov - (delete-overlay corfu--preview-ov) - (setq corfu--preview-ov nil)) - ;; Ensure that state is initialized before next Corfu command - (when (and (symbolp this-command) (string-prefix-p "corfu-" (symbol-name this-command))) - (corfu--update)) - ;; If the next command is not listed in `corfu-continue-commands', insert the - ;; currently selected candidate and bail out of completion. This way you can - ;; continue typing after selecting a candidate. The candidate will be inserted - ;; and your new input will be appended. - (and (corfu--preview-current-p) (eq corfu-preview-current 'insert) - ;; See the comment about `overriding-local-map' in `corfu--post-command'. - (not (or overriding-terminal-local-map - (corfu--match-symbol-p corfu-continue-commands this-command))) - (corfu--insert 'exact))) - -(cl-defgeneric corfu--exhibit (&optional auto) - "Exhibit Corfu UI. -AUTO is non-nil when initializing auto completion." - (pcase-let ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (`(,str . ,pt) (corfu--update 'interruptible))) - (cond - ;; 1) Single exactly matching candidate and no further completion is possible. - ((and (not (equal str "")) - (equal (car corfu--candidates) str) (not (cdr corfu--candidates)) - (not (eq corfu-on-exact-match 'show)) - (or auto corfu-on-exact-match) - (not (consp (completion-try-completion str table pred pt corfu--metadata)))) - ;; Quit directly when initializing auto completion. - (if (or auto (eq corfu-on-exact-match 'quit)) - (corfu-quit) - (corfu--done (car corfu--candidates) 'finished nil))) - ;; 2) There exist candidates => Show candidates popup. - (corfu--candidates - (let ((pos (posn-at-point (+ beg (length corfu--base))))) - (corfu--preview-current beg end) - (corfu--candidates-popup pos))) - ;; 3) No candidates & `corfu-quit-no-match' & initialized => Confirmation popup. - ((pcase-exhaustive corfu-quit-no-match - ('t nil) - ('nil corfu--input) - ('separator (seq-contains-p (car corfu--input) corfu-separator))) - (corfu--popup-show (posn-at-point beg) 0 8 '(#("No match" 0 8 (face italic))))) - ;; 4) No candidates & auto completing or initialized => Quit. - ((or auto corfu--input) (corfu-quit))))) - -(cl-defgeneric corfu--teardown (buffer) - "Tear-down Corfu in BUFFER, which might be dead at this point." - (corfu--popup-hide) - (when corfu--preview-ov (delete-overlay corfu--preview-ov)) - (remove-hook 'post-command-hook #'corfu--post-command) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (remove-hook 'window-selection-change-functions #'corfu--window-change 'local) - (remove-hook 'window-buffer-change-functions #'corfu--window-change 'local) - (remove-hook 'pre-command-hook #'corfu--prepare 'local) - (accept-change-group corfu--change-group))) - (cl-loop for (k . v) in corfu--initial-state do (set k v))) - -(defun corfu-sort-length-alpha (list) - "Sort LIST by length and alphabetically." - (sort list #'corfu--length-string<)) - -(defun corfu-quit () - "Quit Corfu completion." - (interactive) - (completion-in-region-mode -1)) - -(defun corfu-reset () - "Reset Corfu completion. -This command can be executed multiple times by hammering the ESC key. If a -candidate is selected, unselect the candidate. Otherwise reset the input. If -there hasn't been any input, then quit." - (interactive) - (if (/= corfu--index corfu--preselect) - (progn - (corfu--goto -1) - (setq this-command #'corfu-first)) - ;; Cancel all changes and start new change group. - (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) - (str (buffer-substring-no-properties beg end))) - (cancel-change-group corfu--change-group) - (activate-change-group (setq corfu--change-group (prepare-change-group))) - ;; Quit when resetting, when input did not change. - (when (equal str (buffer-substring-no-properties beg end)) - (corfu-quit))))) - -(defun corfu-insert-separator () - "Insert a separator character, inhibiting quit on completion boundary. -If the currently selected candidate is previewed, jump to the input -prompt instead. See `corfu-separator' for more details." - (interactive) - (if (not (corfu--preview-current-p)) - (insert corfu-separator) - (corfu--goto -1) - (unless (or (= (car completion-in-region--data) (point)) - (= (char-before) corfu-separator)) - (insert corfu-separator)))) - -(defun corfu-next (&optional n) - "Go forward N candidates." - (interactive "p") - (let ((index (+ corfu--index (or n 1)))) - (corfu--goto - (cond - ((not corfu-cycle) index) - ((= corfu--total 0) -1) - ((< corfu--preselect 0) (1- (mod (1+ index) (1+ corfu--total)))) - (t (mod index corfu--total)))))) - -(defun corfu-previous (&optional n) - "Go backward N candidates." - (interactive "p") - (corfu-next (- (or n 1)))) - -(defun corfu-scroll-down (&optional n) - "Go back by N pages." - (interactive "p") - (corfu--goto (max 0 (- corfu--index (* (or n 1) corfu-count))))) - -(defun corfu-scroll-up (&optional n) - "Go forward by N pages." - (interactive "p") - (corfu-scroll-down (- (or n 1)))) - -(defun corfu-first () - "Go to first candidate. -If the first candidate is already selected, go to the prompt." - (interactive) - (corfu--goto (if (> corfu--index 0) 0 -1))) - -(defun corfu-last () - "Go to last candidate." - (interactive) - (corfu--goto (1- corfu--total))) - -(defun corfu-prompt-beginning (arg) - "Move to beginning of the prompt line. -If the point is already the beginning of the prompt move to the -beginning of the line. If ARG is not 1 or nil, move backward ARG - 1 -lines first." - (interactive "^p") - (let ((beg (car completion-in-region--data))) - (if (or (not (eq arg 1)) - (and (= corfu--preselect corfu--index) (= (point) beg))) - (move-beginning-of-line arg) - (corfu--goto -1) - (goto-char beg)))) - -(defun corfu-prompt-end (arg) - "Move to end of the prompt line. -If the point is already the end of the prompt move to the end of -the line. If ARG is not 1 or nil, move forward ARG - 1 lines -first." - (interactive "^p") - (let ((end (cadr completion-in-region--data))) - (if (or (not (eq arg 1)) - (and (= corfu--preselect corfu--index) (= (point) end))) - (move-end-of-line arg) - (corfu--goto -1) - (goto-char end)))) - -(defun corfu-complete () - "Complete current input. -If a candidate is selected, insert it. Otherwise invoke -`corfu-expand'. Return non-nil if the input has been expanded." - (interactive) - (if (< corfu--index 0) - (corfu-expand) - ;; Continue completion with selected candidate. Exit with status 'finished - ;; if input is a valid match and no further completion is - ;; possible. Additionally treat completion as finished if at the end of a - ;; boundary, even if other longer candidates would still match, since the - ;; user invoked `corfu-complete' with an explicitly selected candidate! - (pcase-let ((`(,_beg ,_end ,table ,pred . ,_) completion-in-region--data) - (newstr (corfu--insert nil))) - (and (test-completion newstr table pred) - (or (not (consp (completion-try-completion - newstr table pred (length newstr) - (completion-metadata newstr table pred)))) - (equal (completion-boundaries newstr table pred "") '(0 . 0))) - (corfu--done newstr 'finished nil)) - t))) - -(defun corfu-expand () - "Expands the common prefix of all candidates. -If the currently selected candidate is previewed, invoke -`corfu-complete' instead. Expansion relies on the completion -styles via `completion-try-completion'. Return non-nil if the -input has been expanded." - (interactive) - (if (corfu--preview-current-p) - (corfu-complete) - (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (metadata (completion-metadata (substring str 0 pt) table pred))) - (pcase (completion-try-completion str table pred pt metadata) - ('t - (goto-char end) - (corfu--done str 'finished corfu--candidates) - t) - ((and `(,newstr . ,newpt) (guard (not (and (= pt newpt) (equal newstr str))))) - (corfu--replace beg end newstr) - (goto-char (+ beg newpt)) - ;; Exit with status 'finished if input is a valid match - ;; and no further completion is possible. - (and (test-completion newstr table pred) - (not (consp (completion-try-completion - newstr table pred newpt - (completion-metadata (substring newstr 0 newpt) table pred)))) - (corfu--done newstr 'finished corfu--candidates)) - t))))) - -(defun corfu-insert () - "Insert current candidate. -Quit if no candidate is selected." - (interactive) - (if (>= corfu--index 0) - (corfu--insert 'finished) - (corfu-quit))) - -(defun corfu-send () - "Insert current candidate and send it when inside comint or eshell." - (interactive) - (corfu-insert) - (cond - ((and (derived-mode-p 'eshell-mode) (fboundp 'eshell-send-input)) - (eshell-send-input)) - ((and (derived-mode-p 'comint-mode) (fboundp 'comint-send-input)) - (comint-send-input)))) - -;;;###autoload -(define-minor-mode corfu-mode - "COmpletion in Region FUnction." - :group 'corfu :keymap corfu-mode-map - (cond - (corfu-mode - (and corfu-auto (add-hook 'post-command-hook #'corfu--auto-post-command nil 'local)) - (setq-local completion-in-region-function #'corfu--in-region)) - (t - (remove-hook 'post-command-hook #'corfu--auto-post-command 'local) - (kill-local-variable 'completion-in-region-function)))) - -(defcustom global-corfu-modes t - "List of modes where Corfu should be enabled by `global-corfu-mode'. -The variable can either be t, nil or a list of t, nil, mode -symbols or elements of the form (not modes). Examples: - - Enable everywhere, except in Org: ((not org-mode) t). - - Enable in programming modes except Python: ((not python-mode) prog-mode). - - Enable only in text modes: (text-mode)." - :type '(choice (const t) (repeat sexp)) - :group 'corfu) - -;; TODO use `:predicate' on Emacs 29 -(defcustom global-corfu-minibuffer t - "Corfu should be enabled in the minibuffer by `global-corfu-mode'. -The variable can either be t, nil or a custom predicate function. If -the variable is set to t, Corfu is only enabled if the minibuffer has -local `completion-at-point-functions'." - :type '(choice (const t) (const nil) function) - :group 'corfu) - -;;;###autoload -(define-globalized-minor-mode global-corfu-mode - corfu-mode corfu--on - :group 'corfu - (remove-hook 'minibuffer-setup-hook #'corfu--minibuffer-on) - (when (and global-corfu-mode global-corfu-minibuffer) - (add-hook 'minibuffer-setup-hook #'corfu--minibuffer-on 100))) - -(defun corfu--on () - "Enable `corfu-mode' in the current buffer respecting `global-corfu-modes'." - (when (and (not noninteractive) (not (eq (aref (buffer-name) 0) ?\s)) - ;; TODO use `:predicate' on Emacs 29 - (or (eq t global-corfu-modes) - (eq t (cl-loop for p in global-corfu-modes thereis - (pcase-exhaustive p - ('t t) - ('nil 0) - ((pred symbolp) (and (derived-mode-p p) t)) - (`(not . ,m) (and (seq-some #'derived-mode-p m) 0))))))) - (corfu-mode 1))) - -(defun corfu--minibuffer-on () - "Enable `corfu-mode' in the minibuffer respecting `global-corfu-minibuffer'." - (when (and global-corfu-minibuffer (not noninteractive) - (if (functionp global-corfu-minibuffer) - (funcall global-corfu-minibuffer) - (local-variable-p 'completion-at-point-functions))) - (corfu-mode 1))) - -;; Do not show Corfu commands with M-X -(dolist (sym '(corfu-next corfu-previous corfu-first corfu-last corfu-quit corfu-reset - corfu-complete corfu-insert corfu-scroll-up corfu-scroll-down corfu-expand - corfu-send corfu-insert-separator corfu-prompt-beginning corfu-prompt-end - corfu-info-location corfu-info-documentation ;; autoloads in corfu-info.el - corfu-quick-jump corfu-quick-insert corfu-quick-complete)) ;; autoloads in corfu-quick.el - (put sym 'completion-predicate #'ignore)) - -(defun corfu--capf-wrapper-advice (orig fun which) - "Around advice for `completion--capf-wrapper'. -The ORIG function takes the FUN and WHICH arguments." - (if corfu-mode (corfu--capf-wrapper fun t) (funcall orig fun which))) - -(defun corfu--eldoc-advice () - "Return non-nil if Corfu is currently not active." - (not (and corfu-mode completion-in-region-mode))) - -;; Install advice which fixes `completion--capf-wrapper', such that it respects -;; the completion styles for non-exclusive Capfs. See also the fixme comment in -;; the `completion--capf-wrapper' function in minibuffer.el. -(advice-add #'completion--capf-wrapper :around #'corfu--capf-wrapper-advice) - -;; Register Corfu with ElDoc -(advice-add #'eldoc-display-message-no-interference-p - :before-while #'corfu--eldoc-advice) -(eldoc-add-command #'corfu-complete #'corfu-insert #'corfu-expand #'corfu-send) - -(provide 'corfu) -;;; corfu.el ends here diff --git a/emacs/elpa/corfu-20241112.830/corfu.elc b/emacs/elpa/corfu-20241112.830/corfu.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-autoloads.el b/emacs/elpa/corfu-20241115.528/corfu-autoloads.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-echo.el b/emacs/elpa/corfu-20241115.528/corfu-echo.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-echo.elc b/emacs/elpa/corfu-20241115.528/corfu-echo.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-history.el b/emacs/elpa/corfu-20241115.528/corfu-history.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-history.elc b/emacs/elpa/corfu-20241115.528/corfu-history.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-indexed.el b/emacs/elpa/corfu-20241115.528/corfu-indexed.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-indexed.elc b/emacs/elpa/corfu-20241115.528/corfu-indexed.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-info.el b/emacs/elpa/corfu-20241115.528/corfu-info.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-info.elc b/emacs/elpa/corfu-20241115.528/corfu-info.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241115.528/corfu-pkg.el b/emacs/elpa/corfu-20241115.528/corfu-pkg.el @@ -0,0 +1,11 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "corfu" "20241115.528" + "COmpletion in Region FUnction." + '((emacs "28.1") + (compat "30")) + :url "https://github.com/minad/corfu" + :commit "1529c30e2503c4a7e776201f190377cec3a6acd2" + :revdesc "1529c30e2503" + :keywords '("abbrev" "convenience" "matching" "completion" "text") + :authors '(("Daniel Mendler" . "mail@daniel-mendler.de")) + :maintainers '(("Daniel Mendler" . "mail@daniel-mendler.de"))) diff --git a/emacs/elpa/corfu-20241112.830/corfu-popupinfo.el b/emacs/elpa/corfu-20241115.528/corfu-popupinfo.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-popupinfo.elc b/emacs/elpa/corfu-20241115.528/corfu-popupinfo.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241112.830/corfu-quick.el b/emacs/elpa/corfu-20241115.528/corfu-quick.el diff --git a/emacs/elpa/corfu-20241112.830/corfu-quick.elc b/emacs/elpa/corfu-20241115.528/corfu-quick.elc Binary files differ. diff --git a/emacs/elpa/corfu-20241115.528/corfu.el b/emacs/elpa/corfu-20241115.528/corfu.el @@ -0,0 +1,1466 @@ +;;; corfu.el --- COmpletion in Region FUnction -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2024 Free Software Foundation, Inc. + +;; Author: Daniel Mendler <mail@daniel-mendler.de> +;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> +;; Created: 2021 +;; Package-Version: 20241115.528 +;; Package-Revision: 1529c30e2503 +;; Package-Requires: ((emacs "28.1") (compat "30")) +;; URL: https://github.com/minad/corfu +;; Keywords: abbrev, convenience, matching, completion, text + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Corfu enhances in-buffer completion with a small completion popup. +;; The current candidates are shown in a popup below or above the +;; point. The candidates can be selected by moving up and down. +;; Corfu is the minimalistic in-buffer completion counterpart of the +;; Vertico minibuffer UI. + +;;; Code: + +(require 'compat) +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(defgroup corfu nil + "COmpletion in Region FUnction." + :link '(info-link :tag "Info Manual" "(corfu)") + :link '(url-link :tag "Website" "https://github.com/minad/corfu") + :link '(url-link :tag "Wiki" "https://github.com/minad/corfu/wiki") + :link '(emacs-library-link :tag "Library Source" "corfu.el") + :group 'convenience + :group 'tools + :group 'matching + :prefix "corfu-") + +(defcustom corfu-count 10 + "Maximal number of candidates to show." + :type 'natnum) + +(defcustom corfu-scroll-margin 2 + "Number of lines at the top and bottom when scrolling. +The value should lie between 0 and corfu-count/2." + :type 'natnum) + +(defcustom corfu-min-width 15 + "Popup minimum width in characters." + :type 'natnum) + +(defcustom corfu-max-width 100 + "Popup maximum width in characters." + :type 'natnum) + +(defcustom corfu-cycle nil + "Enable cycling for `corfu-next' and `corfu-previous'." + :type 'boolean) + +(defcustom corfu-on-exact-match 'insert + "Configure how a single exact match should be handled. +- nil: No special handling, continue completion. +- insert: Insert candidate, quit and call the `:exit-function'. +- quit: Quit completion without further action. +- show: Initiate completion even for a single match only." + :type '(choice (const insert) (const show) (const quit) (const nil))) + +(defcustom corfu-continue-commands + ;; nil is undefined command + '(nil ignore universal-argument universal-argument-more digit-argument + "\\`corfu-" "\\`scroll-other-window") + "Continue Corfu completion after executing these commands. +The list can container either command symbols or regular expressions." + :type '(repeat (choice regexp symbol))) + +(defcustom corfu-preview-current 'insert + "Preview currently selected candidate. +If the variable has the value `insert', the candidate is automatically +inserted on further input." + :type '(choice boolean (const insert))) + +(defcustom corfu-preselect 'valid + "Configure if the prompt or first candidate is preselected. +- prompt: Always select the prompt. +- first: Always select the first candidate. +- valid: Only select the prompt if valid and not equal to the first candidate. +- directory: Like first, but select the prompt if it is a directory." + :type '(choice (const prompt) (const valid) (const first) (const directory))) + +(defcustom corfu-separator ?\s + "Component separator character. +The character used for separating components in the input. The presence +of this separator character will inhibit quitting at completion +boundaries, so that any further characters can be entered. To enter the +first separator character, call `corfu-insert-separator' (bound to M-SPC +by default). Useful for multi-component completion styles such as +Orderless." + :type 'character) + +(defcustom corfu-quit-at-boundary 'separator + "Automatically quit at completion boundary. +nil: Never quit at completion boundary. +t: Always quit at completion boundary. +separator: Quit at boundary if no `corfu-separator' has been inserted." + :type '(choice boolean (const separator))) + +(defcustom corfu-quit-no-match 'separator + "Automatically quit if no matching candidate is found. +When staying alive even if there is no match a warning message is +shown in the popup. +nil: Stay alive even if there is no match. +t: Quit if there is no match. +separator: Only stay alive if there is no match and +`corfu-separator' has been inserted." + :type '(choice boolean (const separator))) + +(defcustom corfu-left-margin-width 0.5 + "Width of the left margin in units of the character width." + :type 'float) + +(defcustom corfu-right-margin-width 0.5 + "Width of the right margin in units of the character width." + :type 'float) + +(defcustom corfu-bar-width 0.2 + "Width of the bar in units of the character width." + :type 'float) + +(defcustom corfu-margin-formatters nil + "Registry for margin formatter functions. +Each function of the list is called with the completion metadata as +argument until an appropriate formatter is found. The function should +return a formatter function, which takes the candidate string and must +return a string, possibly an icon. In order to preserve correct popup +alignment, the length and display width of the returned string must +precisely span the same number of characters of the fixed-width popup +font. For example the kind-icon package returns a string of length 3 +with a display width of 3 characters." + :type 'hook) + +(defcustom corfu-sort-function #'corfu-sort-length-alpha + "Default sorting function. +This function is used if the completion table does not specify a +`display-sort-function'." + :type `(choice + (const :tag "No sorting" nil) + (const :tag "By length and alpha" ,#'corfu-sort-length-alpha) + (function :tag "Custom function"))) + +(defcustom corfu-sort-override-function nil + "Override sort function which overrides the `display-sort-function'. +This function is used even if a completion table specifies its +own sort function." + :type '(choice (const nil) function)) + +(defcustom corfu-auto-prefix 3 + "Minimum length of prefix for auto completion. +The completion backend can override this with +:company-prefix-length. It is *not recommended* to use a small +prefix length (below 2), since this will create high load for +Emacs. See also `corfu-auto-delay'." + :type 'natnum) + +(defcustom corfu-auto-delay 0.2 + "Delay for auto completion. +It is *not recommended* to use a short delay or even 0, since +this will create high load for Emacs, in particular if executing +the completion backend is costly." + :type 'float) + +(defcustom corfu-auto-commands + '("self-insert-command\\'" "delete-backward-char\\'" "\\`backward-delete-char" + c-electric-colon c-electric-lt-gt c-electric-slash c-scope-operator) + "Commands which initiate auto completion. +The list can container either command symbols or regular expressions." + :type '(repeat (choice regexp symbol))) + +(defcustom corfu-auto nil + "Enable auto completion. +See also the settings `corfu-auto-delay', `corfu-auto-prefix' and +`corfu-auto-commands'." + :type 'boolean) + +(defgroup corfu-faces nil + "Faces used by Corfu." + :group 'corfu + :group 'faces) + +(defface corfu-default + '((((class color) (min-colors 88) (background dark)) :background "#191a1b") + (((class color) (min-colors 88) (background light)) :background "#f0f0f0") + (t :background "gray")) + "Default face, foreground and background colors used for the popup.") + +(defface corfu-current + '((((class color) (min-colors 88) (background dark)) + :background "#00415e" :foreground "white" :extend t) + (((class color) (min-colors 88) (background light)) + :background "#c0efff" :foreground "black" :extend t) + (t :background "blue" :foreground "white" :extend t)) + "Face used to highlight the currently selected candidate.") + +(defface corfu-bar + '((((class color) (min-colors 88) (background dark)) :background "#a8a8a8") + (((class color) (min-colors 88) (background light)) :background "#505050") + (t :background "gray")) + "The background color is used for the scrollbar indicator.") + +(defface corfu-border + '((((class color) (min-colors 88) (background dark)) :background "#323232") + (((class color) (min-colors 88) (background light)) :background "#d7d7d7") + (t :background "gray")) + "The background color used for the thin border.") + +(defface corfu-annotations + '((t :inherit completions-annotations)) + "Face used for annotations.") + +(defface corfu-deprecated + '((t :inherit shadow :strike-through t)) + "Face used for deprecated candidates.") + +(defvar-keymap corfu-mode-map + :doc "Keymap used when `corfu-mode' is active.") + +(defvar-keymap corfu-map + :doc "Keymap used when popup is shown." + "<remap> <move-beginning-of-line>" #'corfu-prompt-beginning + "<remap> <move-end-of-line>" #'corfu-prompt-end + "<remap> <beginning-of-buffer>" #'corfu-first + "<remap> <end-of-buffer>" #'corfu-last + "<remap> <scroll-down-command>" #'corfu-scroll-down + "<remap> <scroll-up-command>" #'corfu-scroll-up + "<remap> <next-line>" #'corfu-next + "<remap> <previous-line>" #'corfu-previous + "<remap> <completion-at-point>" #'corfu-complete + "<remap> <keyboard-escape-quit>" #'corfu-reset + "<down>" #'corfu-next + "<up>" #'corfu-previous + "M-n" #'corfu-next + "M-p" #'corfu-previous + "C-g" #'corfu-quit + "RET" #'corfu-insert + "TAB" #'corfu-complete + "M-TAB" #'corfu-expand + "M-g" 'corfu-info-location + "M-h" 'corfu-info-documentation + "M-SPC" #'corfu-insert-separator) + +(defvar corfu--auto-timer (timer-create) + "Auto completion timer.") + +(defvar corfu--candidates nil + "List of candidates.") + +(defvar corfu--metadata nil + "Completion metadata.") + +(defvar corfu--base "" + "Base string, which is concatenated with the candidate.") + +(defvar corfu--total 0 + "Length of the candidate list `corfu--candidates'.") + +(defvar corfu--hilit #'identity + "Lazy candidate highlighting function.") + +(defvar corfu--index -1 + "Index of current candidate or negative for prompt selection.") + +(defvar corfu--preselect -1 + "Index of preselected candidate, negative for prompt selection.") + +(defvar corfu--scroll 0 + "Scroll position.") + +(defvar corfu--input nil + "Cons of last prompt contents and point.") + +(defvar corfu--preview-ov nil + "Current candidate overlay.") + +(defvar corfu--change-group nil + "Undo change group.") + +(defvar corfu--frame nil + "Popup frame.") + +(defvar corfu--width 0 + "Popup width of current completion to reduce width fluctuations.") + +(defconst corfu--initial-state + (mapcar + (lambda (k) (cons k (symbol-value k))) + '(corfu--base + corfu--candidates + corfu--hilit + corfu--index + corfu--preselect + corfu--scroll + corfu--input + corfu--total + corfu--preview-ov + corfu--change-group + corfu--metadata + corfu--width)) + "Initial Corfu state.") + +(defvar corfu--frame-parameters + '((no-accept-focus . t) + (no-focus-on-map . t) + (min-width . t) + (min-height . t) + (border-width . 0) + (outer-border-width . 0) + (internal-border-width . 1) + (child-frame-border-width . 1) + (vertical-scroll-bars . nil) + (horizontal-scroll-bars . nil) + (menu-bar-lines . 0) + (tool-bar-lines . 0) + (tab-bar-lines . 0) + (no-other-frame . t) + (unsplittable . t) + (undecorated . t) + (cursor-type . nil) + (no-special-glyphs . t) + (desktop-dont-save . t)) + "Default child frame parameters.") + +(defvar corfu--buffer-parameters + '((mode-line-format . nil) + (header-line-format . nil) + (tab-line-format . nil) + (tab-bar-format . nil) + (frame-title-format . "") + (truncate-lines . t) + (cursor-in-non-selected-windows . nil) + (cursor-type . nil) + (show-trailing-whitespace . nil) + (display-line-numbers . nil) + (left-fringe-width . 0) + (right-fringe-width . 0) + (left-margin-width . 0) + (right-margin-width . 0) + (fringes-outside-margins . 0) + (fringe-indicator-alist (continuation) (truncation)) + (indicate-empty-lines . nil) + (indicate-buffer-boundaries . nil) + (buffer-read-only . t)) + "Default child frame buffer parameters.") + +(defvar corfu--mouse-ignore-map + (let ((map (make-sparse-keymap))) + (dotimes (i 7) + (dolist (k '(mouse down-mouse drag-mouse double-mouse triple-mouse)) + (keymap-set map (format "<%s-%s>" k (1+ i)) #'ignore))) + map) + "Ignore all mouse clicks.") + +(defun corfu--replace (beg end str) + "Replace range between BEG and END with STR." + (unless (equal str (buffer-substring-no-properties beg end)) + ;; bug#55205: completion--replace removed properties as an unwanted + ;; side-effect. We also don't want to leave text properties. + (completion--replace beg end (substring-no-properties str)))) + +(defun corfu--capf-wrapper (fun &optional prefix) + "Wrapper for `completion-at-point' FUN. +The wrapper determines if the Capf is applicable at the current +position and performs sanity checking on the returned result. +For non-exclusive Capfs wrapper additionally checks if the +current input can be completed successfully. PREFIX is a prefix +length override, set to t for manual completion." + (pcase (funcall fun) + ((and res `(,beg ,end ,table . ,plist)) + (and (integer-or-marker-p beg) ;; Valid Capf result + (<= beg (point) end) ;; Sanity checking + ;; When auto completing, check the prefix length! + (let ((len (or prefix + (plist-get plist :company-prefix-length) + (- (point) beg)))) + (or (eq len t) (>= len corfu-auto-prefix))) + ;; For non-exclusive Capfs, check for valid completion. + (or (not (eq 'no (plist-get plist :exclusive))) + (let* ((str (buffer-substring-no-properties beg end)) + (pt (- (point) beg)) + (pred (plist-get plist :predicate)) + (md (completion-metadata (substring str 0 pt) table pred))) + ;; We use `completion-try-completion' to check if there are + ;; completions. The upstream `completion--capf-wrapper' uses + ;; `try-completion' which is incorrect since it only checks for + ;; prefix completions. + (completion-try-completion str table pred pt md))) + (cons fun res))))) + +(defun corfu--make-buffer (name) + "Create buffer with NAME." + (let ((fr face-remapping-alist) + (ls line-spacing) + (buffer (get-buffer-create name))) + (with-current-buffer buffer + ;;; XXX HACK install mouse ignore map + (use-local-map corfu--mouse-ignore-map) + (dolist (var corfu--buffer-parameters) + (set (make-local-variable (car var)) (cdr var))) + (setq-local face-remapping-alist (copy-tree fr) + line-spacing ls) + (cl-pushnew 'corfu-default (alist-get 'default face-remapping-alist)) + buffer))) + +(defvar x-gtk-resize-child-frames) ;; Not present on non-gtk builds +(defvar corfu--gtk-resize-child-frames + (let ((case-fold-search t)) + ;; XXX HACK to fix resizing on gtk3/gnome taken from posframe.el + ;; More information: + ;; * https://github.com/minad/corfu/issues/17 + ;; * https://gitlab.gnome.org/GNOME/mutter/-/issues/840 + ;; * https://lists.gnu.org/archive/html/emacs-devel/2020-02/msg00001.html + (and (string-match-p "gtk3" system-configuration-features) + (string-match-p "gnome\\|cinnamon" + (or (getenv "XDG_CURRENT_DESKTOP") + (getenv "DESKTOP_SESSION") "")) + 'resize-mode))) + +;; Function adapted from posframe.el by tumashu +(defun corfu--make-frame (frame x y width height) + "Show current buffer in child frame at X/Y with WIDTH/HEIGHT. +FRAME is the existing frame." + (when-let (((frame-live-p frame)) + (timer (frame-parameter frame 'corfu--hide-timer))) + (cancel-timer timer) + (set-frame-parameter frame 'corfu--hide-timer nil)) + (let* ((window-min-height 1) + (window-min-width 1) + (inhibit-redisplay t) + (x-gtk-resize-child-frames corfu--gtk-resize-child-frames) + (before-make-frame-hook) + (after-make-frame-functions) + (parent (window-frame))) + (unless (and (frame-live-p frame) + (eq (frame-parent frame) + (and (not (bound-and-true-p exwm--connection)) parent)) + ;; If there is more than one window, `frame-root-window' may + ;; return nil. Recreate the frame in this case. + (window-live-p (frame-root-window frame))) + (when frame (delete-frame frame)) + (setq frame (make-frame + `((parent-frame . ,parent) + (minibuffer . ,(minibuffer-window parent)) + (width . 0) (height . 0) (visibility . nil) + (right-fringe . ,right-fringe-width) + (left-fringe . ,left-fringe-width) + ,@corfu--frame-parameters)))) + ;; XXX HACK Setting the same frame-parameter/face-background is not a nop. + ;; Check before applying the setting. Without the check, the frame flickers + ;; on Mac. We have to apply the face background before adjusting the frame + ;; parameter, otherwise the border is not updated. + (let ((new (face-attribute 'corfu-border :background nil 'default))) + (unless (equal (face-attribute 'internal-border :background frame 'default) new) + (set-face-background 'internal-border new frame)) + ;; XXX The Emacs Mac Port does not support `internal-border', we also have + ;; to set `child-frame-border'. + (unless (or (not (facep 'child-frame-border)) + (equal (face-attribute 'child-frame-border :background frame 'default) new)) + (set-face-background 'child-frame-border new frame))) + ;; Reset frame parameters if they changed. For example `tool-bar-mode' + ;; overrides the parameter `tool-bar-lines' for every frame, including child + ;; frames. The child frame API is a pleasure to work with. It is full of + ;; lovely surprises. + (let* ((win (frame-root-window frame)) + (is (frame-parameters frame)) + (should `((background-color + . ,(face-attribute 'corfu-default :background nil 'default)) + (font . ,(frame-parameter parent 'font)) + (right-fringe . ,right-fringe-width) + (left-fringe . ,left-fringe-width) + ,@corfu--frame-parameters)) + (diff (cl-loop for p in should for (k . v) = p + unless (equal (alist-get k is) v) collect p))) + (when diff (modify-frame-parameters frame diff)) + ;; XXX HACK: `set-window-buffer' must be called to force fringe update. + (when (or diff (eq (window-buffer win) (current-buffer))) + (set-window-buffer win (current-buffer))) + ;; Disallow selection of root window (gh:minad/corfu#63) + (set-window-parameter win 'no-delete-other-windows t) + (set-window-parameter win 'no-other-window t) + ;; Mark window as dedicated to prevent frame reuse (gh:minad/corfu#60) + (set-window-dedicated-p win t)) + (redirect-frame-focus frame parent) + (set-frame-size frame width height t) + (pcase-let ((`(,px . ,py) (frame-position frame))) + (unless (and (= x px) (= y py)) + (set-frame-position frame x y)))) + (make-frame-visible frame) + ;; Unparent child frame if EXWM is used, otherwise EXWM buffers are drawn on + ;; top of the Corfu child frame. + (when (and (bound-and-true-p exwm--connection) (frame-parent frame)) + (set-frame-parameter frame 'parent-frame nil)) + frame) + +(defun corfu--hide-frame-deferred (frame) + "Deferred hiding of child FRAME." + (when (and (frame-live-p frame) (frame-visible-p frame)) + (set-frame-parameter frame 'corfu--hide-timer nil) + (make-frame-invisible frame) + (with-current-buffer (window-buffer (frame-root-window frame)) + (with-silent-modifications + (delete-region (point-min) (point-max)))))) + +(defun corfu--hide-frame (frame) + "Hide child FRAME." + (when (and (frame-live-p frame) (frame-visible-p frame) + (not (frame-parameter frame 'corfu--hide-timer))) + (set-frame-parameter frame 'corfu--hide-timer + (run-at-time 0 nil #'corfu--hide-frame-deferred frame)))) + +(defun corfu--move-to-front (elem list) + "Move ELEM to front of LIST." + ;; In contrast to Vertico, this function handles duplicates. See also the + ;; special deduplication function `corfu--delete-dups' based on + ;; `equal-including-properties' + (nconc (cl-loop for x in list if (equal x elem) collect x) + (delete elem list))) + +(defun corfu--filter-completions (&rest args) + "Compute all completions for ARGS with lazy highlighting." + (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) + (static-if (>= emacs-major-version 30) + (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) + (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) + (orig-flex (symbol-function #'completion-flex-all-completions)) + ((symbol-function #'completion-flex-all-completions) + (lambda (&rest args) + ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses + ;; the completion-score for sorting, which is applied during highlighting. + (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) + (apply orig-flex args)))) + ((symbol-function #'completion-pcm--hilit-commonality) + (lambda (pattern cands) + (setq completion-lazy-hilit-fn + (lambda (x) + ;; `completion-pcm--hilit-commonality' sometimes throws an internal error + ;; for example when entering "/sudo:://u". + (condition-case nil + (car (completion-pcm--hilit-commonality pattern (list x))) + (t x)))) + cands)) + ((symbol-function #'completion-hilit-commonality) + (lambda (cands prefix &optional base) + (setq completion-lazy-hilit-fn + (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) + (and cands (nconc cands base))))) + (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) + +(defsubst corfu--length-string< (x y) + "Sorting predicate which compares X and Y first by length then by `string<'." + (or (< (length x) (length y)) (and (= (length x) (length y)) (string< x y)))) + +(defmacro corfu--partition! (list form) + "Evaluate FORM for every element and partition LIST." + (cl-with-gensyms (head1 head2 tail1 tail2) + `(let* ((,head1 (cons nil nil)) + (,head2 (cons nil nil)) + (,tail1 ,head1) + (,tail2 ,head2)) + (while ,list + (if (let ((it (car ,list))) ,form) + (progn + (setcdr ,tail1 ,list) + (pop ,tail1)) + (setcdr ,tail2 ,list) + (pop ,tail2)) + (pop ,list)) + (setcdr ,tail1 (cdr ,head2)) + (setcdr ,tail2 nil) + (setq ,list (cdr ,head1))))) + +(defun corfu--move-prefix-candidates-to-front (field cands) + "Move CANDS which match prefix of FIELD to the beginning." + (let* ((word (substring field 0 + (seq-position field corfu-separator))) + (len (length word))) + (corfu--partition! + cands + (and (>= (length it) len) + (eq t (compare-strings word 0 len it 0 len + completion-ignore-case)))))) + +;; bug#6581: `equal-including-properties' uses `eq' for properties until 29.1. +;; Approximate by comparing `text-properties-at' position 0. +(defalias 'corfu--equal-including-properties + (static-if (< emacs-major-version 29) + (lambda (x y) + (and (equal x y) + (equal (text-properties-at 0 x) (text-properties-at 0 y)))) + #'equal-including-properties)) + +(defun corfu--delete-dups (list) + "Delete `equal-including-properties' consecutive duplicates from LIST." + (let ((beg list)) + (while (cdr beg) + (let ((end (cdr beg))) + (while (equal (car beg) (car end)) (pop end)) + ;; The deduplication is quadratic in the number of duplicates. We can + ;; avoid the quadratic complexity with a hash table which takes + ;; properties into account (available since Emacs 28). + (while (not (eq beg end)) + (let ((dup beg)) + (while (not (eq (cdr dup) end)) + (if (corfu--equal-including-properties (car beg) (cadr dup)) + (setcdr dup (cddr dup)) + (pop dup)))) + (pop beg))))) + list) + +(defun corfu--sort-function () + "Return the sorting function." + (or corfu-sort-override-function + (corfu--metadata-get 'display-sort-function) + corfu-sort-function)) + +(defun corfu--recompute (str pt table pred) + "Recompute state from STR, PT, TABLE and PRED." + (pcase-let* ((before (substring str 0 pt)) + (after (substring str pt)) + (corfu--metadata (completion-metadata before table pred)) + ;; bug#47678: `completion-boundaries' fails for `partial-completion' + ;; if the cursor is moved before the slashes of "~//". + ;; See also vertico.el which has the same issue. + (bounds (condition-case nil + (completion-boundaries before table pred after) + (t (cons 0 (length after))))) + (field (substring str (car bounds) (+ pt (cdr bounds)))) + (completing-file (eq (corfu--metadata-get 'category) 'file)) + (`(,all . ,hl) (corfu--filter-completions str table pred pt corfu--metadata)) + (base (or (when-let ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) + (corfu--base (substring str 0 base)) + (pre nil)) + ;; Filter the ignored file extensions. We cannot use modified predicate for + ;; this filtering, since this breaks the special casing in the + ;; `completion-file-name-table' for `file-exists-p' and `file-directory-p'. + (when completing-file (setq all (completion-pcm--filename-try-filter all))) + ;; Sort using the `display-sort-function' or the Corfu sort functions, and + ;; delete duplicates with respect to `equal-including-properties'. This is + ;; a deviation from the Vertico completion UI with more aggressive + ;; deduplication, where candidates are compared with `equal'. Corfu + ;; preserves candidates which differ in their text properties. Corfu tries + ;; to preserve text properties as much as possible, when calling the + ;; `:exit-function' to help Capfs with candidate disambiguation. This + ;; matters in particular for Lsp backends, which produce duplicates for + ;; overloaded methods. + (setq all (corfu--delete-dups (funcall (or (corfu--sort-function) #'identity) all)) + all (corfu--move-prefix-candidates-to-front field all)) + (when (and completing-file (not (string-suffix-p "/" field))) + (setq all (corfu--move-to-front (concat field "/") all))) + (setq all (corfu--move-to-front field all) + pre (if (or (eq corfu-preselect 'prompt) (not all) + (and completing-file (eq corfu-preselect 'directory) + (= (length corfu--base) (length str)) + (test-completion str table pred)) + (and (eq corfu-preselect 'valid) + (not (equal field (car all))) + (not (and completing-file (equal (concat field "/") (car all)))) + (test-completion str table pred))) + -1 0)) + `((corfu--base . ,corfu--base) + (corfu--metadata . ,corfu--metadata) + (corfu--candidates . ,all) + (corfu--total . ,(length all)) + (corfu--hilit . ,(or hl #'identity)) + (corfu--preselect . ,pre) + (corfu--index . ,(or (and (>= corfu--index 0) (/= corfu--index corfu--preselect) + (seq-position all (nth corfu--index corfu--candidates))) + pre))))) + +(defun corfu--update (&optional interruptible) + "Update state, optionally INTERRUPTIBLE." + (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) + (pt (- (point) beg)) + (str (buffer-substring-no-properties beg end)) + (input (cons str pt))) + (unless (equal corfu--input input) + ;; Redisplay such that the input is immediately shown before the expensive + ;; candidate recomputation (gh:minad/corfu#48). See also corresponding + ;; issue gh:minad/vertico#89. + (when interruptible (redisplay)) + ;; Bind non-essential=t to prevent Tramp from opening new connections, + ;; without the user explicitly requesting it via M-TAB. + (pcase (let ((non-essential t)) + ;; XXX Guard against errors during candidate generation. + ;; bug#61274: `dabbrev-capf' signals errors. + (condition-case err + (if interruptible + (while-no-input (corfu--recompute str pt table pred)) + (corfu--recompute str pt table pred)) + (error + (message "Corfu completion error: %s" (error-message-string err)) + t))) + ('nil (keyboard-quit)) + ((and state (pred consp)) + (setq corfu--input input) + (dolist (s state) (set (car s) (cdr s)))))) + input)) + +(defun corfu--match-symbol-p (pattern sym) + "Return non-nil if SYM is matching an element of the PATTERN list." + (cl-loop with case-fold-search = nil + for x in (and (symbolp sym) pattern) + thereis (if (symbolp x) + (eq sym x) + (string-match-p x (symbol-name sym))))) + +(defun corfu--metadata-get (prop) + "Return PROP from completion metadata." + ;; Marginalia and various icon packages advise `completion-metadata-get' to + ;; inject their annotations, but are meant only for minibuffer completion. + ;; Therefore call `completion-metadata-get' without advices here. + (let ((completion-extra-properties (nth 4 completion-in-region--data))) + (funcall (advice--cd*r (symbol-function (compat-function completion-metadata-get))) + corfu--metadata prop))) + +(defun corfu--format-candidates (cands) + "Format annotated CANDS." + (cl-loop for c in cands do + (cl-loop for s in-ref c do + (setf s (replace-regexp-in-string "[ \t]*\n[ \t]*" " " s)))) + (let* ((cw (cl-loop for x in cands maximize (string-width (car x)))) + (pw (cl-loop for x in cands maximize (string-width (cadr x)))) + (sw (cl-loop for x in cands maximize (string-width (caddr x)))) + (width (min (max corfu--width corfu-min-width (+ pw cw sw)) + ;; -4 because of margins and some additional safety + corfu-max-width (- (frame-width) 4))) + (trunc (not (display-graphic-p)))) + (setq corfu--width width) + (list pw width + (cl-loop + for (cand prefix suffix) in cands collect + (let ((s (concat + prefix (make-string (- pw (string-width prefix)) ?\s) cand + (when (> sw 0) + (make-string (max 0 (- width pw (string-width cand) + (string-width suffix))) + ?\s)) + suffix))) + (if trunc (truncate-string-to-width s width) s)))))) + +(defun corfu--compute-scroll () + "Compute new scroll position." + (let ((off (max (min corfu-scroll-margin (/ corfu-count 2)) 0)) + (corr (if (= corfu-scroll-margin (/ corfu-count 2)) (1- (mod corfu-count 2)) 0))) + (setq corfu--scroll (min (max 0 (- corfu--total corfu-count)) + (max 0 (+ corfu--index off 1 (- corfu-count)) + (min (- corfu--index off corr) corfu--scroll)))))) + +(defun corfu--candidates-popup (pos) + "Show candidates popup at POS." + (corfu--compute-scroll) + (pcase-let* ((last (min (+ corfu--scroll corfu-count) corfu--total)) + (bar (ceiling (* corfu-count corfu-count) corfu--total)) + (lo (min (- corfu-count bar 1) (floor (* corfu-count corfu--scroll) corfu--total))) + (`(,mf . ,acands) (corfu--affixate + (cl-loop repeat corfu-count + for c in (nthcdr corfu--scroll corfu--candidates) + collect (funcall corfu--hilit (substring c))))) + (`(,pw ,width ,fcands) (corfu--format-candidates acands)) + ;; Disable the left margin if a margin formatter is active. + (corfu-left-margin-width (if mf 0 corfu-left-margin-width))) + ;; Nonlinearity at the end and the beginning + (when (/= corfu--scroll 0) + (setq lo (max 1 lo))) + (when (/= last corfu--total) + (setq lo (min (- corfu-count bar 2) lo))) + (corfu--popup-show pos pw width fcands (- corfu--index corfu--scroll) + (and (> corfu--total corfu-count) lo) bar))) + +(defun corfu--range-valid-p () + "Check the completion range, return non-nil if valid." + (pcase-let ((buf (current-buffer)) + (pt (point)) + (`(,beg ,end . ,_) completion-in-region--data)) + (and beg end + (eq buf (marker-buffer beg)) (eq buf (window-buffer)) + (<= beg pt end) + (save-excursion (goto-char beg) (<= (pos-bol) pt (pos-eol)))))) + +(defun corfu--continue-p () + "Check if completion should continue after a command. +Corfu bails out if the current buffer changed unexpectedly or if +point moved out of range, see `corfu--range-valid-p'. Also the +input must satisfy the `completion-in-region-mode--predicate' and +the last command must be listed in `corfu-continue-commands'." + (and (corfu--range-valid-p) + ;; We keep Corfu alive if a `overriding-terminal-local-map' is + ;; installed, e.g., the `universal-argument-map'. It would be good to + ;; think about a better criterion instead. Unfortunately relying on + ;; `this-command' alone is insufficient, since the value of + ;; `this-command' gets clobbered in the case of transient keymaps. + (or overriding-terminal-local-map + ;; Check if it is an explicitly listed continue command + (corfu--match-symbol-p corfu-continue-commands this-command) + (pcase-let ((`(,beg ,end . ,_) completion-in-region--data)) + (and (or (not corfu--input) (< beg end)) ;; Check for empty input + (or (not corfu-quit-at-boundary) ;; Check separator or predicate + (and (eq corfu-quit-at-boundary 'separator) + (or (eq this-command #'corfu-insert-separator) + ;; with separator, any further chars allowed + (seq-contains-p (car corfu--input) corfu-separator))) + (funcall completion-in-region-mode--predicate))))))) + +(defun corfu--preview-current-p () + "Return t if the selected candidate is previewed." + (and corfu-preview-current (>= corfu--index 0) (/= corfu--index corfu--preselect))) + +(defun corfu--preview-current (beg end) + "Show current candidate as overlay given BEG and END." + (when (corfu--preview-current-p) + (setq beg (+ beg (length corfu--base)) + corfu--preview-ov (make-overlay beg end nil)) + (overlay-put corfu--preview-ov 'priority 1000) + (overlay-put corfu--preview-ov 'window (selected-window)) + (overlay-put corfu--preview-ov (if (= beg end) 'after-string 'display) + (nth corfu--index corfu--candidates)))) + +(defun corfu--window-change (_) + "Window and buffer change hook which quits Corfu." + (unless (corfu--range-valid-p) + (corfu-quit))) + +(defun corfu--post-command () + "Refresh Corfu after last command." + (if (corfu--continue-p) + (corfu--exhibit) + (corfu-quit)) + (when corfu-auto + (corfu--auto-post-command))) + +(defun corfu--goto (index) + "Go to candidate with INDEX." + (setq corfu--index (max corfu--preselect (min index (1- corfu--total))))) + +(defun corfu--exit-function (str status cands) + "Call the `:exit-function' with STR and STATUS. +Lookup STR in CANDS to restore text properties." + (when-let ((exit (plist-get completion-extra-properties :exit-function))) + (funcall exit (or (car (member str cands)) str) status))) + +(defun corfu--done (str status cands) + "Exit completion and call the exit function with STR and STATUS. +Lookup STR in CANDS to restore text properties." + (let ((completion-extra-properties (nth 4 completion-in-region--data))) + ;; For successful completions, amalgamate undo operations, + ;; such that completion can be undone in a single step. + (undo-amalgamate-change-group corfu--change-group) + (corfu-quit) + (corfu--exit-function str status cands))) + +(defun corfu--setup (beg end table pred) + "Setup Corfu completion state. +See `completion-in-region' for the arguments BEG, END, TABLE, PRED." + (setq beg (if (markerp beg) beg (copy-marker beg)) + end (if (and (markerp end) (marker-insertion-type end)) end (copy-marker end t)) + completion-in-region--data (list beg end table pred completion-extra-properties)) + (completion-in-region-mode 1) + (activate-change-group (setq corfu--change-group (prepare-change-group))) + (setcdr (assq #'completion-in-region-mode minor-mode-overriding-map-alist) corfu-map) + (add-hook 'pre-command-hook #'corfu--prepare nil 'local) + (add-hook 'window-selection-change-functions #'corfu--window-change nil 'local) + (add-hook 'window-buffer-change-functions #'corfu--window-change nil 'local) + (add-hook 'post-command-hook #'corfu--post-command) + ;; Disable default post-command handling, since we have our own + ;; checks in `corfu--post-command'. + (remove-hook 'post-command-hook #'completion-in-region--postch) + (let ((sym (make-symbol "corfu--teardown")) + (buf (current-buffer))) + (fset sym (lambda () + ;; Ensure that the tear-down runs in the correct buffer, if still alive. + (unless completion-in-region-mode + (remove-hook 'completion-in-region-mode-hook sym) + (corfu--teardown buf)))) + (add-hook 'completion-in-region-mode-hook sym))) + +(defun corfu--in-region (&rest args) + "Corfu completion in region function called with ARGS." + ;; XXX We can get an endless loop when `completion-in-region-function' is set + ;; globally to `corfu--in-region'. This should never happen. + (apply (if (corfu--popup-support-p) #'corfu--in-region-1 + (default-value 'completion-in-region-function)) + args)) + +(defun corfu--in-region-1 (beg end table &optional pred) + "Complete in region, see `completion-in-region' for BEG, END, TABLE, PRED." + (barf-if-buffer-read-only) + ;; Restart the completion. This can happen for example if C-M-/ + ;; (`dabbrev-completion') is pressed while the Corfu popup is already open. + (when completion-in-region-mode (corfu-quit)) + (let* ((pt (max 0 (- (point) beg))) + (str (buffer-substring-no-properties beg end)) + (metadata (completion-metadata (substring str 0 pt) table pred)) + (threshold (completion--cycle-threshold metadata)) + (completion-in-region-mode-predicate + (or completion-in-region-mode-predicate #'always))) + (pcase (completion-try-completion str table pred pt metadata) + ('nil (corfu--message "No match") nil) + ('t (goto-char end) + (corfu--message "Sole match") + (if (eq corfu-on-exact-match 'show) + (corfu--setup beg end table pred) + (corfu--exit-function + str 'finished + (alist-get 'corfu--candidates (corfu--recompute str pt table pred)))) + t) + (`(,newstr . ,newpt) + (setq beg (if (markerp beg) beg (copy-marker beg)) + end (copy-marker end t)) + (corfu--replace beg end newstr) + (goto-char (+ beg newpt)) + (let* ((state (corfu--recompute newstr newpt table pred)) + (base (alist-get 'corfu--base state)) + (total (alist-get 'corfu--total state)) + (candidates (alist-get 'corfu--candidates state))) + (if (= total 1) + ;; If completion is finished and cannot be further completed, and + ;; the value of `corfu-on-exact-match' is not 'show, return + ;; 'finished. Otherwise setup the Corfu popup. + (if (or (eq corfu-on-exact-match 'show) + (consp (completion-try-completion + newstr table pred newpt + (completion-metadata newstr table pred)))) + (corfu--setup beg end table pred) + (corfu--exit-function newstr 'finished candidates)) + (if (or (= total 0) (not threshold) + (and (not (eq threshold t)) (< threshold total))) + (corfu--setup beg end table pred) + (corfu--cycle-candidates total candidates (+ (length base) beg) end) + ;; Do not show Corfu when "trivially" cycling, i.e., + ;; when the completion is finished after the candidate. + (unless (equal (completion-boundaries (car candidates) table pred "") + '(0 . 0)) + (corfu--setup beg end table pred))))) + t)))) + +(defun corfu--message (&rest msg) + "Show completion MSG." + (let (message-log-max) (apply #'message msg))) + +(defun corfu--cycle-candidates (total cands beg end) + "Cycle between TOTAL number of CANDS. +See `completion-in-region' for the arguments BEG, END, TABLE, PRED." + (let* ((idx 0) + (map (make-sparse-keymap)) + (replace (lambda () + (interactive) + (corfu--replace beg end (nth idx cands)) + (corfu--message "Cycling %d/%d..." (1+ idx) total) + (setq idx (mod (1+ idx) total)) + (set-transient-map map)))) + (define-key map [remap completion-at-point] replace) + (define-key map [remap corfu-complete] replace) + (define-key map (vector last-command-event) replace) + (funcall replace))) + +(defun corfu--auto-complete-deferred (&optional tick) + "Initiate auto completion if TICK did not change." + (when (and (not completion-in-region-mode) + (or (not tick) (equal tick (corfu--auto-tick)))) + (pcase (while-no-input ;; Interruptible Capf query + (run-hook-wrapped 'completion-at-point-functions #'corfu--capf-wrapper)) + (`(,fun ,beg ,end ,table . ,plist) + (let ((completion-in-region-mode-predicate + (lambda () + (when-let ((newbeg (car-safe (funcall fun)))) + (= newbeg beg)))) + (completion-extra-properties plist)) + (corfu--setup beg end table (plist-get plist :predicate)) + (corfu--exhibit 'auto)))))) + +(defun corfu--auto-post-command () + "Post command hook which initiates auto completion." + (cancel-timer corfu--auto-timer) + (if (and (not completion-in-region-mode) + (not defining-kbd-macro) + (not buffer-read-only) + (corfu--match-symbol-p corfu-auto-commands this-command) + (corfu--popup-support-p)) + (if (<= corfu-auto-delay 0) + (corfu--auto-complete-deferred) + ;; Do not use `timer-set-idle-time' since this leads to + ;; unpredictable pauses, in particular with `flyspell-mode'. + (timer-set-time corfu--auto-timer + (timer-relative-time nil corfu-auto-delay)) + (timer-set-function corfu--auto-timer #'corfu--auto-complete-deferred + (list (corfu--auto-tick))) + (timer-activate corfu--auto-timer)))) + +(defun corfu--auto-tick () + "Return the current tick/status of the buffer. +Auto completion is only performed if the tick did not change." + (list (selected-window) (current-buffer) (buffer-chars-modified-tick) (point))) + +(cl-defgeneric corfu--popup-show (pos off width lines &optional curr lo bar) + "Show LINES as popup at POS - OFF. +WIDTH is the width of the popup. +The current candidate CURR is highlighted. +A scroll bar is displayed from LO to LO+BAR." + (let ((lh (default-line-height))) + (with-current-buffer (corfu--make-buffer " *corfu*") + (let* ((ch (default-line-height)) + (cw (default-font-width)) + ;; bug#74214, bug#37755, bug#37689: Even for larger fringes, fringe + ;; bitmaps can only have a width between 1 and 16. Therefore we + ;; restrict the fringe width to 16 pixel. This restriction may + ;; cause problem on HDPi systems. Hopefully Emacs will adopt + ;; larger fringe bitmaps in the future and lift the restriction. + (ml (min 16 (ceiling (* cw corfu-left-margin-width)))) + (mr (min 16 (ceiling (* cw corfu-right-margin-width)))) + (bw (min mr (ceiling (* cw corfu-bar-width)))) + (fringe (display-graphic-p)) + (marginl (and (not fringe) (propertize " " 'display `(space :width (,ml))))) + (sbar (if fringe + #(" " 0 1 (display (right-fringe corfu--bar corfu--bar))) + (concat + (propertize " " 'display `(space :align-to (- right (,bw)))) + (propertize " " 'face 'corfu-bar 'display `(space :width (,bw)))))) + (cbar (if fringe + #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) + 1 2 (display (right-fringe corfu--bar corfu--cbar))) + sbar)) + (cmargin (and fringe + #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) + 1 2 (display (right-fringe corfu--nil corfu-current))))) + (pos (posn-x-y pos)) + (width (+ (* width cw) (if fringe 0 (+ ml mr)))) + ;; XXX HACK: Minimum popup height must be at least 1 line of the + ;; parent frame (gh:minad/corfu#261). + (height (max lh (* (length lines) ch))) + (edge (window-inside-pixel-edges)) + (border (alist-get 'internal-border-width corfu--frame-parameters)) + (x (max 0 (min (+ (car edge) (- (or (car pos) 0) ml (* cw off) border)) + (- (frame-pixel-width) width)))) + (yb (+ (cadr edge) (window-tab-line-height) (or (cdr pos) 0) lh)) + (y (if (> (+ yb (* corfu-count ch) lh lh) (frame-pixel-height)) + (- yb height lh border border) + yb)) + (bmp (logxor (1- (ash 1 mr)) (1- (ash 1 bw))))) + (setq left-fringe-width (if fringe ml 0) right-fringe-width (if fringe mr 0)) + ;; Define an inverted corfu--bar face + (unless (equal (and (facep 'corfu--bar) (face-attribute 'corfu--bar :foreground)) + (face-attribute 'corfu-bar :background)) + (set-face-attribute (make-face 'corfu--bar) nil + :foreground (face-attribute 'corfu-bar :background))) + (unless (or (= right-fringe-width 0) (eq (get 'corfu--bar 'corfu--bmp) bmp)) + (put 'corfu--bar 'corfu--bmp bmp) + (define-fringe-bitmap 'corfu--bar (vector (lognot bmp)) 1 mr '(top periodic)) + (define-fringe-bitmap 'corfu--nil []) + ;; Fringe bitmaps require symbol face specification, define internal face. + (set-face-attribute (make-face 'corfu--cbar) nil + :inherit '(corfu--bar corfu-current))) + (with-silent-modifications + (delete-region (point-min) (point-max)) + (apply #'insert + (cl-loop for row from 0 for line in lines collect + (let ((str (concat marginl line + (if (and lo (<= lo row (+ lo bar))) + (if (eq row curr) cbar sbar) + (and (eq row curr) cmargin)) + "\n"))) + (when (eq row curr) + (add-face-text-property + 0 (length str) 'corfu-current 'append str)) + str))) + (goto-char (point-min))) + (setq corfu--frame (corfu--make-frame corfu--frame x y width height)))))) + +(cl-defgeneric corfu--popup-hide () + "Hide Corfu popup." + (corfu--hide-frame corfu--frame)) + +(cl-defgeneric corfu--popup-support-p () + "Return non-nil if child frames are supported." + (or (display-graphic-p) + ;; Upcoming feature: Gerd Möllmann's child frame support on TTY. + (featurep 'tty-child-frames))) + +(cl-defgeneric corfu--insert (status) + "Insert current candidate, exit with STATUS if non-nil." + ;; XXX There is a small bug here, depending on interpretation. + ;; When completing "~/emacs/master/li|/calc" where "|" is the + ;; cursor, then the candidate only includes the prefix + ;; "~/emacs/master/lisp/", but not the suffix "/calc". Default + ;; completion has the same problem when selecting in the + ;; *Completions* buffer. See bug#48356. + (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) + (str (concat corfu--base (nth corfu--index corfu--candidates)))) + (corfu--replace beg end str) + (corfu--goto -1) ;; Reset selection, completion may continue. + (when status (corfu--done str status nil)) + str)) + +(cl-defgeneric corfu--affixate (cands) + "Annotate CANDS with annotation function." + (let* ((extras (nth 4 completion-in-region--data)) + (dep (plist-get extras :company-deprecated)) + (mf (let ((completion-extra-properties extras)) + (run-hook-with-args-until-success 'corfu-margin-formatters corfu--metadata)))) + (setq cands + (if-let ((aff (corfu--metadata-get 'affixation-function))) + (funcall aff cands) + (if-let ((ann (corfu--metadata-get 'annotation-function))) + (cl-loop for cand in cands collect + (let ((suff (or (funcall ann cand) ""))) + ;; The default completion UI adds the + ;; `completions-annotations' face if no other faces are + ;; present. We use a custom `corfu-annotations' face to + ;; allow further styling which fits better for popups. + (unless (text-property-not-all 0 (length suff) 'face nil suff) + (setq suff (propertize suff 'face 'corfu-annotations))) + (list cand "" suff))) + (cl-loop for cand in cands collect (list cand "" ""))))) + (cl-loop for x in cands for (c . _) = x do + (when mf + (setf (cadr x) (funcall mf c))) + (when (and dep (funcall dep c)) + (setcar x (setq c (substring c))) + (add-face-text-property 0 (length c) 'corfu-deprecated 'append c))) + (cons mf cands))) + +(cl-defgeneric corfu--prepare () + "Insert selected candidate unless command is marked to continue completion." + (when corfu--preview-ov + (delete-overlay corfu--preview-ov) + (setq corfu--preview-ov nil)) + ;; Ensure that state is initialized before next Corfu command + (when (and (symbolp this-command) (string-prefix-p "corfu-" (symbol-name this-command))) + (corfu--update)) + ;; If the next command is not listed in `corfu-continue-commands', insert the + ;; currently selected candidate and bail out of completion. This way you can + ;; continue typing after selecting a candidate. The candidate will be inserted + ;; and your new input will be appended. + (and (corfu--preview-current-p) (eq corfu-preview-current 'insert) + ;; See the comment about `overriding-local-map' in `corfu--post-command'. + (not (or overriding-terminal-local-map + (corfu--match-symbol-p corfu-continue-commands this-command))) + (corfu--insert 'exact))) + +(cl-defgeneric corfu--exhibit (&optional auto) + "Exhibit Corfu UI. +AUTO is non-nil when initializing auto completion." + (pcase-let ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) + (`(,str . ,pt) (corfu--update 'interruptible))) + (cond + ;; 1) Single exactly matching candidate and no further completion is possible. + ((and (not (equal str "")) + (equal (car corfu--candidates) str) (not (cdr corfu--candidates)) + (not (eq corfu-on-exact-match 'show)) + (or auto corfu-on-exact-match) + (not (consp (completion-try-completion str table pred pt corfu--metadata)))) + ;; Quit directly when initializing auto completion. + (if (or auto (eq corfu-on-exact-match 'quit)) + (corfu-quit) + (corfu--done (car corfu--candidates) 'finished nil))) + ;; 2) There exist candidates => Show candidates popup. + (corfu--candidates + (let ((pos (posn-at-point (+ beg (length corfu--base))))) + (corfu--preview-current beg end) + (corfu--candidates-popup pos))) + ;; 3) No candidates & `corfu-quit-no-match' & initialized => Confirmation popup. + ((pcase-exhaustive corfu-quit-no-match + ('t nil) + ('nil corfu--input) + ('separator (seq-contains-p (car corfu--input) corfu-separator))) + (corfu--popup-show (posn-at-point beg) 0 8 '(#("No match" 0 8 (face italic))))) + ;; 4) No candidates & auto completing or initialized => Quit. + ((or auto corfu--input) (corfu-quit))))) + +(cl-defgeneric corfu--teardown (buffer) + "Tear-down Corfu in BUFFER, which might be dead at this point." + (corfu--popup-hide) + (when corfu--preview-ov (delete-overlay corfu--preview-ov)) + (remove-hook 'post-command-hook #'corfu--post-command) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (remove-hook 'window-selection-change-functions #'corfu--window-change 'local) + (remove-hook 'window-buffer-change-functions #'corfu--window-change 'local) + (remove-hook 'pre-command-hook #'corfu--prepare 'local) + (accept-change-group corfu--change-group))) + (cl-loop for (k . v) in corfu--initial-state do (set k v))) + +(defun corfu-sort-length-alpha (list) + "Sort LIST by length and alphabetically." + (sort list #'corfu--length-string<)) + +(defun corfu-quit () + "Quit Corfu completion." + (interactive) + (completion-in-region-mode -1)) + +(defun corfu-reset () + "Reset Corfu completion. +This command can be executed multiple times by hammering the ESC key. If a +candidate is selected, unselect the candidate. Otherwise reset the input. If +there hasn't been any input, then quit." + (interactive) + (if (/= corfu--index corfu--preselect) + (progn + (corfu--goto -1) + (setq this-command #'corfu-first)) + ;; Cancel all changes and start new change group. + (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) + (str (buffer-substring-no-properties beg end))) + (cancel-change-group corfu--change-group) + (activate-change-group (setq corfu--change-group (prepare-change-group))) + ;; Quit when resetting, when input did not change. + (when (equal str (buffer-substring-no-properties beg end)) + (corfu-quit))))) + +(defun corfu-insert-separator () + "Insert a separator character, inhibiting quit on completion boundary. +If the currently selected candidate is previewed, jump to the input +prompt instead. See `corfu-separator' for more details." + (interactive) + (if (not (corfu--preview-current-p)) + (insert corfu-separator) + (corfu--goto -1) + (unless (or (= (car completion-in-region--data) (point)) + (= (char-before) corfu-separator)) + (insert corfu-separator)))) + +(defun corfu-next (&optional n) + "Go forward N candidates." + (interactive "p") + (let ((index (+ corfu--index (or n 1)))) + (corfu--goto + (cond + ((not corfu-cycle) index) + ((= corfu--total 0) -1) + ((< corfu--preselect 0) (1- (mod (1+ index) (1+ corfu--total)))) + (t (mod index corfu--total)))))) + +(defun corfu-previous (&optional n) + "Go backward N candidates." + (interactive "p") + (corfu-next (- (or n 1)))) + +(defun corfu-scroll-down (&optional n) + "Go back by N pages." + (interactive "p") + (corfu--goto (max 0 (- corfu--index (* (or n 1) corfu-count))))) + +(defun corfu-scroll-up (&optional n) + "Go forward by N pages." + (interactive "p") + (corfu-scroll-down (- (or n 1)))) + +(defun corfu-first () + "Go to first candidate. +If the first candidate is already selected, go to the prompt." + (interactive) + (corfu--goto (if (> corfu--index 0) 0 -1))) + +(defun corfu-last () + "Go to last candidate." + (interactive) + (corfu--goto (1- corfu--total))) + +(defun corfu-prompt-beginning (arg) + "Move to beginning of the prompt line. +If the point is already the beginning of the prompt move to the +beginning of the line. If ARG is not 1 or nil, move backward ARG - 1 +lines first." + (interactive "^p") + (let ((beg (car completion-in-region--data))) + (if (or (not (eq arg 1)) + (and (= corfu--preselect corfu--index) (= (point) beg))) + (move-beginning-of-line arg) + (corfu--goto -1) + (goto-char beg)))) + +(defun corfu-prompt-end (arg) + "Move to end of the prompt line. +If the point is already the end of the prompt move to the end of +the line. If ARG is not 1 or nil, move forward ARG - 1 lines +first." + (interactive "^p") + (let ((end (cadr completion-in-region--data))) + (if (or (not (eq arg 1)) + (and (= corfu--preselect corfu--index) (= (point) end))) + (move-end-of-line arg) + (corfu--goto -1) + (goto-char end)))) + +(defun corfu-complete () + "Complete current input. +If a candidate is selected, insert it. Otherwise invoke +`corfu-expand'. Return non-nil if the input has been expanded." + (interactive) + (if (< corfu--index 0) + (corfu-expand) + ;; Continue completion with selected candidate. Exit with status 'finished + ;; if input is a valid match and no further completion is + ;; possible. Additionally treat completion as finished if at the end of a + ;; boundary, even if other longer candidates would still match, since the + ;; user invoked `corfu-complete' with an explicitly selected candidate! + (pcase-let ((`(,_beg ,_end ,table ,pred . ,_) completion-in-region--data) + (newstr (corfu--insert nil))) + (and (test-completion newstr table pred) + (or (not (consp (completion-try-completion + newstr table pred (length newstr) + (completion-metadata newstr table pred)))) + (equal (completion-boundaries newstr table pred "") '(0 . 0))) + (corfu--done newstr 'finished nil)) + t))) + +(defun corfu-expand () + "Expands the common prefix of all candidates. +If the currently selected candidate is previewed, invoke +`corfu-complete' instead. Expansion relies on the completion +styles via `completion-try-completion'. Return non-nil if the +input has been expanded." + (interactive) + (if (corfu--preview-current-p) + (corfu-complete) + (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) + (pt (max 0 (- (point) beg))) + (str (buffer-substring-no-properties beg end)) + (metadata (completion-metadata (substring str 0 pt) table pred))) + (pcase (completion-try-completion str table pred pt metadata) + ('t + (goto-char end) + (corfu--done str 'finished corfu--candidates) + t) + ((and `(,newstr . ,newpt) (guard (not (and (= pt newpt) (equal newstr str))))) + (corfu--replace beg end newstr) + (goto-char (+ beg newpt)) + ;; Exit with status 'finished if input is a valid match + ;; and no further completion is possible. + (and (test-completion newstr table pred) + (not (consp (completion-try-completion + newstr table pred newpt + (completion-metadata (substring newstr 0 newpt) table pred)))) + (corfu--done newstr 'finished corfu--candidates)) + t))))) + +(defun corfu-insert () + "Insert current candidate. +Quit if no candidate is selected." + (interactive) + (if (>= corfu--index 0) + (corfu--insert 'finished) + (corfu-quit))) + +(defun corfu-send () + "Insert current candidate and send it when inside comint or eshell." + (interactive) + (corfu-insert) + (cond + ((and (derived-mode-p 'eshell-mode) (fboundp 'eshell-send-input)) + (eshell-send-input)) + ((and (derived-mode-p 'comint-mode) (fboundp 'comint-send-input)) + (comint-send-input)))) + +;;;###autoload +(define-minor-mode corfu-mode + "COmpletion in Region FUnction." + :group 'corfu :keymap corfu-mode-map + (cond + (corfu-mode + (and corfu-auto (add-hook 'post-command-hook #'corfu--auto-post-command nil 'local)) + (setq-local completion-in-region-function #'corfu--in-region)) + (t + (remove-hook 'post-command-hook #'corfu--auto-post-command 'local) + (kill-local-variable 'completion-in-region-function)))) + +(defcustom global-corfu-modes t + "List of modes where Corfu should be enabled by `global-corfu-mode'. +The variable can either be t, nil or a list of t, nil, mode +symbols or elements of the form (not modes). Examples: + - Enable everywhere, except in Org: ((not org-mode) t). + - Enable in programming modes except Python: ((not python-mode) prog-mode). + - Enable only in text modes: (text-mode)." + :type '(choice (const t) (repeat sexp)) + :group 'corfu) + +;; TODO use `:predicate' on Emacs 29 +(defcustom global-corfu-minibuffer t + "Corfu should be enabled in the minibuffer by `global-corfu-mode'. +The variable can either be t, nil or a custom predicate function. If +the variable is set to t, Corfu is only enabled if the minibuffer has +local `completion-at-point-functions'." + :type '(choice (const t) (const nil) function) + :group 'corfu) + +;;;###autoload +(define-globalized-minor-mode global-corfu-mode + corfu-mode corfu--on + :group 'corfu + (remove-hook 'minibuffer-setup-hook #'corfu--minibuffer-on) + (when (and global-corfu-mode global-corfu-minibuffer) + (add-hook 'minibuffer-setup-hook #'corfu--minibuffer-on 100))) + +(defun corfu--on () + "Enable `corfu-mode' in the current buffer respecting `global-corfu-modes'." + (when (and (not noninteractive) (not (eq (aref (buffer-name) 0) ?\s)) + ;; TODO use `:predicate' on Emacs 29 + (or (eq t global-corfu-modes) + (eq t (cl-loop for p in global-corfu-modes thereis + (pcase-exhaustive p + ('t t) + ('nil 0) + ((pred symbolp) (and (derived-mode-p p) t)) + (`(not . ,m) (and (seq-some #'derived-mode-p m) 0))))))) + (corfu-mode 1))) + +(defun corfu--minibuffer-on () + "Enable `corfu-mode' in the minibuffer respecting `global-corfu-minibuffer'." + (when (and global-corfu-minibuffer (not noninteractive) + (if (functionp global-corfu-minibuffer) + (funcall global-corfu-minibuffer) + (local-variable-p 'completion-at-point-functions))) + (corfu-mode 1))) + +;; Do not show Corfu commands with M-X +(dolist (sym '(corfu-next corfu-previous corfu-first corfu-last corfu-quit corfu-reset + corfu-complete corfu-insert corfu-scroll-up corfu-scroll-down corfu-expand + corfu-send corfu-insert-separator corfu-prompt-beginning corfu-prompt-end + corfu-info-location corfu-info-documentation ;; autoloads in corfu-info.el + corfu-quick-jump corfu-quick-insert corfu-quick-complete)) ;; autoloads in corfu-quick.el + (put sym 'completion-predicate #'ignore)) + +(defun corfu--capf-wrapper-advice (orig fun which) + "Around advice for `completion--capf-wrapper'. +The ORIG function takes the FUN and WHICH arguments." + (if corfu-mode (corfu--capf-wrapper fun t) (funcall orig fun which))) + +(defun corfu--eldoc-advice () + "Return non-nil if Corfu is currently not active." + (not (and corfu-mode completion-in-region-mode))) + +;; Install advice which fixes `completion--capf-wrapper', such that it respects +;; the completion styles for non-exclusive Capfs. See also the fixme comment in +;; the `completion--capf-wrapper' function in minibuffer.el. +(advice-add #'completion--capf-wrapper :around #'corfu--capf-wrapper-advice) + +;; Register Corfu with ElDoc +(advice-add #'eldoc-display-message-no-interference-p + :before-while #'corfu--eldoc-advice) +(eldoc-add-command #'corfu-complete #'corfu-insert #'corfu-expand #'corfu-send) + +(provide 'corfu) +;;; corfu.el ends here diff --git a/emacs/elpa/corfu-20241115.528/corfu.elc b/emacs/elpa/corfu-20241115.528/corfu.elc Binary files differ. diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-pkg.el b/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-pkg.el @@ -1,13 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "doom-modeline" "20241102.1416" - "A minimal and modern mode-line." - '((emacs "25.1") - (compat "29.1.4.5") - (nerd-icons "0.1.0") - (shrink-path "0.3.1")) - :url "https://github.com/seagle0128/doom-modeline" - :commit "645ef52e2a5fc35325e9acbf54efcb725d4b74ab" - :revdesc "645ef52e2a5f" - :keywords '("faces" "mode-line") - :authors '(("Vincent Zhang" . "seagle0128@gmail.com")) - :maintainers '(("Vincent Zhang" . "seagle0128@gmail.com"))) diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-segments.el b/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-segments.el @@ -1,3235 +0,0 @@ -;;; doom-modeline-segments.el --- The segments for doom-modeline -*- lexical-binding: t; -*- - -;; Copyright (C) 2018-2024 Vincent Zhang - -;; This file is not part of GNU Emacs. - -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;; - -;;; Commentary: -;; -;; The segments for doom-modeline. -;; Use `doom-modeline-def-segment' to create a new segment. -;; - -;;; Code: - -(require 'doom-modeline-core) -(require 'doom-modeline-env) -(eval-when-compile - (require 'cl-lib) - (require 'seq) - (require 'subr-x)) - - -;; -;; Externals -;; - -(defvar Info-current-file) -(defvar Info-current-node) -(defvar Info-mode-line-node-keymap) -(defvar anzu--cached-count) -(defvar anzu--current-position) -(defvar anzu--overflow-p) -(defvar anzu--state) -(defvar anzu--total-matched) -(defvar anzu-cons-mode-line-p) -(defvar aw-keys) -(defvar battery-echo-area-format) -(defvar battery-load-critical) -(defvar battery-mode-line-format) -(defvar battery-mode-line-limit) -(defvar battery-status-function) -(defvar boon-command-state) -(defvar boon-insert-state) -(defvar boon-off-state) -(defvar boon-special-state) -(defvar display-time-string) -(defvar edebug-execution-mode) -(defvar eglot--managed-mode) -(defvar eglot-menu) -(defvar eglot-menu-string) -(defvar eglot-server-menu) -(defvar erc-modified-channels-alist) -(defvar evil-ex-active-highlights-alist) -(defvar evil-ex-argument) -(defvar evil-ex-range) -(defvar evil-mc-frozen) -(defvar evil-state) -(defvar evil-visual-beginning) -(defvar evil-visual-end) -(defvar evil-visual-selection) -(defvar flycheck--automatically-enabled-checkers) -(defvar flycheck-current-errors) -(defvar flycheck-mode-menu-map) -(defvar flymake--mode-line-format) -(defvar flymake--state) -(defvar flymake-menu) -(defvar gnus-newsrc-alist) -(defvar gnus-newsrc-hashtb) -(defvar grip--process) -(defvar helm--mode-line-display-prefarg) -(defvar iedit-occurrences-overlays) -(defvar kele-menu-map) -(defvar meow--indicator) -(defvar minions-mode-line-lighter) -(defvar minions-mode-line-minor-modes-map) -(defvar mlscroll-right-align) -(defvar mu4e--modeline-item) -(defvar mu4e-alert-mode-line) -(defvar mu4e-alert-modeline-formatter) -(defvar mu4e-modeline-mode) -(defvar objed--obj-state) -(defvar objed--object) -(defvar objed-modeline-setup-func) -(defvar persp-nil-name) -(defvar phi-replace--mode-line-format) -(defvar phi-search--overlays) -(defvar phi-search--selection) -(defvar phi-search-mode-line-format) -(defvar rcirc-activity) -(defvar symbol-overlay-keywords-alist) -(defvar symbol-overlay-temp-symbol) -(defvar text-scale-mode-amount) -(defvar tracking-buffers) -(defvar winum-auto-setup-mode-line) -(defvar xah-fly-insert-state-p) - -(declare-function anzu--reset-status "ext:anzu") -(declare-function anzu--where-is-here "ext:anzu") -(declare-function async-inject-variables "ext:async") -(declare-function async-start "ext:async") -(declare-function avy-traverse "ext:avy") -(declare-function avy-tree "ext:avy") -(declare-function aw-update "ext:ace-window") -(declare-function aw-window-list "ext:ace-window") -(declare-function battery-format "battery") -(declare-function battery-update "battery") -(declare-function boon-modeline-string "ext:boon") -(declare-function boon-state-string "ext:boon") -(declare-function cider--connection-info "ext:cider") -(declare-function cider-connected-p "ext:cider") -(declare-function cider-current-repl "ext:cider") -(declare-function cider-jack-in "ext:cider") -(declare-function cider-quit "ext:cider") -(declare-function citre-mode "ext:citre-basic-tools") -(declare-function compilation-goto-in-progress-buffer "compile") -(declare-function dap--cur-session "ext:dap-mode") -(declare-function dap--debug-session-name "ext:dap-mode") -(declare-function dap--debug-session-state "ext:dap-mode") -(declare-function dap--session-running "ext:dap-mode") -(declare-function dap-debug-recent "ext:dap-mode") -(declare-function dap-disconnect "ext:dap-mode") -(declare-function dap-hydra "ext:dap-hydra") -(declare-function edebug-help "edebug") -(declare-function edebug-next-mode "edebug") -(declare-function edebug-stop "edebug") -(declare-function eglot--major-modes "eglot") -(declare-function eglot--server-info "eglot" t t) -(declare-function eglot-current-server "eglot") -(declare-function eglot-managed-p "eglot") -(declare-function eglot-project-nickname "eglot" t t) -(declare-function erc-switch-to-buffer "erc") -(declare-function erc-track-switch-buffer "erc-track") -(declare-function evil-delimited-arguments "ext:evil-common") -(declare-function evil-emacs-state-p "ext:evil-states" t t) -(declare-function evil-force-normal-state "ext:evil-commands" t t) -(declare-function evil-insert-state-p "ext:evil-states" t t) -(declare-function evil-motion-state-p "ext:evil-states" t t) -(declare-function evil-normal-state-p "ext:evil-states" t t) -(declare-function evil-operator-state-p "ext:evil-states" t t) -(declare-function evil-replace-state-p "ext:evil-states" t t) -(declare-function evil-state-property "ext:evil-common") -(declare-function evil-visual-state-p "ext:evil-states" t t) -(declare-function eyebrowse--get "ext:eyebrowse") -(declare-function face-remap-remove-relative "face-remap") -(declare-function fancy-narrow-active-p "ext:fancy-narrow") -(declare-function flycheck-buffer "ext:flycheck") -(declare-function flycheck-count-errors "ext:flycheck") -(declare-function flycheck-error-level-compilation-level "ext:flycheck") -(declare-function flycheck-list-errors "ext:flycheck") -(declare-function flycheck-next-error "ext:flycheck") -(declare-function flycheck-previous-error "ext:flycheck") -(declare-function flymake--diag-type "flymake" t t) -(declare-function flymake--handle-report "flymake") -(declare-function flymake--lookup-type-property "flymake") -(declare-function flymake--state-diags "flymake" t t) -(declare-function flymake-disabled-backends "flymake") -(declare-function flymake-goto-next-error "flymake") -(declare-function flymake-goto-prev-error "flymake") -(declare-function flymake-reporting-backends "flymake") -(declare-function flymake-running-backends "flymake") -(declare-function flymake-show-buffer-diagnostics "flymake") -(declare-function flymake-show-buffer-diagnostics "flymake") -(declare-function flymake-start "flymake") -(declare-function follow-all-followers "follow") -(declare-function gnus-demon-add-handler "gnus-demon") -(declare-function grip--preview-url "ext:grip-mode") -(declare-function grip-browse-preview "ext:grip-mode") -(declare-function grip-restart-preview "ext:grip-mode") -(declare-function grip-stop-preview "ext:grip-mode") -(declare-function helm-candidate-number-at-point "ext:helm-core") -(declare-function helm-get-candidate-number "ext:helm-core") -(declare-function iedit-find-current-occurrence-overlay "ext:iedit-lib") -(declare-function iedit-prev-occurrence "ext:iedit-lib") -(declare-function image-get-display-property "image-mode") -(declare-function jsonrpc--request-continuations "jsonrpc" t t) -(declare-function jsonrpc-last-error "jsonrpc" t t) -(declare-function jsonrpc-name "jsonrpc" t t) -(declare-function kele-current-context-name "ext:kele") -(declare-function kele-current-namespace "ext:kele") -(declare-function lsp--workspace-print "ext:lsp-mode") -(declare-function lsp-describe-session "ext:lsp-mode") -(declare-function lsp-workspace-folders-open "ext:lsp-mode") -(declare-function lsp-workspace-restart "ext:lsp-mode") -(declare-function lsp-workspace-shutdown "ext:lsp-mode") -(declare-function lsp-workspaces "ext:lsp-mode") -(declare-function lv-message "ext:lv") -(declare-function mc/num-cursors "ext:multiple-cursors-core") -(declare-function meow--current-state "ext:meow") -(declare-function meow-beacon-mode-p "ext:meow") -(declare-function meow-insert-mode-p "ext:meow") -(declare-function meow-keypad-mode-p "ext:meow") -(declare-function meow-motion-mode-p "ext:meow") -(declare-function meow-normal-mode-p "ext:meow") -(declare-function minions--prominent-modes "ext:minions") -(declare-function mlscroll-mode-line "ext:mlscroll") -(declare-function mu4e--modeline-string "ext:mu4e-modeline") -(declare-function mu4e-alert-default-mode-line-formatter "ext:mu4e-alert") -(declare-function mu4e-alert-enable-mode-line-display "ext:mu4e-alert") -(declare-function nyan-create "ext:nyan-mode") -(declare-function org-edit-src-save "org-src") -(declare-function parrot-create "ext:parrot") -(declare-function pdf-cache-number-of-pages "ext:pdf-cache" t t) -(declare-function persp-add-buffer "ext:persp-mode") -(declare-function persp-contain-buffer-p "ext:persp-mode") -(declare-function persp-switch "ext:persp-mode") -(declare-function phi-search--initialize "ext:phi-search") -(declare-function poke-line-create "ext:poke-line") -(declare-function popup-create "ext:popup") -(declare-function popup-delete "ext:popup") -(declare-function rcirc-next-active-buffer "rcirc") -(declare-function rcirc-short-buffer-name "rcirc") -(declare-function rcirc-switch-to-server-buffer "rcirc") -(declare-function rcirc-window-configuration-change "rcirc") -(declare-function rime--should-enable-p "ext:rime") -(declare-function rime--should-inline-ascii-p "ext:rime") -(declare-function sml-modeline-create "ext:sml-modeline") -(declare-function svg-circle "svg") -(declare-function svg-create "svg") -(declare-function svg-image "svg") -(declare-function svg-line "svg") -(declare-function symbol-overlay-assoc "ext:symbol-overlay") -(declare-function symbol-overlay-get-list "ext:symbol-overlay") -(declare-function symbol-overlay-get-symbol "ext:symbol-overlay") -(declare-function symbol-overlay-rename "ext:symbol-overlay") -(declare-function tab-bar--current-tab "tab-bar") -(declare-function tab-bar--current-tab-index "tab-bar") -(declare-function tracking-next-buffer "ext:tracking") -(declare-function tracking-previous-buffer "ext:tracking") -(declare-function tracking-shorten "ext:tracking") -(declare-function warning-numeric-level "warnings") -(declare-function window-numbering-clear-mode-line "ext:window-numbering") -(declare-function window-numbering-get-number-string "ext:window-numbering") -(declare-function window-numbering-install-mode-line "ext:window-numbering") -(declare-function winum--clear-mode-line "ext:winum") -(declare-function winum--install-mode-line "ext:winum") -(declare-function winum-get-number-string "ext:winum") - - - -;; -;; Buffer information -;; - -(defvar-local doom-modeline--buffer-file-icon nil) -(defun doom-modeline-update-buffer-file-icon (&rest _) - "Update file icon in mode-line." - (setq doom-modeline--buffer-file-icon - (when (and doom-modeline-major-mode-icon - (doom-modeline-icon-displayable-p)) - (let ((icon (doom-modeline-icon-for-buffer))) - (propertize (if (or (null icon) (symbolp icon)) - (doom-modeline-icon 'faicon "nf-fa-file_o" nil nil - :face 'nerd-icons-dsilver) - (doom-modeline-propertize-icon icon)) - 'help-echo (format "Major-mode: %s" (format-mode-line mode-name))))))) -(add-hook 'find-file-hook #'doom-modeline-update-buffer-file-icon) -(add-hook 'after-change-major-mode-hook #'doom-modeline-update-buffer-file-icon) -(add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-icon) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-buffer-file-icon)))))) - -(defun doom-modeline-buffer-file-state-icon (icon unicode text face) - "Displays an ICON of buffer state with FACE. -UNICODE and TEXT are the alternatives if it is not applicable. -Uses `nerd-icons-mdicon' to fetch the icon." - (doom-modeline-icon 'mdicon icon unicode text :face face)) - -(defvar-local doom-modeline--buffer-file-state-icon nil) -(defun doom-modeline-update-buffer-file-state-icon (&rest _) - "Update the buffer or file state in mode-line." - (setq doom-modeline--buffer-file-state-icon - (when doom-modeline-buffer-state-icon - (ignore-errors - (concat - (cond ((not (or (and (buffer-file-name) (file-remote-p buffer-file-name)) - (verify-visited-file-modtime (current-buffer)))) - (doom-modeline-buffer-file-state-icon - "nf-md-reload_alert" "⟳" "%1*" - 'doom-modeline-warning)) - (buffer-read-only - (doom-modeline-buffer-file-state-icon - "nf-md-lock" "🔒" "%1*" - 'doom-modeline-warning)) - ((and buffer-file-name (buffer-modified-p) - doom-modeline-buffer-modification-icon) - (doom-modeline-buffer-file-state-icon - "nf-md-content_save_edit" "💾" "%1*" - 'doom-modeline-warning)) - ((and buffer-file-name - ;; Avoid freezing while connection is lost - (not (file-remote-p buffer-file-name)) - (not (file-exists-p buffer-file-name))) - (doom-modeline-buffer-file-state-icon - "nf-md-cancel" "🚫" "!" - 'doom-modeline-urgent)) - (t "")) - (when (or (buffer-narrowed-p) - (and (bound-and-true-p fancy-narrow-mode) - (fancy-narrow-active-p)) - (bound-and-true-p dired-narrow-mode)) - (doom-modeline-buffer-file-state-icon - "nf-md-unfold_less_horizontal" "↕" "><" - 'doom-modeline-warning))))))) - -(defvar-local doom-modeline--buffer-file-name nil) -(defun doom-modeline-update-buffer-file-name (&rest _) - "Update buffer file name in mode-line." - (setq doom-modeline--buffer-file-name - (ignore-errors - (save-match-data - (if buffer-file-name - (doom-modeline-buffer-file-name) - (propertize "%b" - 'face 'doom-modeline-buffer-file - 'mouse-face 'doom-modeline-highlight - 'help-echo "Buffer name -mouse-1: Previous buffer\nmouse-3: Next buffer" - 'local-map mode-line-buffer-identification-keymap)))))) -(add-hook 'find-file-hook #'doom-modeline-update-buffer-file-name) -(add-hook 'after-save-hook #'doom-modeline-update-buffer-file-name) -(add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-name) -(add-hook 'evil-insert-state-exit-hook #'doom-modeline-update-buffer-file-name) -(add-hook 'Info-selection-hook #'doom-modeline-update-buffer-file-name) -(advice-add #'rename-buffer :after #'doom-modeline-update-buffer-file-name) -(advice-add #'set-visited-file-name :after #'doom-modeline-update-buffer-file-name) -(advice-add #'pop-to-buffer :after #'doom-modeline-update-buffer-file-name) -(advice-add #'popup-create :after #'doom-modeline-update-buffer-file-name) -(advice-add #'popup-delete :after #'doom-modeline-update-buffer-file-name) -;; (advice-add #'primitive-undo :after #'doom-modeline-update-buffer-file-name) -;; (advice-add #'set-buffer-modified-p :after #'doom-modeline-update-buffer-file-name) - -(with-no-warnings - (if (boundp 'after-focus-change-function) - (progn - (advice-add #'handle-switch-frame :after #'doom-modeline-update-buffer-file-name) - (add-function :after after-focus-change-function #'doom-modeline-update-buffer-file-name)) - (progn - (add-hook 'focus-in-hook #'doom-modeline-update-buffer-file-name) - (add-hook 'focus-out-hook #'doom-modeline-update-buffer-file-name)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-buffer-file-name-style - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-buffer-file-name-style val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when buffer-file-name - (doom-modeline-update-buffer-file-name))))))) - -(defsubst doom-modeline--buffer-mode-icon () - "The icon of the current major mode." - (when (and doom-modeline-icon doom-modeline-major-mode-icon) - (when-let* ((icon (or doom-modeline--buffer-file-icon - (doom-modeline-update-buffer-file-icon)))) - (unless (string-empty-p icon) - (concat - (if doom-modeline-major-mode-color-icon - (doom-modeline-display-icon icon) - (doom-modeline-propertize-icon - icon - (doom-modeline-face))) - (doom-modeline-vspc)))))) - -(defsubst doom-modeline--buffer-state-icon () - "The icon of the current buffer state." - (when doom-modeline-buffer-state-icon - (when-let* ((icon (doom-modeline-update-buffer-file-state-icon))) - (unless (string-empty-p icon) - (concat - (doom-modeline-display-icon icon) - (doom-modeline-vspc)))))) - -(defsubst doom-modeline--buffer-simple-name () - "The buffer simple name." - (propertize "%b" - 'face (doom-modeline-face - (if (and doom-modeline-highlight-modified-buffer-name - (buffer-modified-p)) - 'doom-modeline-buffer-modified - 'doom-modeline-buffer-file)) - 'mouse-face 'doom-modeline-highlight - 'help-echo "Buffer name -mouse-1: Previous buffer\nmouse-3: Next buffer" - 'local-map mode-line-buffer-identification-keymap)) - -(defsubst doom-modeline--buffer-name () - "The current buffer name." - (when doom-modeline-buffer-name - (if (and (not (eq doom-modeline-buffer-file-name-style 'file-name)) - doom-modeline--limited-width-p) - ;; Only display the buffer name if the window is small, and doesn't - ;; need to respect file-name style. - (doom-modeline--buffer-simple-name) - (when-let* ((name (or doom-modeline--buffer-file-name - (doom-modeline-update-buffer-file-name)))) - ;; Check if the buffer is modified - (if (and doom-modeline-highlight-modified-buffer-name - (buffer-modified-p)) - (propertize name 'face (doom-modeline-face 'doom-modeline-buffer-modified)) - (doom-modeline-display-text name)))))) - -(doom-modeline-def-segment buffer-info - "Combined information about the current buffer. - -Including the current working directory, the file name, and its state (modified, -read-only or non-existent)." - (concat - (doom-modeline-spc) - (doom-modeline--buffer-mode-icon) - (doom-modeline--buffer-state-icon) - (doom-modeline--buffer-name))) - -(doom-modeline-def-segment buffer-info-simple - "Display only the current buffer's name, but with fontification." - (concat - (doom-modeline-spc) - (doom-modeline--buffer-mode-icon) - (doom-modeline--buffer-state-icon) - (doom-modeline--buffer-simple-name))) - -(doom-modeline-def-segment calc - "Display calculator icons and info." - (concat - (doom-modeline-spc) - (when-let* ((icon (doom-modeline-icon 'faicon "nf-fa-calculator" "🖩" ""))) - (concat - (doom-modeline-display-icon icon) - (doom-modeline-vspc))) - (doom-modeline--buffer-simple-name))) - -(doom-modeline-def-segment buffer-default-directory - "Displays `default-directory' with the icon and state. - -This is for special buffers like the scratch buffer where knowing the current -project directory is important." - (let ((face (doom-modeline-face - (if (and buffer-file-name (buffer-modified-p)) - 'doom-modeline-buffer-modified - 'doom-modeline-buffer-path)))) - (concat - (doom-modeline-spc) - (and doom-modeline-major-mode-icon - (concat - (doom-modeline-icon - 'octicon "nf-oct-file_directory_fill" "🖿" "" :face face) - (doom-modeline-vspc))) - (doom-modeline--buffer-state-icon) - (propertize (abbreviate-file-name default-directory) 'face face)))) - -(doom-modeline-def-segment buffer-default-directory-simple - "Displays `default-directory'. - -This is for special buffers like the scratch buffer where knowing the current -project directory is important." - (let ((face (doom-modeline-face 'doom-modeline-buffer-path))) - (concat - (doom-modeline-spc) - (and doom-modeline-major-mode-icon - (concat - (doom-modeline-icon - 'octicon "nf-oct-file_directory_fill" "🖿" "" :face face) - (doom-modeline-vspc))) - (propertize (abbreviate-file-name default-directory) 'face face)))) - - -;; -;; Encoding -;; - -(doom-modeline-def-segment buffer-encoding - "Displays the eol and the encoding style of the buffer." - (when doom-modeline-buffer-encoding - (let ((sep (doom-modeline-spc)) - (face (doom-modeline-face)) - (mouse-face 'doom-modeline-highlight)) - (concat - sep - - ;; eol type - (let ((eol (coding-system-eol-type buffer-file-coding-system))) - (when (or (eq doom-modeline-buffer-encoding t) - (and (eq doom-modeline-buffer-encoding 'nondefault) - (not (equal eol doom-modeline-default-eol-type)))) - (propertize - (pcase eol - (0 "LF ") - (1 "CRLF ") - (2 "CR ") - (_ "")) - 'face face - 'mouse-face mouse-face - 'help-echo (format "End-of-line style: %s\nmouse-1: Cycle" - (pcase eol - (0 "Unix-style LF") - (1 "DOS-style CRLF") - (2 "Mac-style CR") - (_ "Undecided"))) - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] 'mode-line-change-eol) - map)))) - - ;; coding system - (let* ((sys (coding-system-plist buffer-file-coding-system)) - (cat (plist-get sys :category)) - (sym (if (memq cat - '(coding-category-undecided coding-category-utf-8)) - 'utf-8 - (plist-get sys :name)))) - (when (or (eq doom-modeline-buffer-encoding t) - (and (eq doom-modeline-buffer-encoding 'nondefault) - (not (eq cat 'coding-category-undecided)) - (not (eq sym doom-modeline-default-coding-system)))) - (propertize - (upcase (symbol-name sym)) - 'face face - 'mouse-face mouse-face - 'help-echo 'mode-line-mule-info-help-echo - 'local-map mode-line-coding-system-map))) - - sep)))) - - -;; -;; Indentation -;; - -(doom-modeline-def-segment indent-info - "Displays the indentation information." - (when doom-modeline-indent-info - (let ((do-propertize - (lambda (mode size) - (propertize - (format " %s %d " mode size) - 'face (doom-modeline-face))))) - (if indent-tabs-mode - (funcall do-propertize "TAB" tab-width) - (let ((lookup-var - (seq-find (lambda (var) - (and var (boundp var) (symbol-value var))) - (cdr (assoc major-mode doom-modeline-indent-alist)) nil))) - (funcall do-propertize "SPC" - (if lookup-var - (symbol-value lookup-var) - tab-width))))))) - -;; -;; Remote host -;; - -(doom-modeline-def-segment remote-host - "Hostname for remote buffers." - (when default-directory - (when-let* ((host (file-remote-p default-directory 'host))) - (propertize - (concat "@" host) - 'face (doom-modeline-face 'doom-modeline-host))))) - - -;; -;; Major mode -;; - -(doom-modeline-def-segment major-mode - "The major mode, including environment and text-scale info." - (let ((sep (doom-modeline-spc)) - (face (doom-modeline-face 'doom-modeline-buffer-major-mode))) - (concat - sep - (propertize (concat - (format-mode-line - (or (and (boundp 'delighted-modes) - (cadr (assq major-mode delighted-modes))) - mode-name)) - (when (and doom-modeline-env-version doom-modeline-env--version) - (format " %s" doom-modeline-env--version))) - 'help-echo "Major mode\n\ -mouse-1: Display major mode menu\n\ -mouse-2: Show help for major mode\n\ -mouse-3: Toggle minor modes" - 'face face - 'mouse-face 'doom-modeline-highlight - 'local-map mode-line-major-mode-keymap) - (and (boundp 'text-scale-mode-amount) - (/= text-scale-mode-amount 0) - (propertize - (format - (if (> text-scale-mode-amount 0) " (%+d)" " (%-d)") - text-scale-mode-amount) - 'face face)) - sep))) - - -;; -;; Process -;; - -(doom-modeline-def-segment process - "The process info." - (doom-modeline-display-text - (format-mode-line mode-line-process))) - - -;; -;; Minor modes -;; - -(doom-modeline-def-segment minor-modes - (when doom-modeline-minor-modes - (let ((sep (doom-modeline-spc)) - (face (doom-modeline-face 'doom-modeline-buffer-minor-mode)) - (mouse-face 'doom-modeline-highlight) - (help-echo "Minor mode - mouse-1: Display minor mode menu - mouse-2: Show help for minor mode - mouse-3: Toggle minor modes")) - (if (bound-and-true-p minions-mode) - `((:propertize ("" ,(minions--prominent-modes)) - face ,face - mouse-face ,mouse-face - help-echo ,help-echo - local-map ,mode-line-minor-mode-keymap) - ,sep - (:propertize ("" ,(doom-modeline-icon 'octicon "nf-oct-gear" "⚙" - minions-mode-line-lighter - :face face)) - mouse-face ,mouse-face - help-echo "Minions -mouse-1: Display minor modes menu" - local-map ,minions-mode-line-minor-modes-map) - ,sep) - `((:propertize ("" minor-mode-alist) - face ,face - mouse-face ,mouse-face - help-echo ,help-echo - local-map ,mode-line-minor-mode-keymap) - ,sep))))) - - -;; -;; VCS -;; - -(defun doom-modeline-vcs-icon (icon &optional unicode text face) - "Displays the vcs ICON with FACE and VOFFSET. - -UNICODE and TEXT are fallbacks. -Uses `nerd-icons-octicon' to fetch the icon." - (doom-modeline-icon 'devicon (and doom-modeline-vcs-icon icon) - unicode text :face face)) - -(defvar-local doom-modeline--vcs nil) -(defun doom-modeline-update-vcs (&rest _) - "Update vcs state in mode-line." - (setq doom-modeline--vcs - (when (and vc-mode buffer-file-name) - (let* ((backend (vc-backend buffer-file-name)) - (state (vc-state buffer-file-name backend)) - (icon (cond ((memq state '(edited added)) - (doom-modeline-vcs-icon "nf-dev-git_compare" "🔃" "*" 'doom-modeline-info)) - ((eq state 'needs-merge) - (doom-modeline-vcs-icon "nf-dev-git_merge" "🔀" "?" 'doom-modeline-info)) - ((eq state 'needs-update) - (doom-modeline-vcs-icon "nf-dev-git_pull_request" "⬇" "!" 'doom-modeline-warning)) - ((memq state '(removed conflict unregistered)) - (doom-modeline-icon 'octicon "nf-oct-alert" "⚠" "!" :face 'doom-modeline-urgent)) - (t (doom-modeline-vcs-icon "nf-dev-git_branch" "" "@" 'doom-modeline-info)))) - (str (or (and vc-display-status - (functionp doom-modeline-vcs-display-function) - (funcall doom-modeline-vcs-display-function)) - "")) - (face (cond ((eq state 'needs-update) - '(doom-modeline-warning bold)) - ((memq state '(removed conflict unregistered)) - '(doom-modeline-urgent bold)) - (t '(doom-modeline-info bold)))) - (text (propertize (if (length> str doom-modeline-vcs-max-length) - (concat - (substring str 0 (- doom-modeline-vcs-max-length 3)) - doom-modeline-ellipsis) - str) - 'face face))) - `((icon . ,icon) (text . ,text)))))) -(add-hook 'find-file-hook #'doom-modeline-update-vcs) -(add-hook 'after-save-hook #'doom-modeline-update-vcs) -(advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-vcs)))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-unicode-fallback val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-vcs)))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-vcs-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-vcs-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-vcs)))))) - -(doom-modeline-add-variable-watcher - 'vc-display-status - (lambda (_sym val op _where) - (when (eq op 'set) - (setq vc-display-status val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-vcs)))))) - -(doom-modeline-def-segment vcs - "Displays the current branch, colored based on its state." - (when doom-modeline--vcs - (let-alist doom-modeline--vcs - (let ((sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc))) - (concat sep - (propertize (concat - (doom-modeline-display-icon .icon) - vsep - (doom-modeline-display-text .text)) - 'help-echo (get-text-property 1 'help-echo vc-mode) - 'mouse-face 'doom-modeline-highlight - 'local-map (get-text-property 1 'local-map vc-mode)) - sep))))) - - -;; -;; Check -;; - -(defun doom-modeline-check-icon (icon unicode text face) - "Displays the check ICON with FACE. - -UNICODE and TEXT are fallbacks. -Uses `nerd-icons-mdicon' to fetch the icon." - (doom-modeline-icon 'mdicon (and doom-modeline-check-icon icon) - unicode text :face face)) - -(defun doom-modeline-check-text (text &optional face) - "Displays the check TEXT with FACE." - (propertize text 'face (or face 'mode-line))) - -;; Flycheck - -(defun doom-modeline--flycheck-count-errors () - "Count the number of ERRORS, grouped by level. - -Return an alist, where each ITEM is a cons cell whose `car' is an -error level, and whose `cdr' is the number of errors of that -level." - (let ((info 0) (warning 0) (error 0)) - (mapc - (lambda (item) - (let ((count (cdr item))) - (pcase (flycheck-error-level-compilation-level (car item)) - (0 (cl-incf info count)) - (1 (cl-incf warning count)) - (2 (cl-incf error count))))) - (flycheck-count-errors flycheck-current-errors)) - `((info . ,info) (warning . ,warning) (error . ,error)))) - -(defvar-local doom-modeline--flycheck nil) -(defun doom-modeline-update-flycheck (&optional status) - "Update flycheck via STATUS." - (setq doom-modeline--flycheck - (let-alist (doom-modeline--flycheck-count-errors) - (let* ((vsep (doom-modeline-vspc)) - (seg (if doom-modeline-check-simple-format - (let ((count (+ .error .warning .info))) - (pcase status - ('finished (if (> count 0) - (let ((face (if (> .error 0) 'doom-modeline-urgent 'doom-modeline-warning))) - (concat - (doom-modeline-check-icon "nf-md-alert_circle_outline" "⚠" "!" face) - vsep - (doom-modeline-check-text (number-to-string count) face))) - (doom-modeline-check-icon "nf-md-check_circle_outline" "✔" "*" 'doom-modeline-info))) - ('running (concat - (doom-modeline-check-icon "nf-md-timer_sand" "⏳" "*" 'doom-modeline-debug) - (when (> count 0) - (concat - vsep - (doom-modeline-check-text (number-to-string count) 'doom-modeline-debug))))) - ('no-checker (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "-" 'doom-modeline-debug)) - ('errored (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-urgent)) - ('interrupted (doom-modeline-check-icon "nf-md-pause_circle_outline" "⦷" "." 'doom-modeline-debug)) - ('suspicious (doom-modeline-check-icon "nf-md-file_question_outline" "❓" "?" 'doom-modeline-debug)) - (_ ""))) - (concat (doom-modeline-check-icon "nf-md-close_circle_outline" "⮾" "!" 'doom-modeline-urgent) - vsep - (doom-modeline-check-text (number-to-string .error) 'doom-modeline-urgent) - vsep - (doom-modeline-check-icon "nf-md-alert_outline" "⚠" "!" 'doom-modeline-warning) - vsep - (doom-modeline-check-text (number-to-string .warning) 'doom-modeline-warning) - vsep - (doom-modeline-check-icon "nf-md-information_outline" "🛈" "!" 'doom-modeline-info) - vsep - (doom-modeline-check-text (number-to-string .info) 'doom-modeline-info))))) - (propertize seg - 'help-echo (concat "Flycheck\n" - (pcase status - ('finished (format "error: %d, warning: %d, info: %d" .error .warning .info)) - ('running "Checking...") - ('no-checker "No Checker") - ('errored "Error") - ('interrupted "Interrupted") - ('suspicious "Suspicious")) - "\nmouse-1: Display minor mode menu\nmouse-2: Show help for minor mode") - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] - flycheck-mode-menu-map) - (define-key map [mode-line mouse-2] - (lambda () - (interactive) - (describe-function 'flycheck-mode))) - map)))))) -(add-hook 'flycheck-status-changed-functions #'doom-modeline-update-flycheck) -(add-hook 'flycheck-mode-hook #'doom-modeline-update-flycheck) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flycheck-mode) - (doom-modeline-update-flycheck))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-check-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-check-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flycheck-mode) - (doom-modeline-update-flycheck))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-unicode-fallback val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flycheck-mode) - (doom-modeline-update-flycheck))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-check-simple-format - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-check-simple-format val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flycheck-mode) - (doom-modeline-update-flycheck))))))) - -;; Flymake - -;; Compatibility -;; @see https://github.com/emacs-mirror/emacs/commit/6e100869012da9244679696634cab6b9cac96303. -(with-eval-after-load 'flymake - (unless (boundp 'flymake--state) - (defvaralias 'flymake--state 'flymake--backend-state)) - (unless (fboundp 'flymake--state-diags) - (defalias 'flymake--state-diags 'flymake--backend-state-diags))) - -(defun doom-modeline--flymake-count-errors () - "Count the number of ERRORS, grouped by level." - (let ((warning-level (warning-numeric-level :warning)) - (note-level (warning-numeric-level :debug)) - (note 0) (warning 0) (error 0)) - (maphash (lambda (_b state) - (cl-loop - with diags = (flymake--state-diags state) - for diag in diags do - (let ((severity (flymake--lookup-type-property (flymake--diag-type diag) 'severity - (warning-numeric-level :error)))) - (cond ((> severity warning-level) (cl-incf error)) - ((> severity note-level) (cl-incf warning)) - (t (cl-incf note)))))) - flymake--state) - `((note . ,note) (warning . ,warning) (error . ,error)))) - -(defvar-local doom-modeline--flymake nil) -(defun doom-modeline-update-flymake (&rest _) - "Update flymake." - (setq doom-modeline--flymake - (let* ((known (hash-table-keys flymake--state)) - (running (flymake-running-backends)) - (disabled (flymake-disabled-backends)) - (reported (flymake-reporting-backends)) - (all-disabled (and disabled (null running))) - (some-waiting (cl-set-difference running reported))) - (let-alist (doom-modeline--flymake-count-errors) - (let* ((vsep (doom-modeline-vspc)) - (seg (if doom-modeline-check-simple-format - (let ((count (+ .error .warning .note))) - (cond - (some-waiting (concat - (doom-modeline-check-icon "nf-md-timer_sand" "⏳" "*" 'doom-modeline-debug) - (when (> count 0) - (concat - vsep - (doom-modeline-check-text (number-to-string count) 'doom-modeline-debug))))) - ((null known) (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-urgent)) - (all-disabled (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-warning)) - (t (if (> count 0) - (let ((face (cond ((> .error 0) 'doom-modeline-urgent) - ((> .warning 0) 'doom-modeline-warning) - (t 'doom-modeline-info)))) - (concat - (doom-modeline-check-icon "nf-md-alert_circle_outline" "⚠" "!" face) - vsep - (doom-modeline-check-text (number-to-string count) face))) - (doom-modeline-check-icon "nf-md-check_circle_outline" "✔" "*" 'doom-modeline-info))))) - (concat - (doom-modeline-check-icon "nf-md-close_circle_outline" "⮾" "!" 'doom-modeline-urgent) - vsep - (doom-modeline-check-text (number-to-string .error) 'doom-modeline-urgent) - vsep - (doom-modeline-check-icon "nf-md-alert_outline" "⚠" "!" 'doom-modeline-warning) - vsep - (doom-modeline-check-text (number-to-string .warning) 'doom-modeline-warning) - vsep - (doom-modeline-check-icon "nf-md-information_outline" "🛈" "!" 'doom-modeline-info) - vsep - (doom-modeline-check-text (number-to-string .note) 'doom-modeline-info))))) - (propertize - seg - 'help-echo (concat - "Flymake\n" - (cond (some-waiting "Checking...") - ((null known) "No Checker") - (all-disabled "All Checkers Disabled") - (t (format "%d/%d backends running\nerror: %d, warning: %d, note: %d" - (length running) (length known) .error .warning .note))) - "\nmouse-1: Display minor mode menu\nmouse-2: Show help for minor mode") - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] - flymake-menu) - (define-key map [mode-line mouse-2] - (lambda () - (interactive) - (describe-function 'flymake-mode))) - map))))))) -(advice-add #'flymake--handle-report :after #'doom-modeline-update-flymake) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flymake-mode) - (doom-modeline-update-flymake))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-check-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-check-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flymake-mode) - (doom-modeline-update-flymake))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-unicode-fallback val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flymake-mode) - (doom-modeline-update-flymake))))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-check-simple-format - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-check-simple-format val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (bound-and-true-p flymake-mode) - (doom-modeline-update-flymake))))))) - -(doom-modeline-def-segment check - "Displays color-coded error status in the current buffer with pretty icons." - (when-let* ((sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc)) - (seg (cond - ((and (bound-and-true-p flymake-mode) - (bound-and-true-p flymake--state)) ; only support 26+ - doom-modeline--flymake) - ((and (bound-and-true-p flycheck-mode) - (bound-and-true-p flycheck--automatically-enabled-checkers)) - doom-modeline--flycheck)))) - (concat - sep - (let ((str)) - (dolist (s (split-string seg " ")) - (setq str - (concat str - (if (string-match-p "^[0-9]+$" s) - (concat vsep - (doom-modeline-display-text s) - vsep) - (doom-modeline-display-icon s))))) - (propertize str - 'help-echo (get-text-property 0 'help-echo seg) - 'mouse-face 'doom-modeline-highlight - 'local-map (get-text-property 0 'local-map seg))) - sep))) - - -;; -;; Word Count -;; - -(doom-modeline-def-segment word-count - "The buffer word count. -Displayed when in a major mode in `doom-modeline-continuous-word-count-modes'. -Respects `doom-modeline-enable-word-count'." - (when (and doom-modeline-enable-word-count - (member major-mode doom-modeline-continuous-word-count-modes)) - (propertize (format " %dW" (count-words (point-min) (point-max))) - 'face (doom-modeline-face)))) - - -;; -;; Selection -;; - -(defsubst doom-modeline-column (pos) - "Get the column of the position `POS'." - (save-excursion (goto-char pos) - (current-column))) - -(doom-modeline-def-segment selection-info - "Information about the current selection. - -Such as how many characters and lines are selected, or the NxM dimensions of a -block selection." - (when (and (or mark-active (and (bound-and-true-p evil-local-mode) - (eq evil-state 'visual))) - (doom-modeline--active)) - (cl-destructuring-bind (beg . end) - (if (and (bound-and-true-p evil-local-mode) (eq evil-state 'visual)) - (cons evil-visual-beginning evil-visual-end) - (cons (region-beginning) (region-end))) - (propertize - (let ((lines (count-lines beg (min end (point-max))))) - (concat - " " - (cond ((or (bound-and-true-p rectangle-mark-mode) - (and (bound-and-true-p evil-visual-selection) - (eq 'block evil-visual-selection))) - (let ((cols (abs (- (doom-modeline-column end) - (doom-modeline-column beg))))) - (format "%dx%dB" lines cols))) - ((and (bound-and-true-p evil-visual-selection) - (eq evil-visual-selection 'line)) - (format "%dL" lines)) - ((> lines 1) - (format "%dC %dL" (- end beg) lines)) - (t - (format "%dC" (- end beg)))) - (when doom-modeline-enable-word-count - (format " %dW" (count-words beg end))) - " ")) - 'face 'doom-modeline-emphasis)))) - - -;; -;; Matches (macro, anzu, evil-substitute, iedit, symbol-overlay and multi-cursors) -;; - -(defsubst doom-modeline--macro-recording () - "Display current Emacs or evil macro being recorded." - (when (and (doom-modeline--active) - (or defining-kbd-macro executing-kbd-macro)) - (let ((sep (propertize " " 'face 'doom-modeline-panel)) - (vsep (propertize " " 'face - '(:inherit (doom-modeline-panel variable-pitch)))) - (macro-name (if (bound-and-true-p evil-this-macro) - (format " @%s " - (char-to-string evil-this-macro)) - "Macro"))) - (concat - sep - (if doom-modeline-always-show-macro-register - (propertize macro-name 'face 'doom-modeline-panel) - (concat - (doom-modeline-icon 'mdicon "nf-md-record" "●" - macro-name - :face '(:inherit (doom-modeline-urgent doom-modeline-panel)) - :v-adjust 0.15) - vsep - (doom-modeline-icon 'mdicon "nf-md-menu_right" "▶" ">" - :face 'doom-modeline-panel - :v-adjust 0.15))) - sep)))) - -;; `anzu' and `evil-anzu' expose current/total state that can be displayed in the -;; mode-line. -(defun doom-modeline-fix-anzu-count (positions here) - "Calulate anzu count via POSITIONS and HERE." - (cl-loop with i = 0 - for (start . end) in positions - do (cl-incf i) - when (and (>= here start) (<= here end)) - return i - finally return 0)) - -(advice-add #'anzu--where-is-here :override #'doom-modeline-fix-anzu-count) - -(setq anzu-cons-mode-line-p nil) ; manage modeline segment ourselves -;; Ensure anzu state is cleared when searches & iedit are done -(with-eval-after-load 'anzu - (add-hook 'isearch-mode-end-hook #'anzu--reset-status t) - (add-hook 'iedit-mode-end-hook #'anzu--reset-status) - (advice-add #'evil-force-normal-state :after #'anzu--reset-status) - ;; Fix matches segment mirroring across all buffers - (mapc #'make-variable-buffer-local - '(anzu--total-matched - anzu--current-position anzu--state anzu--cached-count - anzu--cached-positions anzu--last-command - anzu--last-isearch-string anzu--overflow-p))) - -(defsubst doom-modeline--anzu () - "Show the match index and total number thereof. -Requires `anzu', also `evil-anzu' if using `evil-mode' for compatibility with -`evil-search'." - (when (and (bound-and-true-p anzu--state) - (not (bound-and-true-p iedit-mode))) - (propertize - (let ((here anzu--current-position) - (total anzu--total-matched)) - (cond ((eq anzu--state 'replace-query) - (format " %d replace " anzu--cached-count)) - ((eq anzu--state 'replace) - (format " %d/%d " here total)) - (anzu--overflow-p - (format " %s+ " total)) - (t - (format " %s/%d " here total)))) - 'face (doom-modeline-face 'doom-modeline-panel)))) - -(defsubst doom-modeline--evil-substitute () - "Show number of matches for `evil-ex' in real time. -The number of matches contains substitutions and highlightings." - (when (and (bound-and-true-p evil-local-mode) - (or (assq 'evil-ex-substitute evil-ex-active-highlights-alist) - (assq 'evil-ex-global-match evil-ex-active-highlights-alist) - (assq 'evil-ex-buffer-match evil-ex-active-highlights-alist))) - (propertize - (let ((range (if evil-ex-range - (cons (car evil-ex-range) (cadr evil-ex-range)) - (cons (line-beginning-position) (line-end-position)))) - (pattern (car-safe (evil-delimited-arguments evil-ex-argument 2)))) - (if pattern - (format " %s matches " (how-many pattern (car range) (cdr range))) - " - ")) - 'face (doom-modeline-face 'doom-modeline-panel)))) - -(defun doom-modeline-themes--overlay-sort (a b) - "Sort overlay A and B." - (< (overlay-start a) (overlay-start b))) - -(defsubst doom-modeline--iedit () - "Show the number of iedit regions matches + what match you're on." - (when (and (bound-and-true-p iedit-mode) - (bound-and-true-p iedit-occurrences-overlays)) - (propertize - (let ((this-oc (or (let ((inhibit-message t)) - (iedit-find-current-occurrence-overlay)) - (save-excursion (iedit-prev-occurrence) - (iedit-find-current-occurrence-overlay)))) - (length (length iedit-occurrences-overlays))) - (format " %s/%d " - (if this-oc - (- length - (length (memq this-oc (sort (append iedit-occurrences-overlays nil) - #'doom-modeline-themes--overlay-sort))) - -1) - "-") - length)) - 'face (doom-modeline-face 'doom-modeline-panel)))) - -(defsubst doom-modeline--symbol-overlay () - "Show the number of matches for symbol overlay." - (when (and (doom-modeline--active) - (bound-and-true-p symbol-overlay-keywords-alist) - (not (bound-and-true-p symbol-overlay-temp-symbol)) - (not (bound-and-true-p iedit-mode))) - (let* ((keyword (symbol-overlay-assoc (symbol-overlay-get-symbol t))) - (symbol (car keyword)) - (before (symbol-overlay-get-list -1 symbol)) - (after (symbol-overlay-get-list 1 symbol)) - (count (length before))) - (if (symbol-overlay-assoc symbol) - (propertize - (format (concat " %d/%d " (and (cadr keyword) "in scope ")) - (+ count 1) - (+ count (length after))) - 'face (doom-modeline-face 'doom-modeline-panel)))))) - -(defsubst doom-modeline--multiple-cursors () - "Show the number of multiple cursors." - (cl-destructuring-bind (count . face) - (cond ((bound-and-true-p multiple-cursors-mode) - (cons (mc/num-cursors) - (doom-modeline-face 'doom-modeline-panel))) - ((bound-and-true-p evil-mc-cursor-list) - (cons (length evil-mc-cursor-list) - (doom-modeline-face (if evil-mc-frozen - 'doom-modeline-bar - 'doom-modeline-panel)))) - ((cons nil nil))) - (when count - (concat (propertize " " 'face face) - (if (doom-modeline-icon-displayable-p) - (doom-modeline-icon 'faicon "nf-fa-i_cursor" "" "" :face face) - (propertize "I" - 'face `(:inherit ,face :height 1.4 :weight normal) - 'display '(raise -0.1))) - (propertize " " - 'face `(:inherit (variable-pitch ,face))) - (propertize (format "%d " count) - 'face face))))) - -(defsubst doom-modeline--phi-search () - "Show the number of matches for `phi-search' and `phi-replace'." - (when (and (doom-modeline--active) - (bound-and-true-p phi-search--overlays)) - (let ((total (length phi-search--overlays)) - (selection phi-search--selection)) - (when selection - (propertize - (format " %d/%d " (1+ selection) total) - 'face (doom-modeline-face 'doom-modeline-panel)))))) - -(defun doom-modeline--override-phi-search (orig-fun &rest args) - "Override the mode-line of `phi-search' and `phi-replace'. -Apply ORIG-FUN with ARGS." - (if (bound-and-true-p doom-modeline-mode) - (apply orig-fun mode-line-format (cdr args)) - (apply orig-fun args))) -(advice-add #'phi-search--initialize :around #'doom-modeline--override-phi-search) - -(defsubst doom-modeline--buffer-size () - "Show buffer size." - (when size-indication-mode - (let ((sep (doom-modeline-spc))) - (concat sep - (propertize "%I" - 'face (doom-modeline-face) - 'help-echo "Buffer size -mouse-1: Display Line and Column Mode Menu" - 'mouse-face 'doom-modeline-highlight - 'local-map mode-line-column-line-number-mode-map) - sep)))) - -(doom-modeline-def-segment matches - "Displays matches. - -Including: -1. the currently recording macro, 2. A current/total for the -current search term (with `anzu'), 3. The number of substitutions being -conducted with `evil-ex-substitute', and/or 4. The number of active `iedit' -regions, 5. The current/total for the highlight term (with `symbol-overlay'), -6. The number of active `multiple-cursors'." - (let ((meta (concat (doom-modeline--macro-recording) - (doom-modeline--anzu) - (doom-modeline--phi-search) - (doom-modeline--evil-substitute) - (doom-modeline--iedit) - (doom-modeline--symbol-overlay) - (doom-modeline--multiple-cursors)))) - (or (and (not (string-empty-p meta)) meta) - (doom-modeline--buffer-size)))) - -(doom-modeline-def-segment buffer-size - "Display buffer size." - (doom-modeline--buffer-size)) - -;; -;; Media -;; - -(doom-modeline-def-segment media-info - "Metadata regarding the current file, such as dimensions for images." - ;; TODO: Include other information - (cond ((eq major-mode 'image-mode) - (cl-destructuring-bind (width . height) - (when (fboundp 'image-size) - (image-size (image-get-display-property) :pixels)) - (format " %dx%d " width height))))) - - -;; -;; Bars -;; - -(defvar doom-modeline--bar-active nil) -(defvar doom-modeline--bar-inactive nil) - -(defsubst doom-modeline--bar () - "The default bar regulates the height of the mode-line in GUI." - (unless (and doom-modeline--bar-active doom-modeline--bar-inactive) - (let ((width doom-modeline-bar-width) - (height (max doom-modeline-height (doom-modeline--font-height)))) - (setq doom-modeline--bar-active - (doom-modeline--create-bar-image 'doom-modeline-bar width height) - doom-modeline--bar-inactive - (doom-modeline--create-bar-image - 'doom-modeline-bar-inactive width height)))) - (if (doom-modeline--active) - doom-modeline--bar-active - doom-modeline--bar-inactive)) - -(defun doom-modeline-refresh-bars () - "Refresh mode-line bars on next redraw." - (setq doom-modeline--bar-active nil - doom-modeline--bar-inactive nil)) - -(cl-defstruct doom-modeline--hud-cache active inactive top-margin bottom-margin) - -(defsubst doom-modeline--hud () - "Powerline's hud segment reimplemented in the style of Doom's bar segment." - (let* ((ws (window-start)) - (we (window-end)) - (bs (buffer-size)) - (height (max doom-modeline-height (doom-modeline--font-height))) - (top-margin (if (zerop bs) - 0 - (/ (* height (1- ws)) bs))) - (bottom-margin (if (zerop bs) - 0 - (max 0 (/ (* height (- bs we 1)) bs)))) - (cache (or (window-parameter nil 'doom-modeline--hud-cache) - (set-window-parameter - nil - 'doom-modeline--hud-cache - (make-doom-modeline--hud-cache))))) - (unless (and (doom-modeline--hud-cache-active cache) - (doom-modeline--hud-cache-inactive cache) - (= top-margin (doom-modeline--hud-cache-top-margin cache)) - (= bottom-margin - (doom-modeline--hud-cache-bottom-margin cache))) - (setf (doom-modeline--hud-cache-active cache) - (doom-modeline--create-hud-image - 'doom-modeline-bar 'default doom-modeline-bar-width - height top-margin bottom-margin) - (doom-modeline--hud-cache-inactive cache) - (doom-modeline--create-hud-image - 'doom-modeline-bar-inactive 'default doom-modeline-bar-width - height top-margin bottom-margin) - (doom-modeline--hud-cache-top-margin cache) top-margin - (doom-modeline--hud-cache-bottom-margin cache) bottom-margin)) - (if (doom-modeline--active) - (doom-modeline--hud-cache-active cache) - (doom-modeline--hud-cache-inactive cache)))) - -(defun doom-modeline-invalidate-huds () - "Invalidate all cached hud images." - (dolist (frame (frame-list)) - (dolist (window (window-list frame)) - (set-window-parameter window 'doom-modeline--hud-cache nil)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-height - (lambda (_sym val op _where) - (when (and (eq op 'set) (integerp val)) - (doom-modeline-refresh-bars) - (doom-modeline-invalidate-huds)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-bar-width - (lambda (_sym val op _where) - (when (and (eq op 'set) (integerp val)) - (doom-modeline-refresh-bars) - (doom-modeline-invalidate-huds)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym _val op _where) - (when (eq op 'set) - (doom-modeline-refresh-bars) - (doom-modeline-invalidate-huds)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym _val op _where) - (when (eq op 'set) - (doom-modeline-refresh-bars) - (doom-modeline-invalidate-huds)))) - -(add-hook 'window-configuration-change-hook #'doom-modeline-refresh-bars) -(add-hook 'window-configuration-change-hook #'doom-modeline-invalidate-huds) - -(doom-modeline-def-segment bar - "The bar regulates the height of the `doom-modeline' in GUI." - (when (display-graphic-p) - (concat - (if doom-modeline-hud - (doom-modeline--hud) - (doom-modeline--bar)) - (doom-modeline-spc)))) - -(doom-modeline-def-segment hud - "Powerline's hud segment reimplemented in the style of bar segment." - (when (display-graphic-p) - (concat - (doom-modeline--hud) - (doom-modeline-spc)))) - - -;; -;; Window number -;; - -;; HACK: `ace-window-display-mode' should respect the ignore buffers. -(defun doom-modeline-aw-update () - "Update ace-window-path window parameter for all windows. -Ensure all windows are labeled so the user can select a specific -one. The ignored buffers are excluded unless `aw-ignore-on' is nil." - (let ((ignore-window-parameters t)) - (avy-traverse - (avy-tree (aw-window-list) aw-keys) - (lambda (path leaf) - (set-window-parameter - leaf 'ace-window-path - (propertize - (apply #'string (reverse path)) - 'face 'aw-mode-line-face)))))) -(advice-add #'aw-update :override #'doom-modeline-aw-update) - -;; Remove original window number of `ace-window-display-mode'. -(add-hook 'ace-window-display-mode-hook - (lambda () - (setq-default mode-line-format - (assq-delete-all 'ace-window-display-mode - (default-value 'mode-line-format))))) - -(advice-add #'window-numbering-install-mode-line :override #'ignore) -(advice-add #'window-numbering-clear-mode-line :override #'ignore) -(advice-add #'winum--install-mode-line :override #'ignore) -(advice-add #'winum--clear-mode-line :override #'ignore) - -(doom-modeline-def-segment window-number - "The current window number." - (let ((num (cond - ((bound-and-true-p ace-window-display-mode) - (aw-update) - (window-parameter (selected-window) 'ace-window-path)) - ((bound-and-true-p winum-mode) - (setq winum-auto-setup-mode-line nil) - (winum-get-number-string)) - ((bound-and-true-p window-numbering-mode) - (window-numbering-get-number-string)) - (t "")))) - (when (and (length> num 0) - (length> (cl-mapcan - (lambda (frame) - ;; Exclude minibuffer, tooltip and child frames - (unless (or (and (fboundp 'frame-parent) (frame-parent frame)) - (string= (frame-parameter frame 'name) - (alist-get 'name (bound-and-true-p tooltip-frame-parameters)))) - (window-list frame 'never))) - (visible-frame-list)) - 1)) - (propertize (format " %s " num) - 'face (doom-modeline-face 'doom-modeline-buffer-major-mode))))) - - -;; -;; Workspace -;; - -(doom-modeline-def-segment workspace-name - "The current workspace name or number. -Requires `eyebrowse-mode' to be enabled or `tab-bar-mode' tabs to be created." - (when doom-modeline-workspace-name - (when-let* - ((name (cond - ((and (bound-and-true-p eyebrowse-mode) - (length> (eyebrowse--get 'window-configs) 1)) - (setq mode-line-misc-info - (assq-delete-all 'eyebrowse-mode mode-line-misc-info)) - (when-let* - ((num (eyebrowse--get 'current-slot)) - (tag (nth 2 (assoc num (eyebrowse--get 'window-configs))))) - (if (length> tag 0) tag (int-to-string num)))) - ((and (fboundp 'tab-bar-mode) - (length> (frame-parameter nil 'tabs) 1)) - (let* ((current-tab (tab-bar--current-tab)) - (tab-index (tab-bar--current-tab-index)) - (explicit-name (alist-get 'explicit-name current-tab)) - (tab-name (alist-get 'name current-tab))) - (if explicit-name tab-name (+ 1 tab-index))))))) - (propertize (format " %s " name) - 'face (doom-modeline-face 'doom-modeline-buffer-major-mode))))) - - -;; -;; Perspective -;; - -(defvar-local doom-modeline--persp-name nil) -(defun doom-modeline-update-persp-name (&rest _) - "Update perspective name in mode-line." - (setq doom-modeline--persp-name - ;; Support `persp-mode', while not support `perspective' - (when (and doom-modeline-persp-name - (bound-and-true-p persp-mode) - (fboundp 'safe-persp-name) - (fboundp 'get-current-persp)) - (let* ((persp (get-current-persp)) - (name (safe-persp-name persp)) - (face (if (and persp - (not (persp-contain-buffer-p (current-buffer) persp))) - 'doom-modeline-persp-buffer-not-in-persp - 'doom-modeline-persp-name)) - (icon (doom-modeline-icon 'octicon "nf-oct-repo" "🖿" "#" - :face `(:inherit ,face :slant normal)))) - (when (or doom-modeline-display-default-persp-name - (not (string-equal persp-nil-name name))) - (concat " " - (propertize (concat (and doom-modeline-persp-icon - (concat icon - (propertize - " " - 'display '((space :relative-width 0.5))))) - (propertize name 'face face)) - 'help-echo "mouse-1: Switch perspective -mouse-2: Show help for minor mode" - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] - #'persp-switch) - (define-key map [mode-line mouse-2] - (lambda () - (interactive) - (describe-function 'persp-mode))) - map)) - " ")))))) - -(add-hook 'buffer-list-update-hook #'doom-modeline-update-persp-name) -(add-hook 'find-file-hook #'doom-modeline-update-persp-name) -(add-hook 'persp-activated-functions #'doom-modeline-update-persp-name) -(add-hook 'persp-renamed-functions #'doom-modeline-update-persp-name) -(advice-add #'lv-message :after #'doom-modeline-update-persp-name) - -(doom-modeline-def-segment persp-name - "The current perspective name." - (when (doom-modeline--segment-visible 'persp-name) - doom-modeline--persp-name)) - - -;; -;; Misc info -;; - -(doom-modeline-def-segment misc-info - "Mode line construct for miscellaneous information. -By default, this shows the information specified by `global-mode-string'." - (when (or doom-modeline-display-misc-in-all-mode-lines - (doom-modeline--segment-visible 'misc-info)) - (doom-modeline-display-text - (string-replace "%" "%%" (format-mode-line mode-line-misc-info))))) - - -;; -;; Position -;; - -(doom-modeline-def-segment buffer-position - "The buffer position information." - (let ((visible (doom-modeline--segment-visible 'buffer-position)) - (sep (doom-modeline-spc)) - (wsep (doom-modeline-wspc)) - (face (doom-modeline-face)) - (help-echo "Buffer percentage\n\ -mouse-1: Display Line and Column Mode Menu") - (mouse-face 'doom-modeline-highlight) - (local-map mode-line-column-line-number-mode-map)) - `(,wsep - - ;; Line and column - (:propertize - ((line-number-mode - (column-number-mode - (doom-modeline-column-zero-based - doom-modeline-position-column-line-format - ,(string-replace - "%c" "%C" (car doom-modeline-position-column-line-format))) - doom-modeline-position-line-format) - (column-number-mode - (doom-modeline-column-zero-based - doom-modeline-position-column-format - ,(string-replace - "%c" "%C" (car doom-modeline-position-column-format))))) - (doom-modeline-total-line-number - ,(and doom-modeline-total-line-number - (format "/%d" (line-number-at-pos (point-max)))))) - face ,face - help-echo ,help-echo - mouse-face ,mouse-face - local-map ,local-map) - - ((or line-number-mode column-number-mode) - ,sep) - - ;; Position - (,visible - ,(cond - ((bound-and-true-p nyan-mode) - (concat sep (nyan-create) sep)) - ((bound-and-true-p poke-line-mode) - (concat sep (poke-line-create) sep)) - ((bound-and-true-p mlscroll-mode) - (concat sep - (let ((mlscroll-right-align nil)) - (format-mode-line (mlscroll-mode-line))) - sep)) - ((bound-and-true-p sml-modeline-mode) - (concat sep (sml-modeline-create) sep)) - (t ""))) - - ;; Percent position - (doom-modeline-percent-position - ((:propertize ("" doom-modeline-percent-position) - face ,face - help-echo ,help-echo - mouse-face ,mouse-face - local-map ,local-map) - ,sep))))) - -;; -;; Party parrot -;; -(doom-modeline-def-segment parrot - "The party parrot animated icon. Requires `parrot-mode' to be enabled." - (when (and (doom-modeline--segment-visible 'parrot) - (bound-and-true-p parrot-mode)) - (concat (doom-modeline-wspc) - (parrot-create) - (doom-modeline-spc)))) - -;; -;; Modals (evil, overwrite, god, ryo and xah-fly-keys, etc.) -;; - -(defun doom-modeline--modal-icon (text face help-echo &optional icon unicode) - "Display the model icon with FACE and HELP-ECHO. -TEXT is alternative if icon is not available." - (propertize (doom-modeline-icon - 'mdicon - (and doom-modeline-modal-icon - (or (and doom-modeline-modal-modern-icon icon) - "nf-md-record")) - (or (and doom-modeline-modal-modern-icon unicode) "●") - text - :face (doom-modeline-face face)) - 'help-echo help-echo)) - -(defsubst doom-modeline--evil () - "The current evil state. Requires `evil-mode' to be enabled." - (when (bound-and-true-p evil-local-mode) - (doom-modeline--modal-icon - (let ((tag (evil-state-property evil-state :tag t))) - (if (stringp tag) tag (funcall tag))) - (cond - ((evil-normal-state-p) 'doom-modeline-evil-normal-state) - ((evil-emacs-state-p) 'doom-modeline-evil-emacs-state) - ((evil-insert-state-p) 'doom-modeline-evil-insert-state) - ((evil-motion-state-p) 'doom-modeline-evil-motion-state) - ((evil-visual-state-p) 'doom-modeline-evil-visual-state) - ((evil-operator-state-p) 'doom-modeline-evil-operator-state) - ((evil-replace-state-p) 'doom-modeline-evil-replace-state) - (t 'doom-modeline-evil-user-state)) - (evil-state-property evil-state :name t) - (cond - ((evil-normal-state-p) "nf-md-alpha_n_circle") - ((evil-emacs-state-p) "nf-md-alpha_e_circle") - ((evil-insert-state-p) "nf-md-alpha_i_circle") - ((evil-motion-state-p) "nf-md-alpha_m_circle") - ((evil-visual-state-p) "nf-md-alpha_v_circle") - ((evil-operator-state-p) "nf-md-alpha_o_circle") - ((evil-replace-state-p) "nf-md-alpha_r_circle") - (t "nf-md-alpha_u_circle")) - (cond - ((evil-normal-state-p) "🅝") - ((evil-emacs-state-p) "🅔") - ((evil-insert-state-p) "🅘") - ((evil-motion-state-p) "🅜") - ((evil-visual-state-p) "🅥") - ((evil-operator-state-p) "🅞") - ((evil-replace-state-p) "🅡") - (t "🅤"))))) - -(defsubst doom-modeline--overwrite () - "The current overwrite state which is enabled by command `overwrite-mode'." - (when (and (bound-and-true-p overwrite-mode) - (not (bound-and-true-p evil-local-mode))) - (doom-modeline--modal-icon - "<W>" 'doom-modeline-overwrite "Overwrite mode" - "nf-md-marker" "🅦"))) - -(defsubst doom-modeline--god () - "The current god state which is enabled by the command `god-mode'." - (when (bound-and-true-p god-local-mode) - (doom-modeline--modal-icon - "<G>" 'doom-modeline-god "God mode" - "nf-md-account_circle" "🅖"))) - -(defsubst doom-modeline--ryo () - "The current ryo-modal state which is enabled by the command `ryo-modal-mode'." - (when (bound-and-true-p ryo-modal-mode) - (doom-modeline--modal-icon - "<R>" 'doom-modeline-ryo "Ryo modal" - "nf-md-star_circle" "✪"))) - -(defsubst doom-modeline--xah-fly-keys () - "The current `xah-fly-keys' state." - (when (bound-and-true-p xah-fly-keys) - (if xah-fly-insert-state-p - (doom-modeline--modal-icon - "<I>" 'doom-modeline-fly-insert-state "Xah-fly insert mode" - "nf-md-airplane_edit" "🛧") - (doom-modeline--modal-icon - "<C>" 'doom-modeline-fly-normal-state "Xah-fly command mode" - "nf-md-airplane_cog" "🛧")))) - -(defsubst doom-modeline--boon () - "The current Boon state. Requires `boon-mode' to be enabled." - (when (bound-and-true-p boon-local-mode) - (doom-modeline--modal-icon - (boon-state-string) - (cond - (boon-command-state 'doom-modeline-boon-command-state) - (boon-insert-state 'doom-modeline-boon-insert-state) - (boon-special-state 'doom-modeline-boon-special-state) - (boon-off-state 'doom-modeline-boon-off-state) - (t 'doom-modeline-boon-off-state)) - (boon-modeline-string) - "nf-md-coffee" "🍵"))) - -(defsubst doom-modeline--meow () - "The current Meow state. Requires `meow-mode' to be enabled." - (when (bound-and-true-p meow-mode) - (doom-modeline--modal-icon - (substring-no-properties meow--indicator) - (cond - ((meow-normal-mode-p) 'doom-modeline-meow-normal-state) - ((meow-insert-mode-p) 'doom-modeline-meow-insert-state) - ((meow-beacon-mode-p) 'doom-modeline-meow-beacon-state) - ((meow-motion-mode-p) 'doom-modeline-meow-motion-state) - ((meow-keypad-mode-p) 'doom-modeline-meow-keypad-state) - (t 'doom-modeline-meow-normal-state)) - (symbol-name (meow--current-state)) - (cond - ((meow-normal-mode-p) "nf-md-alpha_n_circle") - ((meow-insert-mode-p) "nf-md-alpha_i_circle") - ((meow-beacon-mode-p) "nf-md-alpha_b_circle") - ((meow-motion-mode-p) "nf-md-alpha_m_circle") - ((meow-keypad-mode-p) "nf-md-alpha_k_circle") - (t "nf-md-alpha_n_circle")) - (cond - ((meow-normal-mode-p) "🅝") - ((meow-insert-mode-p) "🅘") - ((meow-beacon-mode-p) "🅑") - ((meow-motion-mode-p) "🅜") - ((meow-keypad-mode-p) "🅚") - (t "🅝"))))) - -(doom-modeline-def-segment modals - "Displays modal editing states. - -Including `evil', `overwrite', `god', `ryo' and `xha-fly-kyes', etc." - (when doom-modeline-modal - (let* ((evil (doom-modeline--evil)) - (ow (doom-modeline--overwrite)) - (god (doom-modeline--god)) - (ryo (doom-modeline--ryo)) - (xf (doom-modeline--xah-fly-keys)) - (boon (doom-modeline--boon)) - (vsep (doom-modeline-vspc)) - (meow (doom-modeline--meow)) - (sep (and (or evil ow god ryo xf boon) (doom-modeline-spc)))) - (concat sep - (and evil (concat evil (and (or ow god ryo xf boon meow) vsep))) - (and ow (concat ow (and (or god ryo xf boon meow) vsep))) - (and god (concat god (and (or ryo xf boon meow) vsep))) - (and ryo (concat ryo (and (or xf boon meow) vsep))) - (and xf (concat xf (and (or boon meow) vsep))) - (and boon (concat boon (and meow vsep))) - meow - sep)))) - -;; -;; Objed state -;; - -(defvar doom-modeline--objed-active nil) - -(defun doom-modeline-update-objed (_ &optional reset) - "Update `objed' status, inactive when RESET is true." - (setq doom-modeline--objed-active (not reset))) - -(setq objed-modeline-setup-func #'doom-modeline-update-objed) - -(doom-modeline-def-segment objed-state () - "The current objed state." - (when (and doom-modeline--objed-active - (doom-modeline--active)) - (propertize (format " %s(%s) " - (symbol-name objed--object) - (char-to-string (aref (symbol-name objed--obj-state) 0))) - 'face 'doom-modeline-evil-emacs-state - 'help-echo (format "Objed object: %s (%s)" - (symbol-name objed--object) - (symbol-name objed--obj-state))))) - - -;; -;; Input method -;; - -(doom-modeline-def-segment input-method - "The current input method." - (when-let* ((im (cond - (current-input-method - current-input-method-title) - ((and (bound-and-true-p evil-local-mode) - (bound-and-true-p evil-input-method)) - (nth 3 (assoc default-input-method input-method-alist))) - (t nil))) - (sep (doom-modeline-spc))) - (concat - sep - (propertize im - 'face (doom-modeline-face - (if (and (bound-and-true-p rime-mode) - (equal current-input-method "rime")) - (if (and (rime--should-enable-p) - (not (rime--should-inline-ascii-p))) - 'doom-modeline-input-method - 'doom-modeline-input-method-alt) - 'doom-modeline-input-method)) - 'help-echo (concat - "Current input method: " - current-input-method - "\n\ -mouse-2: Disable input method\n\ -mouse-3: Describe current input method") - 'mouse-face 'doom-modeline-highlight - 'local-map mode-line-input-method-map) - sep))) - - -;; -;; Info -;; - -(doom-modeline-def-segment info-nodes - "The topic and nodes in the Info buffer." - (concat - " (" - ;; topic - (propertize (if (stringp Info-current-file) - (replace-regexp-in-string - "%" "%%" - (file-name-sans-extension - (file-name-nondirectory Info-current-file))) - (format "*%S*" Info-current-file)) - 'face (doom-modeline-face 'doom-modeline-info)) - ") " - ;; node - (when Info-current-node - (propertize (replace-regexp-in-string - "%" "%%" Info-current-node) - 'face (doom-modeline-face 'doom-modeline-buffer-path) - 'help-echo - "mouse-1: scroll forward, mouse-3: scroll back" - 'mouse-face 'doom-modeline-highlight - 'local-map Info-mode-line-node-keymap)))) - - -;; -;; REPL -;; - -(defun doom-modeline-repl-icon (text face) - "Display REPL icon (or TEXT in terminal) with FACE." - (doom-modeline-icon 'faicon "nf-fa-terminal" "$" text :face face)) - -(defvar doom-modeline--cider nil) - -(defun doom-modeline-update-cider () - "Update cider repl state." - (setq doom-modeline--cider - (let* ((connected (cider-connected-p)) - (face (if connected 'doom-modeline-repl-success 'doom-modeline-repl-warning)) - (repl-buffer (cider-current-repl nil nil)) - (cider-info (when repl-buffer - (cider--connection-info repl-buffer t))) - (icon (doom-modeline-repl-icon "REPL" face))) - (propertize icon - 'help-echo - (if connected - (format "CIDER Connected %s\nmouse-2: CIDER quit" cider-info) - "CIDER Disconnected\nmouse-1: CIDER jack-in") - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (if connected - (define-key map [mode-line mouse-2] - #'cider-quit) - (define-key map [mode-line mouse-1] - #'cider-jack-in)) - map))))) - -(add-hook 'cider-connected-hook #'doom-modeline-update-cider) -(add-hook 'cider-disconnected-hook #'doom-modeline-update-cider) -(add-hook 'cider-mode-hook #'doom-modeline-update-cider) - -(doom-modeline-def-segment repl - "The REPL state." - (when doom-modeline-repl - (when-let* ((icon (when (bound-and-true-p cider-mode) - doom-modeline--cider)) - (sep (doom-modeline-spc))) - (concat - sep - (doom-modeline-display-icon icon) - sep)))) - - -;; -;; LSP -;; - -(defun doom-modeline-lsp-icon (text face) - "Display LSP icon (or TEXT in terminal) with FACE." - (if doom-modeline-lsp-icon - (doom-modeline-icon 'octicon "nf-oct-rocket" "🚀" text :face face) - (propertize text 'face face))) - -(defvar-local doom-modeline--lsp nil) -(defun doom-modeline-update-lsp (&rest _) - "Update `lsp-mode' state." - (setq doom-modeline--lsp - (let* ((workspaces (lsp-workspaces)) - (face (if workspaces 'doom-modeline-lsp-success 'doom-modeline-lsp-warning)) - (icon (doom-modeline-lsp-icon "LSP" face))) - (propertize icon - 'help-echo - (if workspaces - (concat "LSP connected " - (string-join - (mapcar (lambda (w) - (format "[%s]\n" (lsp--workspace-print w))) - workspaces)) - "C-mouse-1: Switch to another workspace folder -mouse-1: Describe current session -mouse-2: Quit server -mouse-3: Reconnect to server") - "LSP Disconnected -mouse-1: Reload to start server") - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (if workspaces - (progn - (define-key map [mode-line C-mouse-1] - #'lsp-workspace-folders-open) - (define-key map [mode-line mouse-1] - #'lsp-describe-session) - (define-key map [mode-line mouse-2] - #'lsp-workspace-shutdown) - (define-key map [mode-line mouse-3] - #'lsp-workspace-restart)) - (progn - (define-key map [mode-line mouse-1] - (lambda () - (interactive) - (ignore-errors (revert-buffer t t)))))) - map))))) -(add-hook 'lsp-before-initialize-hook #'doom-modeline-update-lsp) -(add-hook 'lsp-after-initialize-hook #'doom-modeline-update-lsp) -(add-hook 'lsp-after-uninitialized-functions #'doom-modeline-update-lsp) -(add-hook 'lsp-before-open-hook #'doom-modeline-update-lsp) -(add-hook 'lsp-after-open-hook #'doom-modeline-update-lsp) - -(defun doom-modeline--eglot-pending-count (server) - "Get count of pending eglot requests to SERVER." - (if (fboundp 'jsonrpc-continuation-count) - (jsonrpc-continuation-count server) - (hash-table-count (jsonrpc--request-continuations server)))) - -(defvar-local doom-modeline--eglot nil) -(defun doom-modeline-update-eglot () - "Update eglot state." - (setq doom-modeline--eglot - (let* ((server (and (eglot-managed-p) (eglot-current-server))) - (nick (and server (eglot-project-nickname server))) - (pending (and server (doom-modeline--eglot-pending-count server))) - (last-error (and server (jsonrpc-last-error server))) - (face (cond (last-error 'doom-modeline-lsp-error) - ((and pending (cl-plusp pending)) 'doom-modeline-lsp-warning) - (nick 'doom-modeline-lsp-success) - (t 'doom-modeline-lsp-warning))) - (server-info (and server (eglot--server-info server))) - (server-name (or (plist-get server-info :name) - (and server (jsonrpc-name server)) "")) - (major-modes (or (and server (eglot--major-modes server)) "")) - (icon (doom-modeline-lsp-icon eglot-menu-string face))) - (propertize icon - 'help-echo (format "Eglot connected [%s]\n%s %s -mouse-1: Display minor mode menu -mouse-3: LSP server control menu" - nick server-name major-modes) - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] eglot-menu) - (define-key map [mode-line mouse-3] eglot-server-menu) - map))))) -(add-hook 'eglot-managed-mode-hook #'doom-modeline-update-eglot) - -(defvar-local doom-modeline--tags nil) -(defun doom-modeline-update-tags () - "Update tags state." - (setq doom-modeline--tags - (propertize - (doom-modeline-lsp-icon "Tags" 'doom-modeline-lsp-success) - 'help-echo "Tags: Citre mode -mouse-1: Toggle citre mode" - 'mouse-face 'doom-modeline-highlight - 'local-map (make-mode-line-mouse-map 'mouse-1 #'citre-mode)))) -(add-hook 'citre-mode-hook #'doom-modeline-update-tags) - -(defun doom-modeline-update-lsp-icon () - "Update lsp icon." - (cond ((bound-and-true-p lsp-mode) - (doom-modeline-update-lsp)) - ((bound-and-true-p eglot--managed-mode) - (doom-modeline-update-eglot)) - ((bound-and-true-p citre-mode) - (doom-modeline-update-tags)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-lsp-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-lsp-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-lsp-icon)))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-lsp-icon)))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-unicode-fallback val) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (doom-modeline-update-lsp-icon)))))) - -(doom-modeline-def-segment lsp - "The LSP server state." - (when doom-modeline-lsp - (when-let* ((icon (cond ((bound-and-true-p lsp-mode) - doom-modeline--lsp) - ((bound-and-true-p eglot--managed-mode) - doom-modeline--eglot) - ((bound-and-true-p citre-mode) - doom-modeline--tags))) - (sep (doom-modeline-spc))) - (concat - sep - (doom-modeline-display-icon icon) - sep)))) - -(defun doom-modeline-override-eglot () - "Override `eglot' mode-line." - (if (and doom-modeline-lsp - (bound-and-true-p doom-modeline-mode)) - (setq mode-line-misc-info - (delq (assq 'eglot--managed-mode mode-line-misc-info) mode-line-misc-info)) - (add-to-list 'mode-line-misc-info - `(eglot--managed-mode (" [" eglot--mode-line-format "] "))))) -(add-hook 'eglot-managed-mode-hook #'doom-modeline-override-eglot) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-eglot) - -(doom-modeline-add-variable-watcher - 'doom-modeline-battery - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-lsp val) - (doom-modeline-override-eglot)))) - - -;; -;; GitHub -;; - -(defvar doom-modeline--github-notification-number 0) -(defvar doom-modeline-before-github-fetch-notification-hook nil - "Hooks before fetching GitHub notifications. -Example: - (add-hook \\='doom-modeline-before-github-fetch-notification-hook - #\\='auth-source-pass-enable)") - -(defvar doom-modeline-after-github-fetch-notification-hook nil - "Hooks after fetching GitHub notifications.") - -(defun doom-modeline--github-fetch-notifications () - "Fetch GitHub notifications." - (when (and doom-modeline-github - (require 'async nil t)) - (async-start - `(lambda () - ,(async-inject-variables - "\\`\\(load-path\\|auth-sources\\|doom-modeline-before-github-fetch-notification-hook\\)\\'") - (run-hooks 'doom-modeline-before-github-fetch-notification-hook) - (when (require 'ghub nil t) - (with-timeout (10) - (ignore-errors - (when-let* ((username (ghub--username ghub-default-host)) - (token (or (ghub--token ghub-default-host username 'forge t) - (ghub--token ghub-default-host username 'ghub t)))) - (ghub-get "/notifications" - '((notifications . t)) - :host ghub-default-host - :username username - :auth token - :unpaginate t - :noerror t)))))) - (lambda (result) - (message "") ; suppress message - (setq doom-modeline--github-notification-number (length result)) - (run-hooks 'doom-modeline-after-github-fetch-notification-hook))))) - -(defvar doom-modeline--github-timer nil) -(defun doom-modeline-github-timer () - "Start/Stop the timer for GitHub fetching." - (if (timerp doom-modeline--github-timer) - (cancel-timer doom-modeline--github-timer)) - (setq doom-modeline--github-timer - (and doom-modeline-github - (run-with-idle-timer 30 - doom-modeline-github-interval - #'doom-modeline--github-fetch-notifications)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-github - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-github val) - (doom-modeline-github-timer)))) - -(doom-modeline-github-timer) - -(doom-modeline-def-segment github - "The GitHub notifications." - (when (and doom-modeline-github - (doom-modeline--segment-visible 'github) - (numberp doom-modeline--github-notification-number)) - (let ((sep (doom-modeline-spc))) - (concat - sep - (propertize - (concat - (doom-modeline-icon 'octicon "nf-oct-mark_github" "🔔" "&" - :face 'doom-modeline-notification) - (and (> doom-modeline--github-notification-number 0) (doom-modeline-vspc)) - (propertize - (cond - ((<= doom-modeline--github-notification-number 0) "") - ((> doom-modeline--github-notification-number 99) "99+") - (t (number-to-string doom-modeline--github-notification-number))) - 'face '(:inherit - (doom-modeline-unread-number doom-modeline-notification)))) - 'help-echo "Github Notifications -mouse-1: Show notifications -mouse-3: Fetch notifications" - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] - (lambda () - "Open GitHub notifications page." - (interactive) - (run-with-idle-timer 300 nil #'doom-modeline--github-fetch-notifications) - (browse-url "https://github.com/notifications"))) - (define-key map [mode-line mouse-3] - (lambda () - "Fetching GitHub notifications." - (interactive) - (message "Fetching GitHub notifications...") - (doom-modeline--github-fetch-notifications))) - map)) - sep)))) - - -;; -;; Debug states -;; - -;; Highlight the doom-modeline while debugging. -(defvar-local doom-modeline--debug-cookie nil) -(defun doom-modeline--debug-visual (&rest _) - "Update the face of mode-line for debugging." - (mapc (lambda (buffer) - (with-current-buffer buffer - (setq doom-modeline--debug-cookie - (face-remap-add-relative 'doom-modeline 'doom-modeline-debug-visual)) - (force-mode-line-update))) - (buffer-list))) - -(defun doom-modeline--normal-visual (&rest _) - "Restore the face of mode-line." - (mapc (lambda (buffer) - (with-current-buffer buffer - (when doom-modeline--debug-cookie - (face-remap-remove-relative doom-modeline--debug-cookie) - (force-mode-line-update)))) - (buffer-list))) - -(add-hook 'dap-session-created-hook #'doom-modeline--debug-visual) -(add-hook 'dap-terminated-hook #'doom-modeline--normal-visual) - -(defun doom-modeline-debug-icon (face) - "Display debug icon with FACE and ARGS." - (doom-modeline-icon 'codicon "nf-cod-debug" "🐛" "!" :face face)) - -(defun doom-modeline--debug-dap () - "The current `dap-mode' state." - (when (and (bound-and-true-p dap-mode) - (bound-and-true-p lsp-mode)) - (when-let* ((session (dap--cur-session))) - (when (dap--session-running session) - (propertize (doom-modeline-debug-icon 'doom-modeline-info) - 'help-echo (format "DAP (%s - %s) -mouse-1: Display debug hydra -mouse-2: Display recent configurations -mouse-3: Disconnect session" - (dap--debug-session-name session) - (dap--debug-session-state session)) - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] - #'dap-hydra) - (define-key map [mode-line mouse-2] - #'dap-debug-recent) - (define-key map [mode-line mouse-3] - #'dap-disconnect) - map)))))) - -(defvar-local doom-modeline--debug-dap nil) -(defun doom-modeline-update-debug-dap (&rest _) - "Update dap debug state." - (setq doom-modeline--debug-dap (doom-modeline--debug-dap))) - -(add-hook 'dap-session-created-hook #'doom-modeline-update-debug-dap) -(add-hook 'dap-session-changed-hook #'doom-modeline-update-debug-dap) -(add-hook 'dap-terminated-hook #'doom-modeline-update-debug-dap) - -(defsubst doom-modeline--debug-edebug () - "The current `edebug' state." - (when (bound-and-true-p edebug-mode) - (propertize (doom-modeline-debug-icon 'doom-modeline-info) - 'help-echo (format "EDebug (%s) -mouse-1: Show help -mouse-2: Next -mouse-3: Stop debugging" - edebug-execution-mode) - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] - #'edebug-help) - (define-key map [mode-line mouse-2] - #'edebug-next-mode) - (define-key map [mode-line mouse-3] - #'edebug-stop) - map)))) - -(defsubst doom-modeline--debug-on-error () - "The current `debug-on-error' state." - (when debug-on-error - (propertize (doom-modeline-debug-icon 'doom-modeline-urgent) - 'help-echo "Debug on Error -mouse-1: Toggle Debug on Error" - 'mouse-face 'doom-modeline-highlight - 'local-map (make-mode-line-mouse-map 'mouse-1 #'toggle-debug-on-error)))) - -(defsubst doom-modeline--debug-on-quit () - "The current `debug-on-quit' state." - (when debug-on-quit - (propertize (doom-modeline-debug-icon 'doom-modeline-warning) - 'help-echo "Debug on Quit -mouse-1: Toggle Debug on Quit" - 'mouse-face 'doom-modeline-highlight - 'local-map (make-mode-line-mouse-map 'mouse-1 #'toggle-debug-on-quit)))) - -(doom-modeline-def-segment debug - "The current debug state." - (when (doom-modeline--segment-visible 'debug) - (let* ((dap doom-modeline--debug-dap) - (edebug (doom-modeline--debug-edebug)) - (on-error (doom-modeline--debug-on-error)) - (on-quit (doom-modeline--debug-on-quit)) - (vsep (doom-modeline-vspc)) - (sep (and (or dap edebug on-error on-quit) (doom-modeline-spc)))) - (concat sep - (and dap (concat dap (and (or edebug on-error on-quit) vsep))) - (and edebug (concat edebug (and (or on-error on-quit) vsep))) - (and on-error (concat on-error (and on-quit vsep))) - on-quit - sep)))) - - -;; -;; PDF pages -;; - -(defvar-local doom-modeline--pdf-pages nil) -(defun doom-modeline-update-pdf-pages () - "Update PDF pages." - (setq doom-modeline--pdf-pages - (format " P%d/%d " - (or (eval `(pdf-view-current-page)) 0) - (pdf-cache-number-of-pages)))) -(add-hook 'pdf-view-change-page-hook #'doom-modeline-update-pdf-pages) - -(doom-modeline-def-segment pdf-pages - "Display PDF pages." - doom-modeline--pdf-pages) - - -;; -;; `mu4e' notifications -;; - -(doom-modeline-def-segment mu4e - "Show notifications of any unread emails in `mu4e'." - (when (and doom-modeline-mu4e - (doom-modeline--segment-visible 'mu4e)) - (let ((sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc)) - (icon (doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" - :face 'doom-modeline-notification))) - (cond ((and (bound-and-true-p mu4e-alert-mode-line) - (numberp mu4e-alert-mode-line) - ;; don't display if the unread mails count is zero - (> mu4e-alert-mode-line 0)) - (concat - sep - (propertize - (concat - icon - vsep - (propertize - (if (> mu4e-alert-mode-line doom-modeline-number-limit) - (format "%d+" doom-modeline-number-limit) - (number-to-string mu4e-alert-mode-line)) - 'face '(:inherit - (doom-modeline-unread-number doom-modeline-notification)))) - 'mouse-face 'doom-modeline-highlight - 'keymap '(mode-line keymap - (mouse-1 . mu4e-alert-view-unread-mails) - (mouse-2 . mu4e-alert-view-unread-mails) - (mouse-3 . mu4e-alert-view-unread-mails)) - 'help-echo (concat (if (= mu4e-alert-mode-line 1) - "You have an unread email" - (format "You have %s unread emails" mu4e-alert-mode-line)) - "\nClick here to view " - (if (= mu4e-alert-mode-line 1) "it" "them"))) - sep)) - ((bound-and-true-p mu4e-modeline-mode) - (concat sep icon vsep - (propertize (mu4e--modeline-string) - 'face 'doom-modeline-notification) - sep)))))) - -(defun doom-modeline-override-mu4e-alert (&rest _) - "Delete `mu4e-alert-mode-line' from global modeline string." - (when (and (featurep 'mu4e-alert) - (bound-and-true-p mu4e-alert-mode-line)) - (if (and doom-modeline-mu4e - (bound-and-true-p doom-modeline-mode)) - ;; Delete original modeline - (progn - (setq global-mode-string - (delete '(:eval mu4e-alert-mode-line) global-mode-string)) - (setq mu4e-alert-modeline-formatter #'identity)) - ;; Recover default settings - (setq mu4e-alert-modeline-formatter #'mu4e-alert-default-mode-line-formatter)))) -(advice-add #'mu4e-alert-enable-mode-line-display - :after #'doom-modeline-override-mu4e-alert) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-alert) - -(defun doom-modeline-override-mu4e-modeline (&rest _) - "Delete `mu4e-alert-mode-line' from global modeline string." - (when (bound-and-true-p mu4e-modeline-mode) - (if (and doom-modeline-mu4e - (bound-and-true-p doom-modeline-mode)) - ;; Delete original modeline - (setq global-mode-string - (delete mu4e--modeline-item global-mode-string)) - ;; Recover default settings - (add-to-list 'global-mode-string mu4e--modeline-item)))) -(add-hook 'mu4e-modeline-mode-hook #'doom-modeline-override-mu4e-modeline) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-modeline) - -(doom-modeline-add-variable-watcher - 'doom-modeline-mu4e - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-mu4e val) - (doom-modeline-override-mu4e-alert) - (doom-modeline-override-mu4e-modeline)))) - - -;; -;; `gnus' notifications -;; - -(defvar doom-modeline--gnus-unread-mail 0) -(defvar doom-modeline--gnus-started nil - "Used to determine if gnus has started.") -(defun doom-modeline-update-gnus-status (&rest _) - "Get the total number of unread news of gnus group." - (setq doom-modeline--gnus-unread-mail - (when (and doom-modeline-gnus - doom-modeline--gnus-started) - (let ((total-unread-news-number 0)) - (mapc (lambda (g) - (let* ((group (car g)) - (unread (eval `(gnus-group-unread ,group)))) - (when (and (not (seq-contains-p doom-modeline-gnus-excluded-groups group)) - (numberp unread) - (> unread 0)) - (setq total-unread-news-number (+ total-unread-news-number unread))))) - gnus-newsrc-alist) - total-unread-news-number)))) - -;; Update the modeline after changes have been made -(add-hook 'gnus-group-update-hook #'doom-modeline-update-gnus-status) -(add-hook 'gnus-summary-update-hook #'doom-modeline-update-gnus-status) -(add-hook 'gnus-group-update-group-hook #'doom-modeline-update-gnus-status) -(add-hook 'gnus-after-getting-new-news-hook #'doom-modeline-update-gnus-status) - -;; Only start to listen to gnus when gnus is actually running -(defun doom-modeline-start-gnus-listener () - "Start GNUS listener." - (when (and doom-modeline-gnus - (not doom-modeline--gnus-started)) - (setq doom-modeline--gnus-started t) - ;; Scan gnus in the background if the timer is higher than 0 - (doom-modeline-update-gnus-status) - (if (> doom-modeline-gnus-timer 0) - (gnus-demon-add-handler 'gnus-demon-scan-news doom-modeline-gnus-timer doom-modeline-gnus-idle)))) -(add-hook 'gnus-started-hook #'doom-modeline-start-gnus-listener) - -;; Stop the listener if gnus isn't running -(defun doom-modeline-stop-gnus-listener () - "Stop GNUS listener." - (setq doom-modeline--gnus-started nil)) -(add-hook 'gnus-exit-gnus-hook #'doom-modeline-stop-gnus-listener) - -(doom-modeline-def-segment gnus - "Show notifications of any unread emails in `gnus'." - (when (and (doom-modeline--segment-visible 'gnus) - doom-modeline-gnus - doom-modeline--gnus-started - ;; Don't display if the unread mails count is zero - (numberp doom-modeline--gnus-unread-mail) - (> doom-modeline--gnus-unread-mail 0)) - (let ((sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc))) - (concat - sep - (propertize - (concat - (doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" - :face 'doom-modeline-notification) - vsep - (propertize - (if (> doom-modeline--gnus-unread-mail doom-modeline-number-limit) - (format "%d+" doom-modeline-number-limit) - (number-to-string doom-modeline--gnus-unread-mail)) - 'face '(:inherit - (doom-modeline-unread-number doom-modeline-notification)))) - 'mouse-face 'doom-modeline-highlight - 'help-echo (if (= doom-modeline--gnus-unread-mail 1) - "You have an unread email" - (format "You have %s unread emails" doom-modeline--gnus-unread-mail))) - sep)))) - - -;; -;; IRC notifications -;; - -(defun doom-modeline-shorten-irc (name) - "Shorten IRC buffer `name' according to IRC mode. - -Calls the mode specific function to return the shortened -version of `NAME' if applicable: -- Circe: `tracking-shorten' -- ERC: `erc-track-shorten-function' -- rcirc: `rcirc-shorten-buffer-name' - -The specific function will decide how to stylize the buffer name, -read the individual functions documentation for more." - (or (and (fboundp 'tracking-shorten) - (car (tracking-shorten (list name)))) - (and (boundp 'erc-track-shorten-function) - (functionp erc-track-shorten-function) - (car (funcall erc-track-shorten-function (list name)))) - (and (fboundp 'rcirc-short-buffer-name) - (rcirc-short-buffer-name name)) - name)) - -(defun doom-modeline--tracking-buffers (buffers) - "Logic to convert some irc BUFFERS to their font-awesome icon." - (mapconcat - (lambda (b) - (propertize - (funcall doom-modeline-irc-stylize b) - 'face '(:inherit (doom-modeline-unread-number doom-modeline-notification)) - 'help-echo (format "IRC Notification: %s\nmouse-1: Switch to buffer" b) - 'mouse-face 'doom-modeline-highlight - 'local-map (make-mode-line-mouse-map - 'mouse-1 - (lambda () - (interactive) - (when (buffer-live-p (get-buffer b)) - (switch-to-buffer b)))))) - buffers - (doom-modeline-vspc))) - -(defun doom-modeline--circe-p () - "Check if `circe' is in use." - (boundp 'tracking-mode-line-buffers)) - -(defun doom-modeline--erc-p () - "Check if `erc' is in use." - (boundp 'erc-modified-channels-alist)) - -(defun doom-modeline--rcirc-p () - "Check if `rcirc' is in use." - (bound-and-true-p rcirc-track-minor-mode)) - -(defun doom-modeline--get-buffers () - "Gets the buffers that have activity." - (cond - ((doom-modeline--circe-p) - tracking-buffers) - ((doom-modeline--erc-p) - (mapcar (lambda (l) - (buffer-name (car l))) - erc-modified-channels-alist)) - ((doom-modeline--rcirc-p) - (mapcar (lambda (b) - (buffer-name b)) - rcirc-activity)))) - -;; Create a modeline segment that contains all the irc tracked buffers -(doom-modeline-def-segment irc-buffers - "The list of shortened, unread irc buffers." - (when (and doom-modeline-irc - (doom-modeline--segment-visible 'irc-buffers)) - (let* ((buffers (doom-modeline--get-buffers)) - (number (length buffers)) - (sep (doom-modeline-spc))) - (when (> number 0) - (concat - sep - (doom-modeline--tracking-buffers buffers) - sep))))) - -(doom-modeline-def-segment irc - "A notification icon for any unread irc buffer." - (when (and doom-modeline-irc - (doom-modeline--segment-visible 'irc)) - (let* ((buffers (doom-modeline--get-buffers)) - (number (length buffers)) - (sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc))) - (when (> number 0) - (concat - sep - - (propertize (concat - (doom-modeline-icon 'mdicon "nf-md-message_processing" "🗊" "#" - :face 'doom-modeline-notification) - vsep - ;; Display the number of unread buffers - (propertize (number-to-string number) - 'face '(:inherit - (doom-modeline-unread-number - doom-modeline-notification)))) - 'help-echo (format "IRC Notifications: %s\n%s" - (mapconcat - (lambda (b) (funcall doom-modeline-irc-stylize b)) - buffers - ", ") - (cond - ((doom-modeline--circe-p) - "mouse-1: Switch to previous unread buffer -mouse-3: Switch to next unread buffer") - ((doom-modeline--erc-p) - "mouse-1: Switch to buffer -mouse-3: Switch to next unread buffer") - ((doom-modeline--rcirc-p) - "mouse-1: Switch to server buffer -mouse-3: Switch to next unread buffer"))) - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (cond - ((doom-modeline--circe-p) - (define-key map [mode-line mouse-1] - #'tracking-previous-buffer) - (define-key map [mode-line mouse-3] - #'tracking-next-buffer)) - ((doom-modeline--erc-p) - (define-key map [mode-line mouse-1] - #'erc-switch-to-buffer) - (define-key map [mode-line mouse-3] - #'erc-track-switch-buffer)) - ((doom-modeline--rcirc-p) - (define-key map [mode-line mouse-1] - #'rcirc-switch-to-server-buffer) - (define-key map [mode-line mouse-3] - #'rcirc-next-active-buffer))) - map)) - - ;; Display the unread irc buffers as well - (when doom-modeline-irc-buffers - (concat sep (doom-modeline--tracking-buffers buffers))) - - sep))))) - -(defun doom-modeline-override-rcirc () - "Override default `rcirc' mode-line." - (if (and doom-modeline-irc - (bound-and-true-p doom-modeline-mode)) - (setq global-mode-string - (delq 'rcirc-activity-string global-mode-string)) - (when (and rcirc-track-minor-mode - (not (memq 'rcirc-activity-string global-mode-string))) - (setq global-mode-string - (append global-mode-string '(rcirc-activity-string)))))) -(add-hook 'rcirc-track-minor-mode-hook #'doom-modeline-override-rcirc) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-rcirc) - -(doom-modeline-add-variable-watcher - 'doom-modeline-irc - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-irc val) - (doom-modeline-override-rcirc)))) - - -;; -;; Battery status -;; - -(defun doom-modeline-battery-icon (icon unicode text face) - "Displays the battery ICON with FACE. - -UNICODE and TEXT are fallbacks. -Uses `nerd-icons-mdicon' to fetch the icon." - (doom-modeline-icon 'mdicon icon unicode text :face face)) - -(defvar doom-modeline--battery-status nil) -(defun doom-modeline-update-battery-status () - "Update battery status." - (setq doom-modeline--battery-status - (when (and doom-modeline-battery - (bound-and-true-p display-battery-mode)) - (let* ((data (and battery-status-function - (functionp battery-status-function) - (funcall battery-status-function))) - (status (cdr (assoc ?L data))) - (charging? (or (string-equal "AC" status) - (string-equal "on-line" status))) - (percentage (car (read-from-string (or (cdr (assq ?p data)) "ERR")))) - (valid-percentage? (and (numberp percentage) - (>= percentage 0) - (<= percentage battery-mode-line-limit))) - (face (if valid-percentage? - (cond (charging? 'doom-modeline-battery-charging) - ((< percentage battery-load-critical) 'doom-modeline-battery-critical) - ((< percentage 25) 'doom-modeline-battery-warning) - ((< percentage 95) 'doom-modeline-battery-normal) - (t 'doom-modeline-battery-full)) - 'doom-modeline-battery-error)) - (icon (if valid-percentage? - (cond - ((>= percentage 100) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_100" - "nf-md-battery") - "🔋" "-" face)) - ((>= percentage 90) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_90" - "nf-md-battery_90") - "🔋" "-" face)) - ((>= percentage 80) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_80" - "nf-md-battery_80") - "🔋" "-" face)) - ((>= percentage 70) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_70" - "nf-md-battery_70") - "🔋" "-" face)) - ((>= percentage 60) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_60" - "nf-md-battery_60") - "🔋" "-" face)) - ((>= percentage 50) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_50" - "nf-md-battery_50") - "🔋" "-" face)) - ((>= percentage 40) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_40" - "nf-md-battery_40") - "🔋" "-" face)) - ((>= percentage 30) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_30" - "nf-md-battery_30") - "🔋" "-" face)) - ((>= percentage 20) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_20" - "nf-md-battery_20") - "🔋" "-" face)) - ((>= percentage 10) - (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_10" - "nf-md-battery_10") - "🪫" "-" face)) - (t (doom-modeline-battery-icon (if charging? - "nf-md-battery_charging_outline" - "nf-md-battery_outline") - "🪫" "!" face))) - (doom-modeline-battery-icon "nf-md-battery_alert" "⚠" "N/A" face))) - (text (if valid-percentage? (format "%d%s" percentage "%%") "")) - (help-echo (if (and battery-echo-area-format data valid-percentage?) - (battery-format battery-echo-area-format data) - "Battery status not available"))) - (cons (propertize icon 'help-echo help-echo) - (propertize text 'face face 'help-echo help-echo)))))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-icon - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-icon val) - (doom-modeline-update-battery-status)))) - -(doom-modeline-add-variable-watcher - 'doom-modeline-unicode-fallback - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-unicode-fallback val) - (doom-modeline-update-battery-status)))) - -(doom-modeline-def-segment battery - "Display battery status." - (when (and doom-modeline-battery - (bound-and-true-p display-battery-mode) - (doom-modeline--segment-visible 'battery)) - (let ((sep (doom-modeline-spc)) - (vsep (doom-modeline-vspc))) - (concat sep - (car doom-modeline--battery-status) - vsep - (cdr doom-modeline--battery-status) - sep)))) - -(defun doom-modeline-override-battery () - "Override default battery mode-line." - (if (and doom-modeline-battery - (bound-and-true-p doom-modeline-mode)) - (progn - (advice-add #'battery-update :override #'doom-modeline-update-battery-status) - (setq global-mode-string - (delq 'battery-mode-line-string global-mode-string)) - (and (bound-and-true-p display-battery-mode) (battery-update))) - (progn - (advice-remove #'battery-update #'doom-modeline-update-battery-status) - (when (and display-battery-mode battery-status-function battery-mode-line-format - (not (memq 'battery-mode-line-string global-mode-string))) - (setq global-mode-string - (append global-mode-string '(battery-mode-line-string))))))) -(add-hook 'display-battery-mode-hook #'doom-modeline-override-battery) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-battery) - -(doom-modeline-add-variable-watcher - 'doom-modeline-battery - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-battery val) - (doom-modeline-override-battery)))) - - -;; -;; Package information -;; - -(doom-modeline-def-segment package - "Show package information via `paradox'." - (concat - (doom-modeline-display-text - (format-mode-line 'mode-line-front-space)) - - (when (and doom-modeline-icon doom-modeline-major-mode-icon) - (concat - (doom-modeline-spc) - (doom-modeline-icon 'faicon "nf-fa-archive" nil nil - :face (doom-modeline-face - (if doom-modeline-major-mode-color-icon - 'nerd-icons-silver - 'mode-line))))) - (doom-modeline-display-text - (format-mode-line 'mode-line-buffer-identification)))) - - -;; -;; Helm -;; - -(defvar doom-modeline--helm-buffer-ids - '(("*helm*" . "HELM") - ("*helm M-x*" . "HELM M-x") - ("*swiper*" . "SWIPER") - ("*Projectile Perspectives*" . "HELM Projectile Perspectives") - ("*Projectile Layouts*" . "HELM Projectile Layouts") - ("*helm-ag*" . (lambda () - (format "HELM Ag: Using %s" - (car (split-string helm-ag-base-command)))))) - "Alist of custom helm buffer names to use. -The cdr can also be a function that returns a name to use.") - -(doom-modeline-def-segment helm-buffer-id - "Helm session identifier." - (when (bound-and-true-p helm-alive-p) - (let ((sep (doom-modeline-spc))) - (concat - sep - (when doom-modeline-icon - (concat - (doom-modeline-icon 'sucicon "nf-custom-emacs" nil nil - :face (doom-modeline-face - (and doom-modeline-major-mode-color-icon - 'nerd-icons-blue))) - sep)) - (propertize - (let ((custom (cdr (assoc (buffer-name) doom-modeline--helm-buffer-ids))) - (case-fold-search t) - (name (replace-regexp-in-string "-" " " (buffer-name)))) - (cond ((stringp custom) custom) - ((functionp custom) (funcall custom)) - (t - (string-match "\\*helm:? \\(mode \\)?\\([^\\*]+\\)\\*" name) - (concat "HELM " (capitalize (match-string 2 name)))))) - 'face (doom-modeline-face 'doom-modeline-buffer-file)) - sep)))) - -(doom-modeline-def-segment helm-number - "Number of helm candidates." - (when (bound-and-true-p helm-alive-p) - (concat - (propertize (format " %d/%d" - (helm-candidate-number-at-point) - (helm-get-candidate-number t)) - 'face (doom-modeline-face 'doom-modeline-buffer-path)) - (propertize (format " (%d total) " (helm-get-candidate-number)) - 'face (doom-modeline-face 'doom-modeline-info))))) - -(doom-modeline-def-segment helm-help - "Helm keybindings help." - (when (bound-and-true-p helm-alive-p) - (mapcar - (lambda (s) - (if (string-prefix-p "\\<" s) - (propertize (substitute-command-keys s) - 'face (doom-modeline-face - 'doom-modeline-buffer-file)) - s)) - '("\\<helm-map>\\[helm-help]" "(help) " - "\\<helm-map>\\[helm-select-action]" "(actions) " - "\\<helm-map>\\[helm-maybe-exit-minibuffer]/F1/F2..." "(action) ")))) - -(doom-modeline-def-segment helm-prefix-argument - "Helm prefix argument." - (when (and (bound-and-true-p helm-alive-p) - helm--mode-line-display-prefarg) - (let ((arg (prefix-numeric-value (or prefix-arg current-prefix-arg)))) - (unless (= arg 1) - (propertize (format "C-u %s" arg) - 'face (doom-modeline-face 'doom-modeline-info)))))) - -(defvar doom-modeline--helm-current-source nil - "The currently active helm source.") -(doom-modeline-def-segment helm-follow - "Helm follow indicator." - (and (bound-and-true-p helm-alive-p) - doom-modeline--helm-current-source - (eq 1 (cdr (assq 'follow doom-modeline--helm-current-source))) - "HF")) - -;; -;; Git timemachine -;; - -(doom-modeline-def-segment git-timemachine - (concat - (doom-modeline-spc) - (doom-modeline--buffer-mode-icon) - (doom-modeline--buffer-state-icon) - (propertize - "*%b*" - 'face (doom-modeline-face 'doom-modeline-buffer-timemachine)))) - -;; -;; Markdown/Org preview -;; - -(doom-modeline-def-segment grip - (when (bound-and-true-p grip-mode) - (let ((sep (doom-modeline-spc))) - (concat - sep - (let ((face (doom-modeline-face - (if grip--process - (pcase (process-status grip--process) - ('run 'doom-modeline-info) - ('exit 'doom-modeline-warning) - (_ 'doom-modeline-urgent)) - 'doom-modeline-urgent)))) - (propertize - (doom-modeline-icon 'codicon "nf-cod-open_preview" "🗐" "@" :face face) - 'help-echo (format "Preview on %s -mouse-1: Preview in browser -mouse-2: Stop preview -mouse-3: Restart preview" - (grip--preview-url)) - 'mouse-face 'doom-modeline-highlight - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] - #'grip-browse-preview) - (define-key map [mode-line mouse-2] - #'grip-stop-preview) - (define-key map [mode-line mouse-3] - #'grip-restart-preview) - map))) - sep)))) - -;; -;; Follow mode -;; - -(doom-modeline-def-segment follow - (when (bound-and-true-p follow-mode) - (let* ((windows (follow-all-followers)) - (nwindows (length windows)) - (nfollowing (- (length (memq (selected-window) windows)) 1))) - (concat - (doom-modeline-spc) - (propertize (format "Follow %d/%d" (- nwindows nfollowing) nwindows) - 'face 'doom-modeline-buffer-minor-mode))))) - -;; -;; Display time -;; - -(defconst doom-modeline--clock-hour-hand-ratio 0.45 - "Length of the hour hand as a proportion of the radius.") - -(defconst doom-modeline--clock-minute-hand-ratio 0.7 - "Length of the minute hand as a proportion of the radius.") - -(defun doom-modeline--create-clock-svg (hour minute radius color) - "Construct an SVG clock showing the time HOUR:MINUTE. -The clock will be of the specified RADIUS and COLOR." - (let ((thickness-factor (image-compute-scaling-factor 'auto)) - (hour-x (* radius (sin (* (- 6 hour (/ minute 60.0)) (/ float-pi 6))) - doom-modeline--clock-hour-hand-ratio)) - (hour-y (* radius (cos (* (- 6 hour (/ minute 60.0)) (/ float-pi 6))) - doom-modeline--clock-hour-hand-ratio)) - (minute-x (* radius (sin (* (- 30 minute) (/ float-pi 30))) - doom-modeline--clock-minute-hand-ratio)) - (minute-y (* radius (cos (* (- 30 minute) (/ float-pi 30))) - doom-modeline--clock-minute-hand-ratio)) - (svg (svg-create (* 2 radius) (* 2 radius) :stroke color))) - (svg-circle svg radius radius (- radius thickness-factor) - :fill "none" :stroke-width (* 2 thickness-factor)) - (svg-circle svg radius radius thickness-factor - :fill color :stroke "none") - (svg-line svg radius radius (+ radius hour-x) (+ radius hour-y) - :stroke-width (* 2 thickness-factor)) - (svg-line svg radius radius (+ radius minute-x) (+ radius minute-y) - :stroke-width (* 1.5 thickness-factor)) - svg)) - -(defvar doom-modeline--clock-cache nil - "The last result of `doom-modeline--generate-clock'.") - -(defun doom-modeline--generate-clock () - "Return a string containing the current time as an analogue clock svg. -When the svg library is not available, return nil." - (cdr - (or (and (equal (truncate (float-time) - (* doom-modeline-time-clock-minute-resolution 60)) - (car doom-modeline--clock-cache)) - doom-modeline--clock-cache) - (and (require 'svg nil t) - (setq doom-modeline--clock-cache - (cons (truncate (float-time) - (* doom-modeline-time-clock-minute-resolution 60)) - (propertize - " " - 'display - (svg-image - (doom-modeline--create-clock-svg - (string-to-number (format-time-string "%-I")) ; hour - (* (truncate (string-to-number (format-time-string "%-M")) - doom-modeline-time-clock-minute-resolution) - doom-modeline-time-clock-minute-resolution) ; minute - (if (integerp doom-modeline-time-clock-size) ; radius - doom-modeline-time-clock-size - (* doom-modeline-height 0.5 doom-modeline-time-clock-size)) - "currentColor") - :scale 1 :ascent 'center) - 'face 'doom-modeline-time - 'help-echo (lambda (_window _object _pos) - (format-time-string "%c"))))))))) - -(defun doom-modeline-time-icon () - "Displays the time icon." - (or (and doom-modeline-time-live-icon - doom-modeline-time-analogue-clock - (display-graphic-p) - (doom-modeline--generate-clock)) - (doom-modeline-icon - 'mdicon - (if doom-modeline-time-live-icon - (pcase (% (caddr (decode-time)) 12) - (0 "nf-md-clock_time_twelve_outline") - (1 "nf-md-clock_time_one_outline") - (2 "nf-md-clock_time_two_outline") - (3 "nf-md-clock_time_three_outline") - (4 "nf-md-clock_time_four_outline") - (5 "nf-md-clock_time_five_outline") - (6 "nf-md-clock_time_six_outline") - (7 "nf-md-clock_time_seven_outline") - (8 "nf-md-clock_time_eight_outline") - (9 "nf-md-clock_time_nine_outline") - (10 "nf-md-clock_time_ten_outline") - (11 "nf-md-clock_time_eleven_outline")) - "nf-md-clock_outline") - "⏰" - "" - :face '(:inherit doom-modeline-time :weight normal)))) - -(doom-modeline-def-segment time - (when (and doom-modeline-time - (bound-and-true-p display-time-mode) - (doom-modeline--segment-visible 'time)) - (concat - (doom-modeline-spc) - (when doom-modeline-time-icon - (concat - (doom-modeline-time-icon) - (and (or doom-modeline-icon doom-modeline-unicode-fallback) - (doom-modeline-vspc)))) - (propertize display-time-string - 'face (doom-modeline-face 'doom-modeline-time))))) - -(defun doom-modeline-override-time () - "Override default `display-time' mode-line." - (or global-mode-string (setq global-mode-string '(""))) - (if (and doom-modeline-time - (bound-and-true-p doom-modeline-mode)) - (setq global-mode-string (delq 'display-time-string global-mode-string)) - (or (memq 'display-time-string global-mode-string) - (setq global-mode-string - (append global-mode-string '(display-time-string)))))) -(add-hook 'display-time-mode-hook #'doom-modeline-override-time) -(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-time) - -(doom-modeline-add-variable-watcher - 'doom-modeline-time - (lambda (_sym val op _where) - (when (eq op 'set) - (setq doom-modeline-time val) - (doom-modeline-override-time)))) - -;; -;; Compilation -;; - -(doom-modeline-def-segment compilation - (and (bound-and-true-p compilation-in-progress) - (propertize "[Compiling] " - 'face (doom-modeline-face 'doom-modeline-compilation) - 'help-echo "Compiling; mouse-2: Goto Buffer" - 'mouse-face 'doom-modeline-highlight - 'local-map - (make-mode-line-mouse-map - 'mouse-2 - #'compilation-goto-in-progress-buffer)))) - -;; -;; Eldoc -;; - -(doom-modeline-def-segment eldoc - (and (bound-and-true-p eldoc-mode) - '(eldoc-mode-line-string - (" " eldoc-mode-line-string " ")))) - -(defun doom-modeline-eldoc-minibuffer-message (format-string &rest args) - "Display message specified by FORMAT-STRING and ARGS on the mode-line as needed. -This function displays the message produced by formatting ARGS -with FORMAT-STRING on the mode line when the current buffer is a minibuffer. -Otherwise, it displays the message like `message' would." - (if (minibufferp) - (progn - (add-hook 'minibuffer-exit-hook - (lambda () (setq eldoc-mode-line-string nil - ;; https://debbugs.gnu.org/16920 - eldoc-last-message nil)) - nil t) - (with-current-buffer - (window-buffer - (or (window-in-direction 'above (minibuffer-window)) - (minibuffer-selected-window) - (get-largest-window))) - (setq eldoc-mode-line-string - (when (stringp format-string) - (apply #'format-message format-string args))) - (force-mode-line-update))) - (apply #'message format-string args))) - -;; -;; Kubernetes -;; - -(doom-modeline-def-segment k8s - (when (and (bound-and-true-p kele-mode) (doom-modeline--segment-visible 'k8s)) - (let* ((ctx (kele-current-context-name :wait nil)) - (ns (kele-current-namespace :wait nil)) - (icon (doom-modeline-icon 'mdicon "nf-md-kubernetes" "K8s:" "K8s:")) - (sep (doom-modeline-spc)) - (help-msg (let ((msgs (list (format "Current context: %s" ctx)))) - (when ns - (setq msgs (append msgs (list (format "Current namespace: %s" ns))))) - (string-join msgs "\n")))) - (propertize (concat - icon sep ctx - (when (and doom-modeline-k8s-show-namespace ns) (format "(%s)" ns)) - sep) - 'local-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] kele-menu-map) - map) - 'mouse-face 'doom-modeline-highlight - 'help-echo help-msg)))) - -(provide 'doom-modeline-segments) - -;;; doom-modeline-segments.el ends here diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-segments.elc b/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-segments.elc Binary files differ. diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline.el b/emacs/elpa/doom-modeline-20241102.1416/doom-modeline.el @@ -1,263 +0,0 @@ -;;; doom-modeline.el --- A minimal and modern mode-line -*- lexical-binding: t; -*- - -;; Copyright (C) 2018-2024 Vincent Zhang - -;; Author: Vincent Zhang <seagle0128@gmail.com> -;; Homepage: https://github.com/seagle0128/doom-modeline -;; Package-Version: 20241102.1416 -;; Package-Revision: 645ef52e2a5f -;; Package-Requires: ((emacs "25.1") (compat "29.1.4.5") (nerd-icons "0.1.0") (shrink-path "0.3.1")) -;; Keywords: faces mode-line - -;; This file is not part of GNU Emacs. - -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;; - -;;; Commentary: -;; -;; This package offers a fancy and fast mode-line inspired by minimalism design. -;; -;; It's integrated into Doom Emacs (https://github.com/hlissner/doom-emacs) and -;; Centaur Emacs (https://github.com/seagle0128/.emacs.d). -;; -;; The doom-modeline offers: -;; - A match count panel (for anzu, iedit, multiple-cursors, symbol-overlay, -;; evil-search and evil-substitute) -;; - An indicator for recording a macro -;; - Current environment version (e.g. python, ruby, go, etc.) in the major-mode -;; - A customizable mode-line height (see doom-modeline-height) -;; - A minor modes segment which is compatible with minions -;; - An error/warning count segment for flymake/flycheck -;; - A workspace number segment for eyebrowse -;; - A perspective name segment for persp-mode -;; - A window number segment for winum and window-numbering -;; - An indicator for modal editing state, including evil, overwrite, god, ryo -;; and xah-fly-keys, etc. -;; - An indicator for battery status -;; - An indicator for current input method -;; - An indicator for debug state -;; - An indicator for remote host -;; - An indicator for LSP state with lsp-mode or eglot -;; - An indicator for github notifications -;; - An indicator for unread emails with mu4e-alert -;; - An indicator for unread emails with gnus (basically builtin) -;; - An indicator for irc notifications with circe, rcirc or erc. -;; - An indicator for buffer position which is compatible with nyan-mode or poke-line -;; - An indicator for party parrot -;; - An indicator for PDF page number with pdf-tools -;; - An indicator for markdown/org previews with grip -;; - Truncated file name, file icon, buffer state and project name in buffer -;; information segment, which is compatible with project, find-file-in-project -;; and projectile -;; - New mode-line for Info-mode buffers -;; - New package mode-line for paradox -;; - New mode-line for helm buffers -;; - New mode-line for git-timemachine buffers -;; -;; Installation: -;; From melpa, `M-x package-install RET doom-modeline RET`. -;; In `init.el`, -;; (require 'doom-modeline) -;; (doom-modeline-mode 1) -;; or -;; (use-package doom-modeline -;; :ensure t -;; :hook (after-init . doom-modeline-mode)) -;; - -;;; Code: - -(require 'doom-modeline-core) -(require 'doom-modeline-segments) - - -;; -;; Mode lines -;; - -(doom-modeline-def-modeline 'main - '(eldoc bar workspace-name window-number modals matches follow buffer-info remote-host buffer-position word-count parrot selection-info) - '(compilation objed-state misc-info persp-name battery grip irc mu4e gnus github debug repl lsp minor-modes input-method indent-info buffer-encoding major-mode process vcs check time)) - -(doom-modeline-def-modeline 'minimal - '(bar window-number modals matches buffer-info-simple) - '(media-info major-mode time)) - -(doom-modeline-def-modeline 'special - '(eldoc bar window-number modals matches buffer-info remote-host buffer-position word-count parrot selection-info) - '(compilation objed-state misc-info battery irc-buffers debug minor-modes input-method indent-info buffer-encoding major-mode process time)) - -(doom-modeline-def-modeline 'project - '(bar window-number modals buffer-default-directory remote-host buffer-position) - '(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time)) - -(doom-modeline-def-modeline 'dashboard - '(bar window-number modals buffer-default-directory-simple remote-host) - '(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time)) - -(doom-modeline-def-modeline 'vcs - '(bar window-number modals matches buffer-info remote-host buffer-position parrot selection-info) - '(compilation misc-info battery irc mu4e gnus github debug minor-modes buffer-encoding major-mode process time)) - -(doom-modeline-def-modeline 'package - '(bar window-number modals package) - '(compilation misc-info major-mode process time)) - -(doom-modeline-def-modeline 'info - '(bar window-number modals buffer-info info-nodes buffer-position parrot selection-info) - '(compilation misc-info buffer-encoding major-mode time)) - -(doom-modeline-def-modeline 'media - '(bar window-number modals buffer-size buffer-info) - '(compilation misc-info media-info major-mode process vcs time)) - -(doom-modeline-def-modeline 'message - '(eldoc bar window-number modals matches buffer-info-simple buffer-position word-count parrot selection-info) - '(compilation objed-state misc-info battery debug minor-modes input-method indent-info buffer-encoding major-mode time)) - -(doom-modeline-def-modeline 'pdf - '(bar window-number modals matches buffer-info pdf-pages) - '(compilation misc-info major-mode process vcs time)) - -(doom-modeline-def-modeline 'org-src - '(eldoc bar window-number modals matches buffer-info buffer-position word-count parrot selection-info) - '(compilation objed-state misc-info debug lsp minor-modes input-method indent-info buffer-encoding major-mode process check time)) - -(doom-modeline-def-modeline 'helm - '(bar helm-buffer-id helm-number helm-follow helm-prefix-argument) - '(helm-help time)) - -(doom-modeline-def-modeline 'timemachine - '(eldoc bar window-number modals matches git-timemachine buffer-position word-count parrot selection-info) - '(misc-info minor-modes indent-info buffer-encoding major-mode time)) - -(doom-modeline-def-modeline 'calculator - '(window-number modals matches calc buffer-position) - '(misc-info minor-modes major-mode process)) - - -;; -;; Interfaces -;; - -;;;###autoload -(defun doom-modeline-set-main-modeline (&optional default) - "Set main mode-line. -If DEFAULT is non-nil, set the default mode-line for all buffers." - (doom-modeline-set-modeline 'main default)) - - -;; -;; Minor mode -;; - -;; Suppress warnings -(defvar 2C-mode-line-format) -(defvar flymake-mode-line-format) -(defvar helm-ag-show-status-function) -(declare-function helm-display-mode-line "ext:helm-core") - -(defvar doom-modeline-mode-map (make-sparse-keymap)) - -(defvar doom-modeline-mode-alist - '((message-mode . message) - (git-commit-mode . message) - (magit-mode . vcs) - (dashboard-mode . dashboard) - (Info-mode . info) - (image-mode . media) - (pdf-view-mode . pdf) - (org-src-mode . org-src) - (paradox-menu-mode . package) - (xwidget-webkit-mode . minimal) - (git-timemachine-mode . timemachine) - (calc-mode . calculator) - (calc-trail-mode . calculator) - (circe-mode . special) - (erc-mode . special) - (rcirc-mode . special)) - "Alist of major modes and mode-lines.") - -(defun doom-modeline-auto-set-modeline () - "Set mode-line base on major-mode." - (catch 'found - (dolist (x doom-modeline-mode-alist) - (when (derived-mode-p (car x)) - (doom-modeline-set-modeline (cdr x)) - (throw 'found x))))) - -(defun doom-modeline-set-helm-modeline (&rest _) ; To advice helm - "Set helm mode-line." - (doom-modeline-set-modeline 'helm)) - -;;;###autoload -(define-minor-mode doom-modeline-mode - "Toggle `doom-modeline' on or off." - :group 'doom-modeline - :global t - :lighter nil - :keymap doom-modeline-mode-map - (if doom-modeline-mode - (progn - (doom-modeline-refresh-bars) ; Create bars - (doom-modeline-set-main-modeline t) ; Set default mode-line - - ;; Apply to all existing buffers. - (dolist (buf (buffer-list)) - (with-current-buffer buf - (unless (doom-modeline-auto-set-modeline) - (doom-modeline-set-main-modeline)))) - - ;; For flymake - (setq flymake-mode-line-format nil) ; remove the lighter of minor mode - - ;; For Eldoc - (setq eldoc-message-function #'doom-modeline-eldoc-minibuffer-message) - - ;; For two-column editing - (setq 2C-mode-line-format (doom-modeline 'special)) - - ;; Automatically set mode-lines - (add-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline) - - ;; Special handles - (advice-add #'helm-display-mode-line :after #'doom-modeline-set-helm-modeline) - (setq helm-ag-show-status-function #'doom-modeline-set-helm-modeline)) - (progn - ;; Restore mode-line - (let ((original-format (doom-modeline--original-value 'mode-line-format))) - (setq-default mode-line-format original-format) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (setq mode-line-format original-format)))) - - ;; For flymake - (setq flymake-mode-line-format (doom-modeline--original-value 'flymake-mode-line-format)) - - ;; For Eldoc - (setq eldoc-message-function #'eldoc-minibuffer-message) - - ;; For two-column editing - (setq 2C-mode-line-format (doom-modeline--original-value '2C-mode-line-format)) - - ;; Cleanup - (remove-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline) - (advice-remove #'helm-display-mode-line #'doom-modeline-set-helm-modeline) - (setq helm-ag-show-status-function (default-value 'helm-ag-show-status-function))))) - -(provide 'doom-modeline) - -;;; doom-modeline.el ends here diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-autoloads.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-autoloads.el diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-core.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-core.el diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-core.elc b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-core.elc Binary files differ. diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-env.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-env.el diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline-env.elc b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-env.elc Binary files differ. diff --git a/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-pkg.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-pkg.el @@ -0,0 +1,13 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "doom-modeline" "20241117.1101" + "A minimal and modern mode-line." + '((emacs "25.1") + (compat "29.1.4.5") + (nerd-icons "0.1.0") + (shrink-path "0.3.1")) + :url "https://github.com/seagle0128/doom-modeline" + :commit "e6ae2ecfea9b5dd26191e131382a7505f7a775b9" + :revdesc "e6ae2ecfea9b" + :keywords '("faces" "mode-line") + :authors '(("Vincent Zhang" . "seagle0128@gmail.com")) + :maintainers '(("Vincent Zhang" . "seagle0128@gmail.com"))) diff --git a/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-segments.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-segments.el @@ -0,0 +1,3235 @@ +;;; doom-modeline-segments.el --- The segments for doom-modeline -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2024 Vincent Zhang + +;; This file is not part of GNU Emacs. + +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; + +;;; Commentary: +;; +;; The segments for doom-modeline. +;; Use `doom-modeline-def-segment' to create a new segment. +;; + +;;; Code: + +(require 'doom-modeline-core) +(require 'doom-modeline-env) +(eval-when-compile + (require 'cl-lib) + (require 'seq) + (require 'subr-x)) + + +;; +;; Externals +;; + +(defvar Info-current-file) +(defvar Info-current-node) +(defvar Info-mode-line-node-keymap) +(defvar anzu--cached-count) +(defvar anzu--current-position) +(defvar anzu--overflow-p) +(defvar anzu--state) +(defvar anzu--total-matched) +(defvar anzu-cons-mode-line-p) +(defvar aw-keys) +(defvar battery-echo-area-format) +(defvar battery-load-critical) +(defvar battery-mode-line-format) +(defvar battery-mode-line-limit) +(defvar battery-status-function) +(defvar boon-command-state) +(defvar boon-insert-state) +(defvar boon-off-state) +(defvar boon-special-state) +(defvar display-time-string) +(defvar edebug-execution-mode) +(defvar eglot--managed-mode) +(defvar eglot-menu) +(defvar eglot-menu-string) +(defvar eglot-server-menu) +(defvar erc-modified-channels-alist) +(defvar evil-ex-active-highlights-alist) +(defvar evil-ex-argument) +(defvar evil-ex-range) +(defvar evil-mc-frozen) +(defvar evil-state) +(defvar evil-visual-beginning) +(defvar evil-visual-end) +(defvar evil-visual-selection) +(defvar flycheck--automatically-enabled-checkers) +(defvar flycheck-current-errors) +(defvar flycheck-mode-menu-map) +(defvar flymake--mode-line-format) +(defvar flymake--state) +(defvar flymake-menu) +(defvar gnus-newsrc-alist) +(defvar gnus-newsrc-hashtb) +(defvar grip--process) +(defvar helm--mode-line-display-prefarg) +(defvar iedit-occurrences-overlays) +(defvar kele-menu-map) +(defvar meow--indicator) +(defvar minions-mode-line-lighter) +(defvar minions-mode-line-minor-modes-map) +(defvar mlscroll-right-align) +(defvar mu4e--modeline-item) +(defvar mu4e-alert-mode-line) +(defvar mu4e-alert-modeline-formatter) +(defvar mu4e-modeline-mode) +(defvar objed--obj-state) +(defvar objed--object) +(defvar objed-modeline-setup-func) +(defvar persp-nil-name) +(defvar phi-replace--mode-line-format) +(defvar phi-search--overlays) +(defvar phi-search--selection) +(defvar phi-search-mode-line-format) +(defvar rcirc-activity) +(defvar symbol-overlay-keywords-alist) +(defvar symbol-overlay-temp-symbol) +(defvar text-scale-mode-amount) +(defvar tracking-buffers) +(defvar winum-auto-setup-mode-line) +(defvar xah-fly-insert-state-p) + +(declare-function anzu--reset-status "ext:anzu") +(declare-function anzu--where-is-here "ext:anzu") +(declare-function async-inject-variables "ext:async") +(declare-function async-start "ext:async") +(declare-function avy-traverse "ext:avy") +(declare-function avy-tree "ext:avy") +(declare-function aw-update "ext:ace-window") +(declare-function aw-window-list "ext:ace-window") +(declare-function battery-format "battery") +(declare-function battery-update "battery") +(declare-function boon-modeline-string "ext:boon") +(declare-function boon-state-string "ext:boon") +(declare-function cider--connection-info "ext:cider") +(declare-function cider-connected-p "ext:cider") +(declare-function cider-current-repl "ext:cider") +(declare-function cider-jack-in "ext:cider") +(declare-function cider-quit "ext:cider") +(declare-function citre-mode "ext:citre-basic-tools") +(declare-function compilation-goto-in-progress-buffer "compile") +(declare-function dap--cur-session "ext:dap-mode") +(declare-function dap--debug-session-name "ext:dap-mode") +(declare-function dap--debug-session-state "ext:dap-mode") +(declare-function dap--session-running "ext:dap-mode") +(declare-function dap-debug-recent "ext:dap-mode") +(declare-function dap-disconnect "ext:dap-mode") +(declare-function dap-hydra "ext:dap-hydra") +(declare-function edebug-help "edebug") +(declare-function edebug-next-mode "edebug") +(declare-function edebug-stop "edebug") +(declare-function eglot--major-modes "eglot") +(declare-function eglot--server-info "eglot" t t) +(declare-function eglot-current-server "eglot") +(declare-function eglot-managed-p "eglot") +(declare-function eglot-project-nickname "eglot" t t) +(declare-function erc-switch-to-buffer "erc") +(declare-function erc-track-switch-buffer "erc-track") +(declare-function evil-delimited-arguments "ext:evil-common") +(declare-function evil-emacs-state-p "ext:evil-states" t t) +(declare-function evil-force-normal-state "ext:evil-commands" t t) +(declare-function evil-insert-state-p "ext:evil-states" t t) +(declare-function evil-motion-state-p "ext:evil-states" t t) +(declare-function evil-normal-state-p "ext:evil-states" t t) +(declare-function evil-operator-state-p "ext:evil-states" t t) +(declare-function evil-replace-state-p "ext:evil-states" t t) +(declare-function evil-state-property "ext:evil-common") +(declare-function evil-visual-state-p "ext:evil-states" t t) +(declare-function eyebrowse--get "ext:eyebrowse") +(declare-function face-remap-remove-relative "face-remap") +(declare-function fancy-narrow-active-p "ext:fancy-narrow") +(declare-function flycheck-buffer "ext:flycheck") +(declare-function flycheck-count-errors "ext:flycheck") +(declare-function flycheck-error-level-compilation-level "ext:flycheck") +(declare-function flycheck-list-errors "ext:flycheck") +(declare-function flycheck-next-error "ext:flycheck") +(declare-function flycheck-previous-error "ext:flycheck") +(declare-function flymake--diag-type "flymake" t t) +(declare-function flymake--handle-report "flymake") +(declare-function flymake--lookup-type-property "flymake") +(declare-function flymake--state-diags "flymake" t t) +(declare-function flymake-disabled-backends "flymake") +(declare-function flymake-goto-next-error "flymake") +(declare-function flymake-goto-prev-error "flymake") +(declare-function flymake-reporting-backends "flymake") +(declare-function flymake-running-backends "flymake") +(declare-function flymake-show-buffer-diagnostics "flymake") +(declare-function flymake-show-buffer-diagnostics "flymake") +(declare-function flymake-start "flymake") +(declare-function follow-all-followers "follow") +(declare-function gnus-demon-add-handler "gnus-demon") +(declare-function grip--preview-url "ext:grip-mode") +(declare-function grip-browse-preview "ext:grip-mode") +(declare-function grip-restart-preview "ext:grip-mode") +(declare-function grip-stop-preview "ext:grip-mode") +(declare-function helm-candidate-number-at-point "ext:helm-core") +(declare-function helm-get-candidate-number "ext:helm-core") +(declare-function iedit-find-current-occurrence-overlay "ext:iedit-lib") +(declare-function iedit-prev-occurrence "ext:iedit-lib") +(declare-function image-get-display-property "image-mode") +(declare-function jsonrpc--request-continuations "jsonrpc" t t) +(declare-function jsonrpc-last-error "jsonrpc" t t) +(declare-function jsonrpc-name "jsonrpc" t t) +(declare-function kele-current-context-name "ext:kele") +(declare-function kele-current-namespace "ext:kele") +(declare-function lsp--workspace-print "ext:lsp-mode") +(declare-function lsp-describe-session "ext:lsp-mode") +(declare-function lsp-workspace-folders-open "ext:lsp-mode") +(declare-function lsp-workspace-restart "ext:lsp-mode") +(declare-function lsp-workspace-shutdown "ext:lsp-mode") +(declare-function lsp-workspaces "ext:lsp-mode") +(declare-function lv-message "ext:lv") +(declare-function mc/num-cursors "ext:multiple-cursors-core") +(declare-function meow--current-state "ext:meow") +(declare-function meow-beacon-mode-p "ext:meow") +(declare-function meow-insert-mode-p "ext:meow") +(declare-function meow-keypad-mode-p "ext:meow") +(declare-function meow-motion-mode-p "ext:meow") +(declare-function meow-normal-mode-p "ext:meow") +(declare-function minions--prominent-modes "ext:minions") +(declare-function mlscroll-mode-line "ext:mlscroll") +(declare-function mu4e--modeline-string "ext:mu4e-modeline") +(declare-function mu4e-alert-default-mode-line-formatter "ext:mu4e-alert") +(declare-function mu4e-alert-enable-mode-line-display "ext:mu4e-alert") +(declare-function nyan-create "ext:nyan-mode") +(declare-function org-edit-src-save "org-src") +(declare-function parrot-create "ext:parrot") +(declare-function pdf-cache-number-of-pages "ext:pdf-cache" t t) +(declare-function persp-add-buffer "ext:persp-mode") +(declare-function persp-contain-buffer-p "ext:persp-mode") +(declare-function persp-switch "ext:persp-mode") +(declare-function phi-search--initialize "ext:phi-search") +(declare-function poke-line-create "ext:poke-line") +(declare-function popup-create "ext:popup") +(declare-function popup-delete "ext:popup") +(declare-function rcirc-next-active-buffer "rcirc") +(declare-function rcirc-short-buffer-name "rcirc") +(declare-function rcirc-switch-to-server-buffer "rcirc") +(declare-function rcirc-window-configuration-change "rcirc") +(declare-function rime--should-enable-p "ext:rime") +(declare-function rime--should-inline-ascii-p "ext:rime") +(declare-function sml-modeline-create "ext:sml-modeline") +(declare-function svg-circle "svg") +(declare-function svg-create "svg") +(declare-function svg-image "svg") +(declare-function svg-line "svg") +(declare-function symbol-overlay-assoc "ext:symbol-overlay") +(declare-function symbol-overlay-get-list "ext:symbol-overlay") +(declare-function symbol-overlay-get-symbol "ext:symbol-overlay") +(declare-function symbol-overlay-rename "ext:symbol-overlay") +(declare-function tab-bar--current-tab "tab-bar") +(declare-function tab-bar--current-tab-index "tab-bar") +(declare-function tracking-next-buffer "ext:tracking") +(declare-function tracking-previous-buffer "ext:tracking") +(declare-function tracking-shorten "ext:tracking") +(declare-function warning-numeric-level "warnings") +(declare-function window-numbering-clear-mode-line "ext:window-numbering") +(declare-function window-numbering-get-number-string "ext:window-numbering") +(declare-function window-numbering-install-mode-line "ext:window-numbering") +(declare-function winum--clear-mode-line "ext:winum") +(declare-function winum--install-mode-line "ext:winum") +(declare-function winum-get-number-string "ext:winum") + + + +;; +;; Buffer information +;; + +(defvar-local doom-modeline--buffer-file-icon nil) +(defun doom-modeline-update-buffer-file-icon (&rest _) + "Update file icon in mode-line." + (setq doom-modeline--buffer-file-icon + (when (and doom-modeline-major-mode-icon + (doom-modeline-icon-displayable-p)) + (let ((icon (doom-modeline-icon-for-buffer))) + (propertize (if (or (null icon) (symbolp icon)) + (doom-modeline-icon 'faicon "nf-fa-file_o" nil nil + :face 'nerd-icons-dsilver) + (doom-modeline-propertize-icon icon)) + 'help-echo (format "Major-mode: %s" (format-mode-line mode-name))))))) +(add-hook 'find-file-hook #'doom-modeline-update-buffer-file-icon) +(add-hook 'after-change-major-mode-hook #'doom-modeline-update-buffer-file-icon) +(add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-icon) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-buffer-file-icon)))))) + +(defun doom-modeline-buffer-file-state-icon (icon unicode text face) + "Displays an ICON of buffer state with FACE. +UNICODE and TEXT are the alternatives if it is not applicable. +Uses `nerd-icons-mdicon' to fetch the icon." + (doom-modeline-icon 'mdicon icon unicode text :face face)) + +(defvar-local doom-modeline--buffer-file-state-icon nil) +(defun doom-modeline-update-buffer-file-state-icon (&rest _) + "Update the buffer or file state in mode-line." + (setq doom-modeline--buffer-file-state-icon + (when doom-modeline-buffer-state-icon + (ignore-errors + (concat + (cond ((not (or (and (buffer-file-name) (file-remote-p buffer-file-name)) + (verify-visited-file-modtime (current-buffer)))) + (doom-modeline-buffer-file-state-icon + "nf-md-reload_alert" "⟳" "%1*" + 'doom-modeline-warning)) + (buffer-read-only + (doom-modeline-buffer-file-state-icon + "nf-md-lock" "🔒" "%1*" + 'doom-modeline-warning)) + ((and buffer-file-name (buffer-modified-p) + doom-modeline-buffer-modification-icon) + (doom-modeline-buffer-file-state-icon + "nf-md-content_save_edit" "💾" "%1*" + 'doom-modeline-warning)) + ((and buffer-file-name + ;; Avoid freezing while connection is lost + (not (file-remote-p buffer-file-name)) + (not (file-exists-p buffer-file-name))) + (doom-modeline-buffer-file-state-icon + "nf-md-cancel" "🚫" "!" + 'doom-modeline-urgent)) + (t "")) + (when (or (buffer-narrowed-p) + (and (bound-and-true-p fancy-narrow-mode) + (fancy-narrow-active-p)) + (bound-and-true-p dired-narrow-mode)) + (doom-modeline-buffer-file-state-icon + "nf-md-unfold_less_horizontal" "↕" "><" + 'doom-modeline-warning))))))) + +(defvar-local doom-modeline--buffer-file-name nil) +(defun doom-modeline-update-buffer-file-name (&rest _) + "Update buffer file name in mode-line." + (setq doom-modeline--buffer-file-name + (ignore-errors + (save-match-data + (if buffer-file-name + (doom-modeline-buffer-file-name) + (propertize "%b" + 'face 'doom-modeline-buffer-file + 'mouse-face 'doom-modeline-highlight + 'help-echo "Buffer name +mouse-1: Previous buffer\nmouse-3: Next buffer" + 'local-map mode-line-buffer-identification-keymap)))))) +(add-hook 'find-file-hook #'doom-modeline-update-buffer-file-name) +(add-hook 'after-save-hook #'doom-modeline-update-buffer-file-name) +(add-hook 'clone-indirect-buffer-hook #'doom-modeline-update-buffer-file-name) +(add-hook 'evil-insert-state-exit-hook #'doom-modeline-update-buffer-file-name) +(add-hook 'Info-selection-hook #'doom-modeline-update-buffer-file-name) +(advice-add #'rename-buffer :after #'doom-modeline-update-buffer-file-name) +(advice-add #'set-visited-file-name :after #'doom-modeline-update-buffer-file-name) +(advice-add #'pop-to-buffer :after #'doom-modeline-update-buffer-file-name) +(advice-add #'popup-create :after #'doom-modeline-update-buffer-file-name) +(advice-add #'popup-delete :after #'doom-modeline-update-buffer-file-name) +;; (advice-add #'primitive-undo :after #'doom-modeline-update-buffer-file-name) +;; (advice-add #'set-buffer-modified-p :after #'doom-modeline-update-buffer-file-name) + +(with-no-warnings + (if (boundp 'after-focus-change-function) + (progn + (advice-add #'handle-switch-frame :after #'doom-modeline-update-buffer-file-name) + (add-function :after after-focus-change-function #'doom-modeline-update-buffer-file-name)) + (progn + (add-hook 'focus-in-hook #'doom-modeline-update-buffer-file-name) + (add-hook 'focus-out-hook #'doom-modeline-update-buffer-file-name)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-buffer-file-name-style + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-buffer-file-name-style val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when buffer-file-name + (doom-modeline-update-buffer-file-name))))))) + +(defsubst doom-modeline--buffer-mode-icon () + "The icon of the current major mode." + (when (and doom-modeline-icon doom-modeline-major-mode-icon) + (when-let* ((icon (or doom-modeline--buffer-file-icon + (doom-modeline-update-buffer-file-icon)))) + (unless (string-empty-p icon) + (concat + (if doom-modeline-major-mode-color-icon + (doom-modeline-display-icon icon) + (doom-modeline-propertize-icon + icon + (doom-modeline-face))) + (doom-modeline-vspc)))))) + +(defsubst doom-modeline--buffer-state-icon () + "The icon of the current buffer state." + (when doom-modeline-buffer-state-icon + (when-let* ((icon (doom-modeline-update-buffer-file-state-icon))) + (unless (string-empty-p icon) + (concat + (doom-modeline-display-icon icon) + (doom-modeline-vspc)))))) + +(defsubst doom-modeline--buffer-simple-name () + "The buffer simple name." + (propertize "%b" + 'face (doom-modeline-face + (if (and doom-modeline-highlight-modified-buffer-name + (buffer-modified-p)) + 'doom-modeline-buffer-modified + 'doom-modeline-buffer-file)) + 'mouse-face 'doom-modeline-highlight + 'help-echo "Buffer name +mouse-1: Previous buffer\nmouse-3: Next buffer" + 'local-map mode-line-buffer-identification-keymap)) + +(defsubst doom-modeline--buffer-name () + "The current buffer name." + (when doom-modeline-buffer-name + (if (and (not (eq doom-modeline-buffer-file-name-style 'file-name)) + doom-modeline--limited-width-p) + ;; Only display the buffer name if the window is small, and doesn't + ;; need to respect file-name style. + (doom-modeline--buffer-simple-name) + (when-let* ((name (or doom-modeline--buffer-file-name + (doom-modeline-update-buffer-file-name)))) + ;; Check if the buffer is modified + (if (and doom-modeline-highlight-modified-buffer-name + (buffer-modified-p)) + (propertize name 'face (doom-modeline-face 'doom-modeline-buffer-modified)) + (doom-modeline-display-text name)))))) + +(doom-modeline-def-segment buffer-info + "Combined information about the current buffer. + +Including the current working directory, the file name, and its state (modified, +read-only or non-existent)." + (concat + (doom-modeline-spc) + (doom-modeline--buffer-mode-icon) + (doom-modeline--buffer-state-icon) + (doom-modeline--buffer-name))) + +(doom-modeline-def-segment buffer-info-simple + "Display only the current buffer's name, but with fontification." + (concat + (doom-modeline-spc) + (doom-modeline--buffer-mode-icon) + (doom-modeline--buffer-state-icon) + (doom-modeline--buffer-simple-name))) + +(doom-modeline-def-segment calc + "Display calculator icons and info." + (concat + (doom-modeline-spc) + (when-let* ((icon (doom-modeline-icon 'faicon "nf-fa-calculator" "🖩" ""))) + (concat + (doom-modeline-display-icon icon) + (doom-modeline-vspc))) + (doom-modeline--buffer-simple-name))) + +(doom-modeline-def-segment buffer-default-directory + "Displays `default-directory' with the icon and state. + +This is for special buffers like the scratch buffer where knowing the current +project directory is important." + (let ((face (doom-modeline-face + (if (and buffer-file-name (buffer-modified-p)) + 'doom-modeline-buffer-modified + 'doom-modeline-buffer-path)))) + (concat + (doom-modeline-spc) + (and doom-modeline-major-mode-icon + (concat + (doom-modeline-icon + 'octicon "nf-oct-file_directory_fill" "🖿" "" :face face) + (doom-modeline-vspc))) + (doom-modeline--buffer-state-icon) + (propertize (abbreviate-file-name default-directory) 'face face)))) + +(doom-modeline-def-segment buffer-default-directory-simple + "Displays `default-directory'. + +This is for special buffers like the scratch buffer where knowing the current +project directory is important." + (let ((face (doom-modeline-face 'doom-modeline-buffer-path))) + (concat + (doom-modeline-spc) + (and doom-modeline-major-mode-icon + (concat + (doom-modeline-icon + 'octicon "nf-oct-file_directory_fill" "🖿" "" :face face) + (doom-modeline-vspc))) + (propertize (abbreviate-file-name default-directory) 'face face)))) + + +;; +;; Encoding +;; + +(doom-modeline-def-segment buffer-encoding + "Displays the eol and the encoding style of the buffer." + (when doom-modeline-buffer-encoding + (let ((sep (doom-modeline-spc)) + (face (doom-modeline-face)) + (mouse-face 'doom-modeline-highlight)) + (concat + sep + + ;; eol type + (let ((eol (coding-system-eol-type buffer-file-coding-system))) + (when (or (eq doom-modeline-buffer-encoding t) + (and (eq doom-modeline-buffer-encoding 'nondefault) + (not (equal eol doom-modeline-default-eol-type)))) + (propertize + (pcase eol + (0 "LF ") + (1 "CRLF ") + (2 "CR ") + (_ "")) + 'face face + 'mouse-face mouse-face + 'help-echo (format "End-of-line style: %s\nmouse-1: Cycle" + (pcase eol + (0 "Unix-style LF") + (1 "DOS-style CRLF") + (2 "Mac-style CR") + (_ "Undecided"))) + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'mode-line-change-eol) + map)))) + + ;; coding system + (let* ((sys (coding-system-plist buffer-file-coding-system)) + (cat (plist-get sys :category)) + (sym (if (memq cat + '(coding-category-undecided coding-category-utf-8)) + 'utf-8 + (plist-get sys :name)))) + (when (or (eq doom-modeline-buffer-encoding t) + (and (eq doom-modeline-buffer-encoding 'nondefault) + (not (eq cat 'coding-category-undecided)) + (not (eq sym doom-modeline-default-coding-system)))) + (propertize + (upcase (symbol-name sym)) + 'face face + 'mouse-face mouse-face + 'help-echo 'mode-line-mule-info-help-echo + 'local-map mode-line-coding-system-map))) + + sep)))) + + +;; +;; Indentation +;; + +(doom-modeline-def-segment indent-info + "Displays the indentation information." + (when doom-modeline-indent-info + (let ((do-propertize + (lambda (mode size) + (propertize + (format " %s %d " mode size) + 'face (doom-modeline-face))))) + (if indent-tabs-mode + (funcall do-propertize "TAB" tab-width) + (let ((lookup-var + (seq-find (lambda (var) + (and var (boundp var) (symbol-value var))) + (cdr (assoc major-mode doom-modeline-indent-alist)) nil))) + (funcall do-propertize "SPC" + (if lookup-var + (symbol-value lookup-var) + tab-width))))))) + +;; +;; Remote host +;; + +(doom-modeline-def-segment remote-host + "Hostname for remote buffers." + (when default-directory + (when-let* ((host (file-remote-p default-directory 'host))) + (propertize + (concat "@" host) + 'face (doom-modeline-face 'doom-modeline-host))))) + + +;; +;; Major mode +;; + +(doom-modeline-def-segment major-mode + "The major mode, including environment and text-scale info." + (let ((sep (doom-modeline-spc)) + (face (doom-modeline-face 'doom-modeline-buffer-major-mode))) + (concat + sep + (propertize (concat + (format-mode-line + (or (and (boundp 'delighted-modes) + (cadr (assq major-mode delighted-modes))) + mode-name)) + (when (and doom-modeline-env-version doom-modeline-env--version) + (format " %s" doom-modeline-env--version))) + 'help-echo "Major mode\n\ +mouse-1: Display major mode menu\n\ +mouse-2: Show help for major mode\n\ +mouse-3: Toggle minor modes" + 'face face + 'mouse-face 'doom-modeline-highlight + 'local-map mode-line-major-mode-keymap) + (and (boundp 'text-scale-mode-amount) + (/= text-scale-mode-amount 0) + (propertize + (format + (if (> text-scale-mode-amount 0) " (%+d)" " (%-d)") + text-scale-mode-amount) + 'face face)) + sep))) + + +;; +;; Process +;; + +(doom-modeline-def-segment process + "The process info." + (doom-modeline-display-text + (format-mode-line mode-line-process))) + + +;; +;; Minor modes +;; + +(doom-modeline-def-segment minor-modes + (when doom-modeline-minor-modes + (let ((sep (doom-modeline-spc)) + (face (doom-modeline-face 'doom-modeline-buffer-minor-mode)) + (mouse-face 'doom-modeline-highlight) + (help-echo "Minor mode + mouse-1: Display minor mode menu + mouse-2: Show help for minor mode + mouse-3: Toggle minor modes")) + (if (bound-and-true-p minions-mode) + `((:propertize ("" ,(minions--prominent-modes)) + face ,face + mouse-face ,mouse-face + help-echo ,help-echo + local-map ,mode-line-minor-mode-keymap) + ,sep + (:propertize ("" ,(doom-modeline-icon 'octicon "nf-oct-gear" "⚙" + minions-mode-line-lighter + :face face)) + mouse-face ,mouse-face + help-echo "Minions +mouse-1: Display minor modes menu" + local-map ,minions-mode-line-minor-modes-map) + ,sep) + `((:propertize ("" minor-mode-alist) + face ,face + mouse-face ,mouse-face + help-echo ,help-echo + local-map ,mode-line-minor-mode-keymap) + ,sep))))) + + +;; +;; VCS +;; + +(defun doom-modeline-vcs-icon (icon &optional unicode text face) + "Displays the vcs ICON with FACE and VOFFSET. + +UNICODE and TEXT are fallbacks. +Uses `nerd-icons-octicon' to fetch the icon." + (doom-modeline-icon 'devicon (and doom-modeline-vcs-icon icon) + unicode text :face face)) + +(defvar-local doom-modeline--vcs nil) +(defun doom-modeline-update-vcs (&rest _) + "Update vcs state in mode-line." + (setq doom-modeline--vcs + (when (and vc-mode buffer-file-name) + (let* ((backend (vc-backend buffer-file-name)) + (state (vc-state buffer-file-name backend)) + (icon (cond ((memq state '(edited added)) + (doom-modeline-vcs-icon "nf-dev-git_compare" "🔃" "*" 'doom-modeline-info)) + ((eq state 'needs-merge) + (doom-modeline-vcs-icon "nf-dev-git_merge" "🔀" "?" 'doom-modeline-info)) + ((eq state 'needs-update) + (doom-modeline-vcs-icon "nf-dev-git_pull_request" "⬇" "!" 'doom-modeline-warning)) + ((memq state '(removed conflict unregistered)) + (doom-modeline-icon 'octicon "nf-oct-alert" "⚠" "!" :face 'doom-modeline-urgent)) + (t (doom-modeline-vcs-icon "nf-dev-git_branch" "" "@" 'doom-modeline-info)))) + (str (or (and vc-display-status + (functionp doom-modeline-vcs-display-function) + (funcall doom-modeline-vcs-display-function)) + "")) + (face (cond ((eq state 'needs-update) + '(doom-modeline-warning bold)) + ((memq state '(removed conflict unregistered)) + '(doom-modeline-urgent bold)) + (t '(doom-modeline-info bold)))) + (text (propertize (if (length> str doom-modeline-vcs-max-length) + (concat + (substring str 0 (- doom-modeline-vcs-max-length 3)) + doom-modeline-ellipsis) + str) + 'face face))) + `((icon . ,icon) (text . ,text)))))) +(add-hook 'find-file-hook #'doom-modeline-update-vcs) +(add-hook 'after-save-hook #'doom-modeline-update-vcs) +(advice-add #'vc-refresh-state :after #'doom-modeline-update-vcs) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-vcs)))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-unicode-fallback val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-vcs)))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-vcs-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-vcs-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-vcs)))))) + +(doom-modeline-add-variable-watcher + 'vc-display-status + (lambda (_sym val op _where) + (when (eq op 'set) + (setq vc-display-status val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-vcs)))))) + +(doom-modeline-def-segment vcs + "Displays the current branch, colored based on its state." + (when doom-modeline--vcs + (let-alist doom-modeline--vcs + (let ((sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc))) + (concat sep + (propertize (concat + (doom-modeline-display-icon .icon) + vsep + (doom-modeline-display-text .text)) + 'help-echo (get-text-property 1 'help-echo vc-mode) + 'mouse-face 'doom-modeline-highlight + 'local-map (get-text-property 1 'local-map vc-mode)) + sep))))) + + +;; +;; Check +;; + +(defun doom-modeline-check-icon (icon unicode text face) + "Displays the check ICON with FACE. + +UNICODE and TEXT are fallbacks. +Uses `nerd-icons-mdicon' to fetch the icon." + (doom-modeline-icon 'mdicon (and doom-modeline-check-icon icon) + unicode text :face face)) + +(defun doom-modeline-check-text (text &optional face) + "Displays the check TEXT with FACE." + (propertize text 'face (or face 'mode-line))) + +;; Flycheck + +(defun doom-modeline--flycheck-count-errors () + "Count the number of ERRORS, grouped by level. + +Return an alist, where each ITEM is a cons cell whose `car' is an +error level, and whose `cdr' is the number of errors of that +level." + (let ((info 0) (warning 0) (error 0)) + (mapc + (lambda (item) + (let ((count (cdr item))) + (pcase (flycheck-error-level-compilation-level (car item)) + (0 (cl-incf info count)) + (1 (cl-incf warning count)) + (2 (cl-incf error count))))) + (flycheck-count-errors flycheck-current-errors)) + `((info . ,info) (warning . ,warning) (error . ,error)))) + +(defvar-local doom-modeline--flycheck nil) +(defun doom-modeline-update-flycheck (&optional status) + "Update flycheck via STATUS." + (setq doom-modeline--flycheck + (let-alist (doom-modeline--flycheck-count-errors) + (let* ((vsep (doom-modeline-vspc)) + (seg (if doom-modeline-check-simple-format + (let ((count (+ .error .warning .info))) + (pcase status + ('finished (if (> count 0) + (let ((face (if (> .error 0) 'doom-modeline-urgent 'doom-modeline-warning))) + (concat + (doom-modeline-check-icon "nf-md-alert_circle_outline" "⚠" "!" face) + vsep + (doom-modeline-check-text (number-to-string count) face))) + (doom-modeline-check-icon "nf-md-check_circle_outline" "✔" "*" 'doom-modeline-info))) + ('running (concat + (doom-modeline-check-icon "nf-md-timer_sand" "⏳" "*" 'doom-modeline-debug) + (when (> count 0) + (concat + vsep + (doom-modeline-check-text (number-to-string count) 'doom-modeline-debug))))) + ('no-checker (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "-" 'doom-modeline-debug)) + ('errored (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-urgent)) + ('interrupted (doom-modeline-check-icon "nf-md-pause_circle_outline" "⦷" "." 'doom-modeline-debug)) + ('suspicious (doom-modeline-check-icon "nf-md-file_question_outline" "❓" "?" 'doom-modeline-debug)) + (_ ""))) + (concat (doom-modeline-check-icon "nf-md-close_circle_outline" "⮾" "!" 'doom-modeline-urgent) + vsep + (doom-modeline-check-text (number-to-string .error) 'doom-modeline-urgent) + vsep + (doom-modeline-check-icon "nf-md-alert_outline" "⚠" "!" 'doom-modeline-warning) + vsep + (doom-modeline-check-text (number-to-string .warning) 'doom-modeline-warning) + vsep + (doom-modeline-check-icon "nf-md-information_outline" "🛈" "!" 'doom-modeline-info) + vsep + (doom-modeline-check-text (number-to-string .info) 'doom-modeline-info))))) + (propertize seg + 'help-echo (concat "Flycheck\n" + (pcase status + ('finished (format "error: %d, warning: %d, info: %d" .error .warning .info)) + ('running "Checking...") + ('no-checker "No Checker") + ('errored "Error") + ('interrupted "Interrupted") + ('suspicious "Suspicious")) + "\nmouse-1: Display minor mode menu\nmouse-2: Show help for minor mode") + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] + flycheck-mode-menu-map) + (define-key map [mode-line mouse-2] + (lambda () + (interactive) + (describe-function 'flycheck-mode))) + map)))))) +(add-hook 'flycheck-status-changed-functions #'doom-modeline-update-flycheck) +(add-hook 'flycheck-mode-hook #'doom-modeline-update-flycheck) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flycheck-mode) + (doom-modeline-update-flycheck))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-check-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-check-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flycheck-mode) + (doom-modeline-update-flycheck))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-unicode-fallback val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flycheck-mode) + (doom-modeline-update-flycheck))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-check-simple-format + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-check-simple-format val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flycheck-mode) + (doom-modeline-update-flycheck))))))) + +;; Flymake + +;; Compatibility +;; @see https://github.com/emacs-mirror/emacs/commit/6e100869012da9244679696634cab6b9cac96303. +(with-eval-after-load 'flymake + (unless (boundp 'flymake--state) + (defvaralias 'flymake--state 'flymake--backend-state)) + (unless (fboundp 'flymake--state-diags) + (defalias 'flymake--state-diags 'flymake--backend-state-diags))) + +(defun doom-modeline--flymake-count-errors () + "Count the number of ERRORS, grouped by level." + (let ((warning-level (warning-numeric-level :warning)) + (note-level (warning-numeric-level :debug)) + (note 0) (warning 0) (error 0)) + (maphash (lambda (_b state) + (cl-loop + with diags = (flymake--state-diags state) + for diag in diags do + (let ((severity (flymake--lookup-type-property (flymake--diag-type diag) 'severity + (warning-numeric-level :error)))) + (cond ((> severity warning-level) (cl-incf error)) + ((> severity note-level) (cl-incf warning)) + (t (cl-incf note)))))) + flymake--state) + `((note . ,note) (warning . ,warning) (error . ,error)))) + +(defvar-local doom-modeline--flymake nil) +(defun doom-modeline-update-flymake (&rest _) + "Update flymake." + (setq doom-modeline--flymake + (let* ((known (hash-table-keys flymake--state)) + (running (flymake-running-backends)) + (disabled (flymake-disabled-backends)) + (reported (flymake-reporting-backends)) + (all-disabled (and disabled (null running))) + (some-waiting (cl-set-difference running reported))) + (let-alist (doom-modeline--flymake-count-errors) + (let* ((vsep (doom-modeline-vspc)) + (seg (if doom-modeline-check-simple-format + (let ((count (+ .error .warning .note))) + (cond + (some-waiting (concat + (doom-modeline-check-icon "nf-md-timer_sand" "⏳" "*" 'doom-modeline-debug) + (when (> count 0) + (concat + vsep + (doom-modeline-check-text (number-to-string count) 'doom-modeline-debug))))) + ((null known) (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-urgent)) + (all-disabled (doom-modeline-check-icon "nf-md-alert_box_outline" "⚠" "!" 'doom-modeline-warning)) + (t (if (> count 0) + (let ((face (cond ((> .error 0) 'doom-modeline-urgent) + ((> .warning 0) 'doom-modeline-warning) + (t 'doom-modeline-info)))) + (concat + (doom-modeline-check-icon "nf-md-alert_circle_outline" "⚠" "!" face) + vsep + (doom-modeline-check-text (number-to-string count) face))) + (doom-modeline-check-icon "nf-md-check_circle_outline" "✔" "*" 'doom-modeline-info))))) + (concat + (doom-modeline-check-icon "nf-md-close_circle_outline" "⮾" "!" 'doom-modeline-urgent) + vsep + (doom-modeline-check-text (number-to-string .error) 'doom-modeline-urgent) + vsep + (doom-modeline-check-icon "nf-md-alert_outline" "⚠" "!" 'doom-modeline-warning) + vsep + (doom-modeline-check-text (number-to-string .warning) 'doom-modeline-warning) + vsep + (doom-modeline-check-icon "nf-md-information_outline" "🛈" "!" 'doom-modeline-info) + vsep + (doom-modeline-check-text (number-to-string .note) 'doom-modeline-info))))) + (propertize + seg + 'help-echo (concat + "Flymake\n" + (cond (some-waiting "Checking...") + ((null known) "No Checker") + (all-disabled "All Checkers Disabled") + (t (format "%d/%d backends running\nerror: %d, warning: %d, note: %d" + (length running) (length known) .error .warning .note))) + "\nmouse-1: Display minor mode menu\nmouse-2: Show help for minor mode") + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] + flymake-menu) + (define-key map [mode-line mouse-2] + (lambda () + (interactive) + (describe-function 'flymake-mode))) + map))))))) +(advice-add #'flymake--handle-report :after #'doom-modeline-update-flymake) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flymake-mode) + (doom-modeline-update-flymake))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-check-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-check-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flymake-mode) + (doom-modeline-update-flymake))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-unicode-fallback val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flymake-mode) + (doom-modeline-update-flymake))))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-check-simple-format + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-check-simple-format val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (bound-and-true-p flymake-mode) + (doom-modeline-update-flymake))))))) + +(doom-modeline-def-segment check + "Displays color-coded error status in the current buffer with pretty icons." + (when-let* ((sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc)) + (seg (cond + ((and (bound-and-true-p flymake-mode) + (bound-and-true-p flymake--state)) ; only support 26+ + doom-modeline--flymake) + ((and (bound-and-true-p flycheck-mode) + (bound-and-true-p flycheck--automatically-enabled-checkers)) + doom-modeline--flycheck)))) + (concat + sep + (let ((str)) + (dolist (s (split-string seg " ")) + (setq str + (concat str + (if (string-match-p "^[0-9]+$" s) + (concat vsep + (doom-modeline-display-text s) + vsep) + (doom-modeline-display-icon s))))) + (propertize str + 'help-echo (get-text-property 0 'help-echo seg) + 'mouse-face 'doom-modeline-highlight + 'local-map (get-text-property 0 'local-map seg))) + sep))) + + +;; +;; Word Count +;; + +(doom-modeline-def-segment word-count + "The buffer word count. +Displayed when in a major mode in `doom-modeline-continuous-word-count-modes'. +Respects `doom-modeline-enable-word-count'." + (when (and doom-modeline-enable-word-count + (member major-mode doom-modeline-continuous-word-count-modes)) + (propertize (format " %dW" (count-words (point-min) (point-max))) + 'face (doom-modeline-face)))) + + +;; +;; Selection +;; + +(defsubst doom-modeline-column (pos) + "Get the column of the position `POS'." + (save-excursion (goto-char pos) + (current-column))) + +(doom-modeline-def-segment selection-info + "Information about the current selection. + +Such as how many characters and lines are selected, or the NxM dimensions of a +block selection." + (when (and (or mark-active (and (bound-and-true-p evil-local-mode) + (eq evil-state 'visual))) + (doom-modeline--active)) + (cl-destructuring-bind (beg . end) + (if (and (bound-and-true-p evil-local-mode) (eq evil-state 'visual)) + (cons evil-visual-beginning evil-visual-end) + (cons (region-beginning) (region-end))) + (propertize + (let ((lines (count-lines beg (min end (point-max))))) + (concat + " " + (cond ((or (bound-and-true-p rectangle-mark-mode) + (and (bound-and-true-p evil-visual-selection) + (eq 'block evil-visual-selection))) + (let ((cols (abs (- (doom-modeline-column end) + (doom-modeline-column beg))))) + (format "%dx%dB" lines cols))) + ((and (bound-and-true-p evil-visual-selection) + (eq evil-visual-selection 'line)) + (format "%dL" lines)) + ((> lines 1) + (format "%dC %dL" (- end beg) lines)) + (t + (format "%dC" (- end beg)))) + (when doom-modeline-enable-word-count + (format " %dW" (count-words beg end))) + " ")) + 'face 'doom-modeline-emphasis)))) + + +;; +;; Matches (macro, anzu, evil-substitute, iedit, symbol-overlay and multi-cursors) +;; + +(defsubst doom-modeline--macro-recording () + "Display current Emacs or evil macro being recorded." + (when (and (doom-modeline--active) + (or defining-kbd-macro executing-kbd-macro)) + (let ((sep (propertize " " 'face 'doom-modeline-panel)) + (vsep (propertize " " 'face + '(:inherit (doom-modeline-panel variable-pitch)))) + (macro-name (if (bound-and-true-p evil-this-macro) + (format " @%s " + (char-to-string evil-this-macro)) + "Macro"))) + (concat + sep + (if doom-modeline-always-show-macro-register + (propertize macro-name 'face 'doom-modeline-panel) + (concat + (doom-modeline-icon 'mdicon "nf-md-record" "●" + macro-name + :face '(:inherit (doom-modeline-urgent doom-modeline-panel)) + :v-adjust 0.15) + vsep + (doom-modeline-icon 'mdicon "nf-md-menu_right" "▶" ">" + :face 'doom-modeline-panel + :v-adjust 0.15))) + sep)))) + +;; `anzu' and `evil-anzu' expose current/total state that can be displayed in the +;; mode-line. +(defun doom-modeline-fix-anzu-count (positions here) + "Calulate anzu count via POSITIONS and HERE." + (cl-loop with i = 0 + for (start . end) in positions + do (cl-incf i) + when (and (>= here start) (<= here end)) + return i + finally return 0)) + +(advice-add #'anzu--where-is-here :override #'doom-modeline-fix-anzu-count) + +(setq anzu-cons-mode-line-p nil) ; manage modeline segment ourselves +;; Ensure anzu state is cleared when searches & iedit are done +(with-eval-after-load 'anzu + (add-hook 'isearch-mode-end-hook #'anzu--reset-status t) + (add-hook 'iedit-mode-end-hook #'anzu--reset-status) + (advice-add #'evil-force-normal-state :after #'anzu--reset-status) + ;; Fix matches segment mirroring across all buffers + (mapc #'make-variable-buffer-local + '(anzu--total-matched + anzu--current-position anzu--state anzu--cached-count + anzu--cached-positions anzu--last-command + anzu--last-isearch-string anzu--overflow-p))) + +(defsubst doom-modeline--anzu () + "Show the match index and total number thereof. +Requires `anzu', also `evil-anzu' if using `evil-mode' for compatibility with +`evil-search'." + (when (and (bound-and-true-p anzu--state) + (not (bound-and-true-p iedit-mode))) + (propertize + (let ((here anzu--current-position) + (total anzu--total-matched)) + (cond ((eq anzu--state 'replace-query) + (format " %d replace " anzu--cached-count)) + ((eq anzu--state 'replace) + (format " %d/%d " here total)) + (anzu--overflow-p + (format " %s+ " total)) + (t + (format " %s/%d " here total)))) + 'face (doom-modeline-face 'doom-modeline-panel)))) + +(defsubst doom-modeline--evil-substitute () + "Show number of matches for `evil-ex' in real time. +The number of matches contains substitutions and highlightings." + (when (and (bound-and-true-p evil-local-mode) + (or (assq 'evil-ex-substitute evil-ex-active-highlights-alist) + (assq 'evil-ex-global-match evil-ex-active-highlights-alist) + (assq 'evil-ex-buffer-match evil-ex-active-highlights-alist))) + (propertize + (let ((range (if evil-ex-range + (cons (car evil-ex-range) (cadr evil-ex-range)) + (cons (line-beginning-position) (line-end-position)))) + (pattern (car-safe (evil-delimited-arguments evil-ex-argument 2)))) + (if pattern + (format " %s matches " (how-many pattern (car range) (cdr range))) + " - ")) + 'face (doom-modeline-face 'doom-modeline-panel)))) + +(defun doom-modeline-themes--overlay-sort (a b) + "Sort overlay A and B." + (< (overlay-start a) (overlay-start b))) + +(defsubst doom-modeline--iedit () + "Show the number of iedit regions matches + what match you're on." + (when (and (bound-and-true-p iedit-mode) + (bound-and-true-p iedit-occurrences-overlays)) + (propertize + (let ((this-oc (or (let ((inhibit-message t)) + (iedit-find-current-occurrence-overlay)) + (save-excursion (iedit-prev-occurrence) + (iedit-find-current-occurrence-overlay)))) + (length (length iedit-occurrences-overlays))) + (format " %s/%d " + (if this-oc + (- length + (length (memq this-oc (sort (append iedit-occurrences-overlays nil) + #'doom-modeline-themes--overlay-sort))) + -1) + "-") + length)) + 'face (doom-modeline-face 'doom-modeline-panel)))) + +(defsubst doom-modeline--symbol-overlay () + "Show the number of matches for symbol overlay." + (when (and (doom-modeline--active) + (bound-and-true-p symbol-overlay-keywords-alist) + (not (bound-and-true-p symbol-overlay-temp-symbol)) + (not (bound-and-true-p iedit-mode))) + (let* ((keyword (symbol-overlay-assoc (symbol-overlay-get-symbol t))) + (symbol (car keyword)) + (before (symbol-overlay-get-list -1 symbol)) + (after (symbol-overlay-get-list 1 symbol)) + (count (length before))) + (if (symbol-overlay-assoc symbol) + (propertize + (format (concat " %d/%d " (and (cadr keyword) "in scope ")) + (+ count 1) + (+ count (length after))) + 'face (doom-modeline-face 'doom-modeline-panel)))))) + +(defsubst doom-modeline--multiple-cursors () + "Show the number of multiple cursors." + (cl-destructuring-bind (count . face) + (cond ((bound-and-true-p multiple-cursors-mode) + (cons (mc/num-cursors) + (doom-modeline-face 'doom-modeline-panel))) + ((bound-and-true-p evil-mc-cursor-list) + (cons (length evil-mc-cursor-list) + (doom-modeline-face (if evil-mc-frozen + 'doom-modeline-bar + 'doom-modeline-panel)))) + ((cons nil nil))) + (when count + (concat (propertize " " 'face face) + (if (doom-modeline-icon-displayable-p) + (doom-modeline-icon 'faicon "nf-fa-i_cursor" "" "" :face face) + (propertize "I" + 'face `(:inherit ,face :height 1.4 :weight normal) + 'display '(raise -0.1))) + (propertize " " + 'face `(:inherit (variable-pitch ,face))) + (propertize (format "%d " count) + 'face face))))) + +(defsubst doom-modeline--phi-search () + "Show the number of matches for `phi-search' and `phi-replace'." + (when (and (doom-modeline--active) + (bound-and-true-p phi-search--overlays)) + (let ((total (length phi-search--overlays)) + (selection phi-search--selection)) + (when selection + (propertize + (format " %d/%d " (1+ selection) total) + 'face (doom-modeline-face 'doom-modeline-panel)))))) + +(defun doom-modeline--override-phi-search (orig-fun &rest args) + "Override the mode-line of `phi-search' and `phi-replace'. +Apply ORIG-FUN with ARGS." + (if (bound-and-true-p doom-modeline-mode) + (apply orig-fun mode-line-format (cdr args)) + (apply orig-fun args))) +(advice-add #'phi-search--initialize :around #'doom-modeline--override-phi-search) + +(defsubst doom-modeline--buffer-size () + "Show buffer size." + (when size-indication-mode + (let ((sep (doom-modeline-spc))) + (concat sep + (propertize "%I" + 'face (doom-modeline-face) + 'help-echo "Buffer size +mouse-1: Display Line and Column Mode Menu" + 'mouse-face 'doom-modeline-highlight + 'local-map mode-line-column-line-number-mode-map) + sep)))) + +(doom-modeline-def-segment matches + "Displays matches. + +Including: +1. the currently recording macro, 2. A current/total for the +current search term (with `anzu'), 3. The number of substitutions being +conducted with `evil-ex-substitute', and/or 4. The number of active `iedit' +regions, 5. The current/total for the highlight term (with `symbol-overlay'), +6. The number of active `multiple-cursors'." + (let ((meta (concat (doom-modeline--macro-recording) + (doom-modeline--anzu) + (doom-modeline--phi-search) + (doom-modeline--evil-substitute) + (doom-modeline--iedit) + (doom-modeline--symbol-overlay) + (doom-modeline--multiple-cursors)))) + (or (and (not (string-empty-p meta)) meta) + (doom-modeline--buffer-size)))) + +(doom-modeline-def-segment buffer-size + "Display buffer size." + (doom-modeline--buffer-size)) + +;; +;; Media +;; + +(doom-modeline-def-segment media-info + "Metadata regarding the current file, such as dimensions for images." + ;; TODO: Include other information + (cond ((eq major-mode 'image-mode) + (cl-destructuring-bind (width . height) + (when (fboundp 'image-size) + (image-size (image-get-display-property) :pixels)) + (format " %dx%d " width height))))) + + +;; +;; Bars +;; + +(defvar doom-modeline--bar-active nil) +(defvar doom-modeline--bar-inactive nil) + +(defsubst doom-modeline--bar () + "The default bar regulates the height of the mode-line in GUI." + (unless (and doom-modeline--bar-active doom-modeline--bar-inactive) + (let ((width doom-modeline-bar-width) + (height (max doom-modeline-height (doom-modeline--font-height)))) + (setq doom-modeline--bar-active + (doom-modeline--create-bar-image 'doom-modeline-bar width height) + doom-modeline--bar-inactive + (doom-modeline--create-bar-image + 'doom-modeline-bar-inactive width height)))) + (if (doom-modeline--active) + doom-modeline--bar-active + doom-modeline--bar-inactive)) + +(defun doom-modeline-refresh-bars () + "Refresh mode-line bars on next redraw." + (setq doom-modeline--bar-active nil + doom-modeline--bar-inactive nil)) + +(cl-defstruct doom-modeline--hud-cache active inactive top-margin bottom-margin) + +(defsubst doom-modeline--hud () + "Powerline's hud segment reimplemented in the style of Doom's bar segment." + (let* ((ws (window-start)) + (we (window-end)) + (bs (buffer-size)) + (height (max doom-modeline-height (doom-modeline--font-height))) + (top-margin (if (zerop bs) + 0 + (/ (* height (1- ws)) bs))) + (bottom-margin (if (zerop bs) + 0 + (max 0 (/ (* height (- bs we 1)) bs)))) + (cache (or (window-parameter nil 'doom-modeline--hud-cache) + (set-window-parameter + nil + 'doom-modeline--hud-cache + (make-doom-modeline--hud-cache))))) + (unless (and (doom-modeline--hud-cache-active cache) + (doom-modeline--hud-cache-inactive cache) + (= top-margin (doom-modeline--hud-cache-top-margin cache)) + (= bottom-margin + (doom-modeline--hud-cache-bottom-margin cache))) + (setf (doom-modeline--hud-cache-active cache) + (doom-modeline--create-hud-image + 'doom-modeline-bar 'default doom-modeline-bar-width + height top-margin bottom-margin) + (doom-modeline--hud-cache-inactive cache) + (doom-modeline--create-hud-image + 'doom-modeline-bar-inactive 'default doom-modeline-bar-width + height top-margin bottom-margin) + (doom-modeline--hud-cache-top-margin cache) top-margin + (doom-modeline--hud-cache-bottom-margin cache) bottom-margin)) + (if (doom-modeline--active) + (doom-modeline--hud-cache-active cache) + (doom-modeline--hud-cache-inactive cache)))) + +(defun doom-modeline-invalidate-huds () + "Invalidate all cached hud images." + (dolist (frame (frame-list)) + (dolist (window (window-list frame)) + (set-window-parameter window 'doom-modeline--hud-cache nil)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-height + (lambda (_sym val op _where) + (when (and (eq op 'set) (integerp val)) + (doom-modeline-refresh-bars) + (doom-modeline-invalidate-huds)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-bar-width + (lambda (_sym val op _where) + (when (and (eq op 'set) (integerp val)) + (doom-modeline-refresh-bars) + (doom-modeline-invalidate-huds)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym _val op _where) + (when (eq op 'set) + (doom-modeline-refresh-bars) + (doom-modeline-invalidate-huds)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym _val op _where) + (when (eq op 'set) + (doom-modeline-refresh-bars) + (doom-modeline-invalidate-huds)))) + +(add-hook 'window-configuration-change-hook #'doom-modeline-refresh-bars) +(add-hook 'window-configuration-change-hook #'doom-modeline-invalidate-huds) + +(doom-modeline-def-segment bar + "The bar regulates the height of the `doom-modeline' in GUI." + (when (display-graphic-p) + (concat + (if doom-modeline-hud + (doom-modeline--hud) + (doom-modeline--bar)) + (doom-modeline-spc)))) + +(doom-modeline-def-segment hud + "Powerline's hud segment reimplemented in the style of bar segment." + (when (display-graphic-p) + (concat + (doom-modeline--hud) + (doom-modeline-spc)))) + + +;; +;; Window number +;; + +;; HACK: `ace-window-display-mode' should respect the ignore buffers. +(defun doom-modeline-aw-update () + "Update ace-window-path window parameter for all windows. +Ensure all windows are labeled so the user can select a specific +one. The ignored buffers are excluded unless `aw-ignore-on' is nil." + (let ((ignore-window-parameters t)) + (avy-traverse + (avy-tree (aw-window-list) aw-keys) + (lambda (path leaf) + (set-window-parameter + leaf 'ace-window-path + (propertize + (apply #'string (reverse path)) + 'face 'aw-mode-line-face)))))) +(advice-add #'aw-update :override #'doom-modeline-aw-update) + +;; Remove original window number of `ace-window-display-mode'. +(add-hook 'ace-window-display-mode-hook + (lambda () + (setq-default mode-line-format + (assq-delete-all 'ace-window-display-mode + (default-value 'mode-line-format))))) + +(advice-add #'window-numbering-install-mode-line :override #'ignore) +(advice-add #'window-numbering-clear-mode-line :override #'ignore) +(advice-add #'winum--install-mode-line :override #'ignore) +(advice-add #'winum--clear-mode-line :override #'ignore) + +(doom-modeline-def-segment window-number + "The current window number." + (let ((num (cond + ((bound-and-true-p ace-window-display-mode) + (aw-update) + (window-parameter (selected-window) 'ace-window-path)) + ((bound-and-true-p winum-mode) + (setq winum-auto-setup-mode-line nil) + (winum-get-number-string)) + ((bound-and-true-p window-numbering-mode) + (window-numbering-get-number-string)) + (t "")))) + (when (and (length> num 0) + (length> (cl-mapcan + (lambda (frame) + ;; Exclude minibuffer, tooltip and child frames + (unless (or (and (fboundp 'frame-parent) (frame-parent frame)) + (string= (frame-parameter frame 'name) + (alist-get 'name (bound-and-true-p tooltip-frame-parameters)))) + (window-list frame 'never))) + (visible-frame-list)) + 1)) + (propertize (format " %s " num) + 'face (doom-modeline-face 'doom-modeline-buffer-major-mode))))) + + +;; +;; Workspace +;; + +(doom-modeline-def-segment workspace-name + "The current workspace name or number. +Requires `eyebrowse-mode' to be enabled or `tab-bar-mode' tabs to be created." + (when doom-modeline-workspace-name + (when-let* + ((name (cond + ((and (bound-and-true-p eyebrowse-mode) + (length> (eyebrowse--get 'window-configs) 1)) + (setq mode-line-misc-info + (assq-delete-all 'eyebrowse-mode mode-line-misc-info)) + (when-let* + ((num (eyebrowse--get 'current-slot)) + (tag (nth 2 (assoc num (eyebrowse--get 'window-configs))))) + (if (length> tag 0) tag (int-to-string num)))) + ((and (fboundp 'tab-bar-mode) + (length> (frame-parameter nil 'tabs) 1)) + (let* ((current-tab (tab-bar--current-tab)) + (tab-index (tab-bar--current-tab-index)) + (explicit-name (alist-get 'explicit-name current-tab)) + (tab-name (alist-get 'name current-tab))) + (if explicit-name tab-name (+ 1 tab-index))))))) + (propertize (format " %s " name) + 'face (doom-modeline-face 'doom-modeline-buffer-major-mode))))) + + +;; +;; Perspective +;; + +(defvar-local doom-modeline--persp-name nil) +(defun doom-modeline-update-persp-name (&rest _) + "Update perspective name in mode-line." + (setq doom-modeline--persp-name + ;; Support `persp-mode', while not support `perspective' + (when (and doom-modeline-persp-name + (bound-and-true-p persp-mode) + (fboundp 'safe-persp-name) + (fboundp 'get-current-persp)) + (let* ((persp (get-current-persp)) + (name (safe-persp-name persp)) + (face (if (and persp + (not (persp-contain-buffer-p (current-buffer) persp))) + 'doom-modeline-persp-buffer-not-in-persp + 'doom-modeline-persp-name)) + (icon (doom-modeline-icon 'octicon "nf-oct-repo" "🖿" "#" + :face `(:inherit ,face :slant normal)))) + (when (or doom-modeline-display-default-persp-name + (not (string-equal persp-nil-name name))) + (concat " " + (propertize (concat (and doom-modeline-persp-icon + (concat icon + (propertize + " " + 'display '((space :relative-width 0.5))))) + (propertize name 'face face)) + 'help-echo "mouse-1: Switch perspective +mouse-2: Show help for minor mode" + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + #'persp-switch) + (define-key map [mode-line mouse-2] + (lambda () + (interactive) + (describe-function 'persp-mode))) + map)) + " ")))))) + +(add-hook 'buffer-list-update-hook #'doom-modeline-update-persp-name) +(add-hook 'find-file-hook #'doom-modeline-update-persp-name) +(add-hook 'persp-activated-functions #'doom-modeline-update-persp-name) +(add-hook 'persp-renamed-functions #'doom-modeline-update-persp-name) +(advice-add #'lv-message :after #'doom-modeline-update-persp-name) + +(doom-modeline-def-segment persp-name + "The current perspective name." + (when (doom-modeline--segment-visible 'persp-name) + doom-modeline--persp-name)) + + +;; +;; Misc info +;; + +(doom-modeline-def-segment misc-info + "Mode line construct for miscellaneous information. +By default, this shows the information specified by `global-mode-string'." + (when (or doom-modeline-display-misc-in-all-mode-lines + (doom-modeline--segment-visible 'misc-info)) + (doom-modeline-display-text + (string-replace "%" "%%" (format-mode-line mode-line-misc-info))))) + + +;; +;; Position +;; + +(doom-modeline-def-segment buffer-position + "The buffer position information." + (let ((visible (doom-modeline--segment-visible 'buffer-position)) + (sep (doom-modeline-spc)) + (wsep (doom-modeline-wspc)) + (face (doom-modeline-face)) + (help-echo "Buffer percentage\n\ +mouse-1: Display Line and Column Mode Menu") + (mouse-face 'doom-modeline-highlight) + (local-map mode-line-column-line-number-mode-map)) + `(,wsep + + ;; Line and column + (:propertize + ((line-number-mode + (column-number-mode + (doom-modeline-column-zero-based + doom-modeline-position-column-line-format + ,(string-replace + "%c" "%C" (car doom-modeline-position-column-line-format))) + doom-modeline-position-line-format) + (column-number-mode + (doom-modeline-column-zero-based + doom-modeline-position-column-format + ,(string-replace + "%c" "%C" (car doom-modeline-position-column-format))))) + (doom-modeline-total-line-number + ,(and doom-modeline-total-line-number + (format "/%d" (line-number-at-pos (point-max)))))) + face ,face + help-echo ,help-echo + mouse-face ,mouse-face + local-map ,local-map) + + ((or line-number-mode column-number-mode) + ,sep) + + ;; Position + (,visible + ,(cond + ((bound-and-true-p nyan-mode) + (concat sep (nyan-create) sep)) + ((bound-and-true-p poke-line-mode) + (concat sep (poke-line-create) sep)) + ((bound-and-true-p mlscroll-mode) + (concat sep + (let ((mlscroll-right-align nil)) + (format-mode-line (mlscroll-mode-line))) + sep)) + ((bound-and-true-p sml-modeline-mode) + (concat sep (sml-modeline-create) sep)) + (t ""))) + + ;; Percent position + (doom-modeline-percent-position + ((:propertize ("" doom-modeline-percent-position) + face ,face + help-echo ,help-echo + mouse-face ,mouse-face + local-map ,local-map) + ,sep))))) + +;; +;; Party parrot +;; +(doom-modeline-def-segment parrot + "The party parrot animated icon. Requires `parrot-mode' to be enabled." + (when (and (doom-modeline--segment-visible 'parrot) + (bound-and-true-p parrot-mode)) + (concat (doom-modeline-wspc) + (parrot-create) + (doom-modeline-spc)))) + +;; +;; Modals (evil, overwrite, god, ryo and xah-fly-keys, etc.) +;; + +(defun doom-modeline--modal-icon (text face help-echo &optional icon unicode) + "Display the model icon with FACE and HELP-ECHO. +TEXT is alternative if icon is not available." + (propertize (doom-modeline-icon + 'mdicon + (and doom-modeline-modal-icon + (or (and doom-modeline-modal-modern-icon icon) + "nf-md-record")) + (or (and doom-modeline-modal-modern-icon unicode) "●") + text + :face (doom-modeline-face face)) + 'help-echo help-echo)) + +(defsubst doom-modeline--evil () + "The current evil state. Requires `evil-mode' to be enabled." + (when (bound-and-true-p evil-local-mode) + (doom-modeline--modal-icon + (let ((tag (evil-state-property evil-state :tag t))) + (if (stringp tag) tag (funcall tag))) + (cond + ((evil-normal-state-p) 'doom-modeline-evil-normal-state) + ((evil-emacs-state-p) 'doom-modeline-evil-emacs-state) + ((evil-insert-state-p) 'doom-modeline-evil-insert-state) + ((evil-motion-state-p) 'doom-modeline-evil-motion-state) + ((evil-visual-state-p) 'doom-modeline-evil-visual-state) + ((evil-operator-state-p) 'doom-modeline-evil-operator-state) + ((evil-replace-state-p) 'doom-modeline-evil-replace-state) + (t 'doom-modeline-evil-user-state)) + (evil-state-property evil-state :name t) + (cond + ((evil-normal-state-p) "nf-md-alpha_n_circle") + ((evil-emacs-state-p) "nf-md-alpha_e_circle") + ((evil-insert-state-p) "nf-md-alpha_i_circle") + ((evil-motion-state-p) "nf-md-alpha_m_circle") + ((evil-visual-state-p) "nf-md-alpha_v_circle") + ((evil-operator-state-p) "nf-md-alpha_o_circle") + ((evil-replace-state-p) "nf-md-alpha_r_circle") + (t "nf-md-alpha_u_circle")) + (cond + ((evil-normal-state-p) "🅝") + ((evil-emacs-state-p) "🅔") + ((evil-insert-state-p) "🅘") + ((evil-motion-state-p) "🅜") + ((evil-visual-state-p) "🅥") + ((evil-operator-state-p) "🅞") + ((evil-replace-state-p) "🅡") + (t "🅤"))))) + +(defsubst doom-modeline--overwrite () + "The current overwrite state which is enabled by command `overwrite-mode'." + (when (and (bound-and-true-p overwrite-mode) + (not (bound-and-true-p evil-local-mode))) + (doom-modeline--modal-icon + "<W>" 'doom-modeline-overwrite "Overwrite mode" + "nf-md-marker" "🅦"))) + +(defsubst doom-modeline--god () + "The current god state which is enabled by the command `god-mode'." + (when (bound-and-true-p god-local-mode) + (doom-modeline--modal-icon + "<G>" 'doom-modeline-god "God mode" + "nf-md-account_circle" "🅖"))) + +(defsubst doom-modeline--ryo () + "The current ryo-modal state which is enabled by the command `ryo-modal-mode'." + (when (bound-and-true-p ryo-modal-mode) + (doom-modeline--modal-icon + "<R>" 'doom-modeline-ryo "Ryo modal" + "nf-md-star_circle" "✪"))) + +(defsubst doom-modeline--xah-fly-keys () + "The current `xah-fly-keys' state." + (when (bound-and-true-p xah-fly-keys) + (if xah-fly-insert-state-p + (doom-modeline--modal-icon + "<I>" 'doom-modeline-fly-insert-state "Xah-fly insert mode" + "nf-md-airplane_edit" "🛧") + (doom-modeline--modal-icon + "<C>" 'doom-modeline-fly-normal-state "Xah-fly command mode" + "nf-md-airplane_cog" "🛧")))) + +(defsubst doom-modeline--boon () + "The current Boon state. Requires `boon-mode' to be enabled." + (when (bound-and-true-p boon-local-mode) + (doom-modeline--modal-icon + (boon-state-string) + (cond + (boon-command-state 'doom-modeline-boon-command-state) + (boon-insert-state 'doom-modeline-boon-insert-state) + (boon-special-state 'doom-modeline-boon-special-state) + (boon-off-state 'doom-modeline-boon-off-state) + (t 'doom-modeline-boon-off-state)) + (boon-modeline-string) + "nf-md-coffee" "🍵"))) + +(defsubst doom-modeline--meow () + "The current Meow state. Requires `meow-mode' to be enabled." + (when (bound-and-true-p meow-mode) + (doom-modeline--modal-icon + (substring-no-properties meow--indicator) + (cond + ((meow-normal-mode-p) 'doom-modeline-meow-normal-state) + ((meow-insert-mode-p) 'doom-modeline-meow-insert-state) + ((meow-beacon-mode-p) 'doom-modeline-meow-beacon-state) + ((meow-motion-mode-p) 'doom-modeline-meow-motion-state) + ((meow-keypad-mode-p) 'doom-modeline-meow-keypad-state) + (t 'doom-modeline-meow-normal-state)) + (symbol-name (meow--current-state)) + (cond + ((meow-normal-mode-p) "nf-md-alpha_n_circle") + ((meow-insert-mode-p) "nf-md-alpha_i_circle") + ((meow-beacon-mode-p) "nf-md-alpha_b_circle") + ((meow-motion-mode-p) "nf-md-alpha_m_circle") + ((meow-keypad-mode-p) "nf-md-alpha_k_circle") + (t "nf-md-alpha_n_circle")) + (cond + ((meow-normal-mode-p) "🅝") + ((meow-insert-mode-p) "🅘") + ((meow-beacon-mode-p) "🅑") + ((meow-motion-mode-p) "🅜") + ((meow-keypad-mode-p) "🅚") + (t "🅝"))))) + +(doom-modeline-def-segment modals + "Displays modal editing states. + +Including `evil', `overwrite', `god', `ryo' and `xha-fly-kyes', etc." + (when doom-modeline-modal + (let* ((evil (doom-modeline--evil)) + (ow (doom-modeline--overwrite)) + (god (doom-modeline--god)) + (ryo (doom-modeline--ryo)) + (xf (doom-modeline--xah-fly-keys)) + (boon (doom-modeline--boon)) + (meow (doom-modeline--meow)) + (vsep (doom-modeline-vspc)) + (sep (and (or evil ow god ryo xf boon meow) (doom-modeline-spc)))) + (concat sep + (and evil (concat evil (and (or ow god ryo xf boon meow) vsep))) + (and ow (concat ow (and (or god ryo xf boon meow) vsep))) + (and god (concat god (and (or ryo xf boon meow) vsep))) + (and ryo (concat ryo (and (or xf boon meow) vsep))) + (and xf (concat xf (and (or boon meow) vsep))) + (and boon (concat boon (and meow vsep))) + meow + sep)))) + +;; +;; Objed state +;; + +(defvar doom-modeline--objed-active nil) + +(defun doom-modeline-update-objed (_ &optional reset) + "Update `objed' status, inactive when RESET is true." + (setq doom-modeline--objed-active (not reset))) + +(setq objed-modeline-setup-func #'doom-modeline-update-objed) + +(doom-modeline-def-segment objed-state () + "The current objed state." + (when (and doom-modeline--objed-active + (doom-modeline--active)) + (propertize (format " %s(%s) " + (symbol-name objed--object) + (char-to-string (aref (symbol-name objed--obj-state) 0))) + 'face 'doom-modeline-evil-emacs-state + 'help-echo (format "Objed object: %s (%s)" + (symbol-name objed--object) + (symbol-name objed--obj-state))))) + + +;; +;; Input method +;; + +(doom-modeline-def-segment input-method + "The current input method." + (when-let* ((im (cond + (current-input-method + current-input-method-title) + ((and (bound-and-true-p evil-local-mode) + (bound-and-true-p evil-input-method)) + (nth 3 (assoc default-input-method input-method-alist))) + (t nil))) + (sep (doom-modeline-spc))) + (concat + sep + (propertize im + 'face (doom-modeline-face + (if (and (bound-and-true-p rime-mode) + (equal current-input-method "rime")) + (if (and (rime--should-enable-p) + (not (rime--should-inline-ascii-p))) + 'doom-modeline-input-method + 'doom-modeline-input-method-alt) + 'doom-modeline-input-method)) + 'help-echo (concat + "Current input method: " + current-input-method + "\n\ +mouse-2: Disable input method\n\ +mouse-3: Describe current input method") + 'mouse-face 'doom-modeline-highlight + 'local-map mode-line-input-method-map) + sep))) + + +;; +;; Info +;; + +(doom-modeline-def-segment info-nodes + "The topic and nodes in the Info buffer." + (concat + " (" + ;; topic + (propertize (if (stringp Info-current-file) + (replace-regexp-in-string + "%" "%%" + (file-name-sans-extension + (file-name-nondirectory Info-current-file))) + (format "*%S*" Info-current-file)) + 'face (doom-modeline-face 'doom-modeline-info)) + ") " + ;; node + (when Info-current-node + (propertize (replace-regexp-in-string + "%" "%%" Info-current-node) + 'face (doom-modeline-face 'doom-modeline-buffer-path) + 'help-echo + "mouse-1: scroll forward, mouse-3: scroll back" + 'mouse-face 'doom-modeline-highlight + 'local-map Info-mode-line-node-keymap)))) + + +;; +;; REPL +;; + +(defun doom-modeline-repl-icon (text face) + "Display REPL icon (or TEXT in terminal) with FACE." + (doom-modeline-icon 'faicon "nf-fa-terminal" "$" text :face face)) + +(defvar doom-modeline--cider nil) + +(defun doom-modeline-update-cider () + "Update cider repl state." + (setq doom-modeline--cider + (let* ((connected (cider-connected-p)) + (face (if connected 'doom-modeline-repl-success 'doom-modeline-repl-warning)) + (repl-buffer (cider-current-repl nil nil)) + (cider-info (when repl-buffer + (cider--connection-info repl-buffer t))) + (icon (doom-modeline-repl-icon "REPL" face))) + (propertize icon + 'help-echo + (if connected + (format "CIDER Connected %s\nmouse-2: CIDER quit" cider-info) + "CIDER Disconnected\nmouse-1: CIDER jack-in") + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (if connected + (define-key map [mode-line mouse-2] + #'cider-quit) + (define-key map [mode-line mouse-1] + #'cider-jack-in)) + map))))) + +(add-hook 'cider-connected-hook #'doom-modeline-update-cider) +(add-hook 'cider-disconnected-hook #'doom-modeline-update-cider) +(add-hook 'cider-mode-hook #'doom-modeline-update-cider) + +(doom-modeline-def-segment repl + "The REPL state." + (when doom-modeline-repl + (when-let* ((icon (when (bound-and-true-p cider-mode) + doom-modeline--cider)) + (sep (doom-modeline-spc))) + (concat + sep + (doom-modeline-display-icon icon) + sep)))) + + +;; +;; LSP +;; + +(defun doom-modeline-lsp-icon (text face) + "Display LSP icon (or TEXT in terminal) with FACE." + (if doom-modeline-lsp-icon + (doom-modeline-icon 'octicon "nf-oct-rocket" "🚀" text :face face) + (propertize text 'face face))) + +(defvar-local doom-modeline--lsp nil) +(defun doom-modeline-update-lsp (&rest _) + "Update `lsp-mode' state." + (setq doom-modeline--lsp + (let* ((workspaces (lsp-workspaces)) + (face (if workspaces 'doom-modeline-lsp-success 'doom-modeline-lsp-warning)) + (icon (doom-modeline-lsp-icon "LSP" face))) + (propertize icon + 'help-echo + (if workspaces + (concat "LSP connected " + (string-join + (mapcar (lambda (w) + (format "[%s]\n" (lsp--workspace-print w))) + workspaces)) + "C-mouse-1: Switch to another workspace folder +mouse-1: Describe current session +mouse-2: Quit server +mouse-3: Reconnect to server") + "LSP Disconnected +mouse-1: Reload to start server") + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (if workspaces + (progn + (define-key map [mode-line C-mouse-1] + #'lsp-workspace-folders-open) + (define-key map [mode-line mouse-1] + #'lsp-describe-session) + (define-key map [mode-line mouse-2] + #'lsp-workspace-shutdown) + (define-key map [mode-line mouse-3] + #'lsp-workspace-restart)) + (progn + (define-key map [mode-line mouse-1] + (lambda () + (interactive) + (ignore-errors (revert-buffer t t)))))) + map))))) +(add-hook 'lsp-before-initialize-hook #'doom-modeline-update-lsp) +(add-hook 'lsp-after-initialize-hook #'doom-modeline-update-lsp) +(add-hook 'lsp-after-uninitialized-functions #'doom-modeline-update-lsp) +(add-hook 'lsp-before-open-hook #'doom-modeline-update-lsp) +(add-hook 'lsp-after-open-hook #'doom-modeline-update-lsp) + +(defun doom-modeline--eglot-pending-count (server) + "Get count of pending eglot requests to SERVER." + (if (fboundp 'jsonrpc-continuation-count) + (jsonrpc-continuation-count server) + (hash-table-count (jsonrpc--request-continuations server)))) + +(defvar-local doom-modeline--eglot nil) +(defun doom-modeline-update-eglot () + "Update eglot state." + (setq doom-modeline--eglot + (let* ((server (and (eglot-managed-p) (eglot-current-server))) + (nick (and server (eglot-project-nickname server))) + (pending (and server (doom-modeline--eglot-pending-count server))) + (last-error (and server (jsonrpc-last-error server))) + (face (cond (last-error 'doom-modeline-lsp-error) + ((and pending (cl-plusp pending)) 'doom-modeline-lsp-warning) + (nick 'doom-modeline-lsp-success) + (t 'doom-modeline-lsp-warning))) + (server-info (and server (eglot--server-info server))) + (server-name (or (plist-get server-info :name) + (and server (jsonrpc-name server)) "")) + (major-modes (or (and server (eglot--major-modes server)) "")) + (icon (doom-modeline-lsp-icon eglot-menu-string face))) + (propertize icon + 'help-echo (format "Eglot connected [%s]\n%s %s +mouse-1: Display minor mode menu +mouse-3: LSP server control menu" + nick server-name major-modes) + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] eglot-menu) + (define-key map [mode-line mouse-3] eglot-server-menu) + map))))) +(add-hook 'eglot-managed-mode-hook #'doom-modeline-update-eglot) + +(defvar-local doom-modeline--tags nil) +(defun doom-modeline-update-tags () + "Update tags state." + (setq doom-modeline--tags + (propertize + (doom-modeline-lsp-icon "Tags" 'doom-modeline-lsp-success) + 'help-echo "Tags: Citre mode +mouse-1: Toggle citre mode" + 'mouse-face 'doom-modeline-highlight + 'local-map (make-mode-line-mouse-map 'mouse-1 #'citre-mode)))) +(add-hook 'citre-mode-hook #'doom-modeline-update-tags) + +(defun doom-modeline-update-lsp-icon () + "Update lsp icon." + (cond ((bound-and-true-p lsp-mode) + (doom-modeline-update-lsp)) + ((bound-and-true-p eglot--managed-mode) + (doom-modeline-update-eglot)) + ((bound-and-true-p citre-mode) + (doom-modeline-update-tags)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-lsp-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-lsp-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-lsp-icon)))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-lsp-icon)))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-unicode-fallback val) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (doom-modeline-update-lsp-icon)))))) + +(doom-modeline-def-segment lsp + "The LSP server state." + (when doom-modeline-lsp + (when-let* ((icon (cond ((bound-and-true-p lsp-mode) + doom-modeline--lsp) + ((bound-and-true-p eglot--managed-mode) + doom-modeline--eglot) + ((bound-and-true-p citre-mode) + doom-modeline--tags))) + (sep (doom-modeline-spc))) + (concat + sep + (doom-modeline-display-icon icon) + sep)))) + +(defun doom-modeline-override-eglot () + "Override `eglot' mode-line." + (if (and doom-modeline-lsp + (bound-and-true-p doom-modeline-mode)) + (setq mode-line-misc-info + (delq (assq 'eglot--managed-mode mode-line-misc-info) mode-line-misc-info)) + (add-to-list 'mode-line-misc-info + `(eglot--managed-mode (" [" eglot--mode-line-format "] "))))) +(add-hook 'eglot-managed-mode-hook #'doom-modeline-override-eglot) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-eglot) + +(doom-modeline-add-variable-watcher + 'doom-modeline-battery + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-lsp val) + (doom-modeline-override-eglot)))) + + +;; +;; GitHub +;; + +(defvar doom-modeline--github-notification-number 0) +(defvar doom-modeline-before-github-fetch-notification-hook nil + "Hooks before fetching GitHub notifications. +Example: + (add-hook \\='doom-modeline-before-github-fetch-notification-hook + #\\='auth-source-pass-enable)") + +(defvar doom-modeline-after-github-fetch-notification-hook nil + "Hooks after fetching GitHub notifications.") + +(defun doom-modeline--github-fetch-notifications () + "Fetch GitHub notifications." + (when (and doom-modeline-github + (require 'async nil t)) + (async-start + `(lambda () + ,(async-inject-variables + "\\`\\(load-path\\|auth-sources\\|doom-modeline-before-github-fetch-notification-hook\\)\\'") + (run-hooks 'doom-modeline-before-github-fetch-notification-hook) + (when (require 'ghub nil t) + (with-timeout (10) + (ignore-errors + (when-let* ((username (ghub--username ghub-default-host)) + (token (or (ghub--token ghub-default-host username 'forge t) + (ghub--token ghub-default-host username 'ghub t)))) + (ghub-get "/notifications" + '((notifications . t)) + :host ghub-default-host + :username username + :auth token + :unpaginate t + :noerror t)))))) + (lambda (result) + (message "") ; suppress message + (setq doom-modeline--github-notification-number (length result)) + (run-hooks 'doom-modeline-after-github-fetch-notification-hook))))) + +(defvar doom-modeline--github-timer nil) +(defun doom-modeline-github-timer () + "Start/Stop the timer for GitHub fetching." + (if (timerp doom-modeline--github-timer) + (cancel-timer doom-modeline--github-timer)) + (setq doom-modeline--github-timer + (and doom-modeline-github + (run-with-idle-timer 30 + doom-modeline-github-interval + #'doom-modeline--github-fetch-notifications)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-github + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-github val) + (doom-modeline-github-timer)))) + +(doom-modeline-github-timer) + +(doom-modeline-def-segment github + "The GitHub notifications." + (when (and doom-modeline-github + (doom-modeline--segment-visible 'github) + (numberp doom-modeline--github-notification-number)) + (let ((sep (doom-modeline-spc))) + (concat + sep + (propertize + (concat + (doom-modeline-icon 'octicon "nf-oct-mark_github" "🔔" "&" + :face 'doom-modeline-notification) + (and (> doom-modeline--github-notification-number 0) (doom-modeline-vspc)) + (propertize + (cond + ((<= doom-modeline--github-notification-number 0) "") + ((> doom-modeline--github-notification-number 99) "99+") + (t (number-to-string doom-modeline--github-notification-number))) + 'face '(:inherit + (doom-modeline-unread-number doom-modeline-notification)))) + 'help-echo "Github Notifications +mouse-1: Show notifications +mouse-3: Fetch notifications" + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + (lambda () + "Open GitHub notifications page." + (interactive) + (run-with-idle-timer 300 nil #'doom-modeline--github-fetch-notifications) + (browse-url "https://github.com/notifications"))) + (define-key map [mode-line mouse-3] + (lambda () + "Fetching GitHub notifications." + (interactive) + (message "Fetching GitHub notifications...") + (doom-modeline--github-fetch-notifications))) + map)) + sep)))) + + +;; +;; Debug states +;; + +;; Highlight the doom-modeline while debugging. +(defvar-local doom-modeline--debug-cookie nil) +(defun doom-modeline--debug-visual (&rest _) + "Update the face of mode-line for debugging." + (mapc (lambda (buffer) + (with-current-buffer buffer + (setq doom-modeline--debug-cookie + (face-remap-add-relative 'doom-modeline 'doom-modeline-debug-visual)) + (force-mode-line-update))) + (buffer-list))) + +(defun doom-modeline--normal-visual (&rest _) + "Restore the face of mode-line." + (mapc (lambda (buffer) + (with-current-buffer buffer + (when doom-modeline--debug-cookie + (face-remap-remove-relative doom-modeline--debug-cookie) + (force-mode-line-update)))) + (buffer-list))) + +(add-hook 'dap-session-created-hook #'doom-modeline--debug-visual) +(add-hook 'dap-terminated-hook #'doom-modeline--normal-visual) + +(defun doom-modeline-debug-icon (face) + "Display debug icon with FACE and ARGS." + (doom-modeline-icon 'codicon "nf-cod-debug" "🐛" "!" :face face)) + +(defun doom-modeline--debug-dap () + "The current `dap-mode' state." + (when (and (bound-and-true-p dap-mode) + (bound-and-true-p lsp-mode)) + (when-let* ((session (dap--cur-session))) + (when (dap--session-running session) + (propertize (doom-modeline-debug-icon 'doom-modeline-info) + 'help-echo (format "DAP (%s - %s) +mouse-1: Display debug hydra +mouse-2: Display recent configurations +mouse-3: Disconnect session" + (dap--debug-session-name session) + (dap--debug-session-state session)) + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + #'dap-hydra) + (define-key map [mode-line mouse-2] + #'dap-debug-recent) + (define-key map [mode-line mouse-3] + #'dap-disconnect) + map)))))) + +(defvar-local doom-modeline--debug-dap nil) +(defun doom-modeline-update-debug-dap (&rest _) + "Update dap debug state." + (setq doom-modeline--debug-dap (doom-modeline--debug-dap))) + +(add-hook 'dap-session-created-hook #'doom-modeline-update-debug-dap) +(add-hook 'dap-session-changed-hook #'doom-modeline-update-debug-dap) +(add-hook 'dap-terminated-hook #'doom-modeline-update-debug-dap) + +(defsubst doom-modeline--debug-edebug () + "The current `edebug' state." + (when (bound-and-true-p edebug-mode) + (propertize (doom-modeline-debug-icon 'doom-modeline-info) + 'help-echo (format "EDebug (%s) +mouse-1: Show help +mouse-2: Next +mouse-3: Stop debugging" + edebug-execution-mode) + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + #'edebug-help) + (define-key map [mode-line mouse-2] + #'edebug-next-mode) + (define-key map [mode-line mouse-3] + #'edebug-stop) + map)))) + +(defsubst doom-modeline--debug-on-error () + "The current `debug-on-error' state." + (when debug-on-error + (propertize (doom-modeline-debug-icon 'doom-modeline-urgent) + 'help-echo "Debug on Error +mouse-1: Toggle Debug on Error" + 'mouse-face 'doom-modeline-highlight + 'local-map (make-mode-line-mouse-map 'mouse-1 #'toggle-debug-on-error)))) + +(defsubst doom-modeline--debug-on-quit () + "The current `debug-on-quit' state." + (when debug-on-quit + (propertize (doom-modeline-debug-icon 'doom-modeline-warning) + 'help-echo "Debug on Quit +mouse-1: Toggle Debug on Quit" + 'mouse-face 'doom-modeline-highlight + 'local-map (make-mode-line-mouse-map 'mouse-1 #'toggle-debug-on-quit)))) + +(doom-modeline-def-segment debug + "The current debug state." + (when (doom-modeline--segment-visible 'debug) + (let* ((dap doom-modeline--debug-dap) + (edebug (doom-modeline--debug-edebug)) + (on-error (doom-modeline--debug-on-error)) + (on-quit (doom-modeline--debug-on-quit)) + (vsep (doom-modeline-vspc)) + (sep (and (or dap edebug on-error on-quit) (doom-modeline-spc)))) + (concat sep + (and dap (concat dap (and (or edebug on-error on-quit) vsep))) + (and edebug (concat edebug (and (or on-error on-quit) vsep))) + (and on-error (concat on-error (and on-quit vsep))) + on-quit + sep)))) + + +;; +;; PDF pages +;; + +(defvar-local doom-modeline--pdf-pages nil) +(defun doom-modeline-update-pdf-pages () + "Update PDF pages." + (setq doom-modeline--pdf-pages + (format " P%d/%d " + (or (eval `(pdf-view-current-page)) 0) + (pdf-cache-number-of-pages)))) +(add-hook 'pdf-view-change-page-hook #'doom-modeline-update-pdf-pages) + +(doom-modeline-def-segment pdf-pages + "Display PDF pages." + doom-modeline--pdf-pages) + + +;; +;; `mu4e' notifications +;; + +(doom-modeline-def-segment mu4e + "Show notifications of any unread emails in `mu4e'." + (when (and doom-modeline-mu4e + (doom-modeline--segment-visible 'mu4e)) + (let ((sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc)) + (icon (doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" + :face 'doom-modeline-notification))) + (cond ((and (bound-and-true-p mu4e-alert-mode-line) + (numberp mu4e-alert-mode-line) + ;; don't display if the unread mails count is zero + (> mu4e-alert-mode-line 0)) + (concat + sep + (propertize + (concat + icon + vsep + (propertize + (if (> mu4e-alert-mode-line doom-modeline-number-limit) + (format "%d+" doom-modeline-number-limit) + (number-to-string mu4e-alert-mode-line)) + 'face '(:inherit + (doom-modeline-unread-number doom-modeline-notification)))) + 'mouse-face 'doom-modeline-highlight + 'keymap '(mode-line keymap + (mouse-1 . mu4e-alert-view-unread-mails) + (mouse-2 . mu4e-alert-view-unread-mails) + (mouse-3 . mu4e-alert-view-unread-mails)) + 'help-echo (concat (if (= mu4e-alert-mode-line 1) + "You have an unread email" + (format "You have %s unread emails" mu4e-alert-mode-line)) + "\nClick here to view " + (if (= mu4e-alert-mode-line 1) "it" "them"))) + sep)) + ((bound-and-true-p mu4e-modeline-mode) + (concat sep icon vsep + (propertize (mu4e--modeline-string) + 'face 'doom-modeline-notification) + sep)))))) + +(defun doom-modeline-override-mu4e-alert (&rest _) + "Delete `mu4e-alert-mode-line' from global modeline string." + (when (and (featurep 'mu4e-alert) + (bound-and-true-p mu4e-alert-mode-line)) + (if (and doom-modeline-mu4e + (bound-and-true-p doom-modeline-mode)) + ;; Delete original modeline + (progn + (setq global-mode-string + (delete '(:eval mu4e-alert-mode-line) global-mode-string)) + (setq mu4e-alert-modeline-formatter #'identity)) + ;; Recover default settings + (setq mu4e-alert-modeline-formatter #'mu4e-alert-default-mode-line-formatter)))) +(advice-add #'mu4e-alert-enable-mode-line-display + :after #'doom-modeline-override-mu4e-alert) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-alert) + +(defun doom-modeline-override-mu4e-modeline (&rest _) + "Delete `mu4e-alert-mode-line' from global modeline string." + (when (bound-and-true-p mu4e-modeline-mode) + (if (and doom-modeline-mu4e + (bound-and-true-p doom-modeline-mode)) + ;; Delete original modeline + (setq global-mode-string + (delete mu4e--modeline-item global-mode-string)) + ;; Recover default settings + (add-to-list 'global-mode-string mu4e--modeline-item)))) +(add-hook 'mu4e-modeline-mode-hook #'doom-modeline-override-mu4e-modeline) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-mu4e-modeline) + +(doom-modeline-add-variable-watcher + 'doom-modeline-mu4e + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-mu4e val) + (doom-modeline-override-mu4e-alert) + (doom-modeline-override-mu4e-modeline)))) + + +;; +;; `gnus' notifications +;; + +(defvar doom-modeline--gnus-unread-mail 0) +(defvar doom-modeline--gnus-started nil + "Used to determine if gnus has started.") +(defun doom-modeline-update-gnus-status (&rest _) + "Get the total number of unread news of gnus group." + (setq doom-modeline--gnus-unread-mail + (when (and doom-modeline-gnus + doom-modeline--gnus-started) + (let ((total-unread-news-number 0)) + (mapc (lambda (g) + (let* ((group (car g)) + (unread (eval `(gnus-group-unread ,group)))) + (when (and (not (seq-contains-p doom-modeline-gnus-excluded-groups group)) + (numberp unread) + (> unread 0)) + (setq total-unread-news-number (+ total-unread-news-number unread))))) + gnus-newsrc-alist) + total-unread-news-number)))) + +;; Update the modeline after changes have been made +(add-hook 'gnus-group-update-hook #'doom-modeline-update-gnus-status) +(add-hook 'gnus-summary-update-hook #'doom-modeline-update-gnus-status) +(add-hook 'gnus-group-update-group-hook #'doom-modeline-update-gnus-status) +(add-hook 'gnus-after-getting-new-news-hook #'doom-modeline-update-gnus-status) + +;; Only start to listen to gnus when gnus is actually running +(defun doom-modeline-start-gnus-listener () + "Start GNUS listener." + (when (and doom-modeline-gnus + (not doom-modeline--gnus-started)) + (setq doom-modeline--gnus-started t) + ;; Scan gnus in the background if the timer is higher than 0 + (doom-modeline-update-gnus-status) + (if (> doom-modeline-gnus-timer 0) + (gnus-demon-add-handler 'gnus-demon-scan-news doom-modeline-gnus-timer doom-modeline-gnus-idle)))) +(add-hook 'gnus-started-hook #'doom-modeline-start-gnus-listener) + +;; Stop the listener if gnus isn't running +(defun doom-modeline-stop-gnus-listener () + "Stop GNUS listener." + (setq doom-modeline--gnus-started nil)) +(add-hook 'gnus-exit-gnus-hook #'doom-modeline-stop-gnus-listener) + +(doom-modeline-def-segment gnus + "Show notifications of any unread emails in `gnus'." + (when (and (doom-modeline--segment-visible 'gnus) + doom-modeline-gnus + doom-modeline--gnus-started + ;; Don't display if the unread mails count is zero + (numberp doom-modeline--gnus-unread-mail) + (> doom-modeline--gnus-unread-mail 0)) + (let ((sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc))) + (concat + sep + (propertize + (concat + (doom-modeline-icon 'mdicon "nf-md-email" "📧" "#" + :face 'doom-modeline-notification) + vsep + (propertize + (if (> doom-modeline--gnus-unread-mail doom-modeline-number-limit) + (format "%d+" doom-modeline-number-limit) + (number-to-string doom-modeline--gnus-unread-mail)) + 'face '(:inherit + (doom-modeline-unread-number doom-modeline-notification)))) + 'mouse-face 'doom-modeline-highlight + 'help-echo (if (= doom-modeline--gnus-unread-mail 1) + "You have an unread email" + (format "You have %s unread emails" doom-modeline--gnus-unread-mail))) + sep)))) + + +;; +;; IRC notifications +;; + +(defun doom-modeline-shorten-irc (name) + "Shorten IRC buffer `name' according to IRC mode. + +Calls the mode specific function to return the shortened +version of `NAME' if applicable: +- Circe: `tracking-shorten' +- ERC: `erc-track-shorten-function' +- rcirc: `rcirc-shorten-buffer-name' + +The specific function will decide how to stylize the buffer name, +read the individual functions documentation for more." + (or (and (fboundp 'tracking-shorten) + (car (tracking-shorten (list name)))) + (and (boundp 'erc-track-shorten-function) + (functionp erc-track-shorten-function) + (car (funcall erc-track-shorten-function (list name)))) + (and (fboundp 'rcirc-short-buffer-name) + (rcirc-short-buffer-name name)) + name)) + +(defun doom-modeline--tracking-buffers (buffers) + "Logic to convert some irc BUFFERS to their font-awesome icon." + (mapconcat + (lambda (b) + (propertize + (funcall doom-modeline-irc-stylize b) + 'face '(:inherit (doom-modeline-unread-number doom-modeline-notification)) + 'help-echo (format "IRC Notification: %s\nmouse-1: Switch to buffer" b) + 'mouse-face 'doom-modeline-highlight + 'local-map (make-mode-line-mouse-map + 'mouse-1 + (lambda () + (interactive) + (when (buffer-live-p (get-buffer b)) + (switch-to-buffer b)))))) + buffers + (doom-modeline-vspc))) + +(defun doom-modeline--circe-p () + "Check if `circe' is in use." + (boundp 'tracking-mode-line-buffers)) + +(defun doom-modeline--erc-p () + "Check if `erc' is in use." + (boundp 'erc-modified-channels-alist)) + +(defun doom-modeline--rcirc-p () + "Check if `rcirc' is in use." + (bound-and-true-p rcirc-track-minor-mode)) + +(defun doom-modeline--get-buffers () + "Gets the buffers that have activity." + (cond + ((doom-modeline--circe-p) + tracking-buffers) + ((doom-modeline--erc-p) + (mapcar (lambda (l) + (buffer-name (car l))) + erc-modified-channels-alist)) + ((doom-modeline--rcirc-p) + (mapcar (lambda (b) + (buffer-name b)) + rcirc-activity)))) + +;; Create a modeline segment that contains all the irc tracked buffers +(doom-modeline-def-segment irc-buffers + "The list of shortened, unread irc buffers." + (when (and doom-modeline-irc + (doom-modeline--segment-visible 'irc-buffers)) + (let* ((buffers (doom-modeline--get-buffers)) + (number (length buffers)) + (sep (doom-modeline-spc))) + (when (> number 0) + (concat + sep + (doom-modeline--tracking-buffers buffers) + sep))))) + +(doom-modeline-def-segment irc + "A notification icon for any unread irc buffer." + (when (and doom-modeline-irc + (doom-modeline--segment-visible 'irc)) + (let* ((buffers (doom-modeline--get-buffers)) + (number (length buffers)) + (sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc))) + (when (> number 0) + (concat + sep + + (propertize (concat + (doom-modeline-icon 'mdicon "nf-md-message_processing" "🗊" "#" + :face 'doom-modeline-notification) + vsep + ;; Display the number of unread buffers + (propertize (number-to-string number) + 'face '(:inherit + (doom-modeline-unread-number + doom-modeline-notification)))) + 'help-echo (format "IRC Notifications: %s\n%s" + (mapconcat + (lambda (b) (funcall doom-modeline-irc-stylize b)) + buffers + ", ") + (cond + ((doom-modeline--circe-p) + "mouse-1: Switch to previous unread buffer +mouse-3: Switch to next unread buffer") + ((doom-modeline--erc-p) + "mouse-1: Switch to buffer +mouse-3: Switch to next unread buffer") + ((doom-modeline--rcirc-p) + "mouse-1: Switch to server buffer +mouse-3: Switch to next unread buffer"))) + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (cond + ((doom-modeline--circe-p) + (define-key map [mode-line mouse-1] + #'tracking-previous-buffer) + (define-key map [mode-line mouse-3] + #'tracking-next-buffer)) + ((doom-modeline--erc-p) + (define-key map [mode-line mouse-1] + #'erc-switch-to-buffer) + (define-key map [mode-line mouse-3] + #'erc-track-switch-buffer)) + ((doom-modeline--rcirc-p) + (define-key map [mode-line mouse-1] + #'rcirc-switch-to-server-buffer) + (define-key map [mode-line mouse-3] + #'rcirc-next-active-buffer))) + map)) + + ;; Display the unread irc buffers as well + (when doom-modeline-irc-buffers + (concat sep (doom-modeline--tracking-buffers buffers))) + + sep))))) + +(defun doom-modeline-override-rcirc () + "Override default `rcirc' mode-line." + (if (and doom-modeline-irc + (bound-and-true-p doom-modeline-mode)) + (setq global-mode-string + (delq 'rcirc-activity-string global-mode-string)) + (when (and rcirc-track-minor-mode + (not (memq 'rcirc-activity-string global-mode-string))) + (setq global-mode-string + (append global-mode-string '(rcirc-activity-string)))))) +(add-hook 'rcirc-track-minor-mode-hook #'doom-modeline-override-rcirc) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-rcirc) + +(doom-modeline-add-variable-watcher + 'doom-modeline-irc + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-irc val) + (doom-modeline-override-rcirc)))) + + +;; +;; Battery status +;; + +(defun doom-modeline-battery-icon (icon unicode text face) + "Displays the battery ICON with FACE. + +UNICODE and TEXT are fallbacks. +Uses `nerd-icons-mdicon' to fetch the icon." + (doom-modeline-icon 'mdicon icon unicode text :face face)) + +(defvar doom-modeline--battery-status nil) +(defun doom-modeline-update-battery-status () + "Update battery status." + (setq doom-modeline--battery-status + (when (and doom-modeline-battery + (bound-and-true-p display-battery-mode)) + (let* ((data (and battery-status-function + (functionp battery-status-function) + (funcall battery-status-function))) + (status (cdr (assoc ?L data))) + (charging? (or (string-equal "AC" status) + (string-equal "on-line" status))) + (percentage (car (read-from-string (or (cdr (assq ?p data)) "ERR")))) + (valid-percentage? (and (numberp percentage) + (>= percentage 0) + (<= percentage battery-mode-line-limit))) + (face (if valid-percentage? + (cond (charging? 'doom-modeline-battery-charging) + ((< percentage battery-load-critical) 'doom-modeline-battery-critical) + ((< percentage 25) 'doom-modeline-battery-warning) + ((< percentage 95) 'doom-modeline-battery-normal) + (t 'doom-modeline-battery-full)) + 'doom-modeline-battery-error)) + (icon (if valid-percentage? + (cond + ((>= percentage 100) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_100" + "nf-md-battery") + "🔋" "-" face)) + ((>= percentage 90) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_90" + "nf-md-battery_90") + "🔋" "-" face)) + ((>= percentage 80) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_80" + "nf-md-battery_80") + "🔋" "-" face)) + ((>= percentage 70) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_70" + "nf-md-battery_70") + "🔋" "-" face)) + ((>= percentage 60) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_60" + "nf-md-battery_60") + "🔋" "-" face)) + ((>= percentage 50) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_50" + "nf-md-battery_50") + "🔋" "-" face)) + ((>= percentage 40) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_40" + "nf-md-battery_40") + "🔋" "-" face)) + ((>= percentage 30) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_30" + "nf-md-battery_30") + "🔋" "-" face)) + ((>= percentage 20) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_20" + "nf-md-battery_20") + "🔋" "-" face)) + ((>= percentage 10) + (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_10" + "nf-md-battery_10") + "🪫" "-" face)) + (t (doom-modeline-battery-icon (if charging? + "nf-md-battery_charging_outline" + "nf-md-battery_outline") + "🪫" "!" face))) + (doom-modeline-battery-icon "nf-md-battery_alert" "⚠" "N/A" face))) + (text (if valid-percentage? (format "%d%s" percentage "%%") "")) + (help-echo (if (and battery-echo-area-format data valid-percentage?) + (battery-format battery-echo-area-format data) + "Battery status not available"))) + (cons (propertize icon 'help-echo help-echo) + (propertize text 'face face 'help-echo help-echo)))))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-icon + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-icon val) + (doom-modeline-update-battery-status)))) + +(doom-modeline-add-variable-watcher + 'doom-modeline-unicode-fallback + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-unicode-fallback val) + (doom-modeline-update-battery-status)))) + +(doom-modeline-def-segment battery + "Display battery status." + (when (and doom-modeline-battery + (bound-and-true-p display-battery-mode) + (doom-modeline--segment-visible 'battery)) + (let ((sep (doom-modeline-spc)) + (vsep (doom-modeline-vspc))) + (concat sep + (car doom-modeline--battery-status) + vsep + (cdr doom-modeline--battery-status) + sep)))) + +(defun doom-modeline-override-battery () + "Override default battery mode-line." + (if (and doom-modeline-battery + (bound-and-true-p doom-modeline-mode)) + (progn + (advice-add #'battery-update :override #'doom-modeline-update-battery-status) + (setq global-mode-string + (delq 'battery-mode-line-string global-mode-string)) + (and (bound-and-true-p display-battery-mode) (battery-update))) + (progn + (advice-remove #'battery-update #'doom-modeline-update-battery-status) + (when (and display-battery-mode battery-status-function battery-mode-line-format + (not (memq 'battery-mode-line-string global-mode-string))) + (setq global-mode-string + (append global-mode-string '(battery-mode-line-string))))))) +(add-hook 'display-battery-mode-hook #'doom-modeline-override-battery) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-battery) + +(doom-modeline-add-variable-watcher + 'doom-modeline-battery + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-battery val) + (doom-modeline-override-battery)))) + + +;; +;; Package information +;; + +(doom-modeline-def-segment package + "Show package information via `paradox'." + (concat + (doom-modeline-display-text + (format-mode-line 'mode-line-front-space)) + + (when (and doom-modeline-icon doom-modeline-major-mode-icon) + (concat + (doom-modeline-spc) + (doom-modeline-icon 'faicon "nf-fa-archive" nil nil + :face (doom-modeline-face + (if doom-modeline-major-mode-color-icon + 'nerd-icons-silver + 'mode-line))))) + (doom-modeline-display-text + (format-mode-line 'mode-line-buffer-identification)))) + + +;; +;; Helm +;; + +(defvar doom-modeline--helm-buffer-ids + '(("*helm*" . "HELM") + ("*helm M-x*" . "HELM M-x") + ("*swiper*" . "SWIPER") + ("*Projectile Perspectives*" . "HELM Projectile Perspectives") + ("*Projectile Layouts*" . "HELM Projectile Layouts") + ("*helm-ag*" . (lambda () + (format "HELM Ag: Using %s" + (car (split-string helm-ag-base-command)))))) + "Alist of custom helm buffer names to use. +The cdr can also be a function that returns a name to use.") + +(doom-modeline-def-segment helm-buffer-id + "Helm session identifier." + (when (bound-and-true-p helm-alive-p) + (let ((sep (doom-modeline-spc))) + (concat + sep + (when doom-modeline-icon + (concat + (doom-modeline-icon 'sucicon "nf-custom-emacs" nil nil + :face (doom-modeline-face + (and doom-modeline-major-mode-color-icon + 'nerd-icons-blue))) + sep)) + (propertize + (let ((custom (cdr (assoc (buffer-name) doom-modeline--helm-buffer-ids))) + (case-fold-search t) + (name (replace-regexp-in-string "-" " " (buffer-name)))) + (cond ((stringp custom) custom) + ((functionp custom) (funcall custom)) + (t + (string-match "\\*helm:? \\(mode \\)?\\([^\\*]+\\)\\*" name) + (concat "HELM " (capitalize (match-string 2 name)))))) + 'face (doom-modeline-face 'doom-modeline-buffer-file)) + sep)))) + +(doom-modeline-def-segment helm-number + "Number of helm candidates." + (when (bound-and-true-p helm-alive-p) + (concat + (propertize (format " %d/%d" + (helm-candidate-number-at-point) + (helm-get-candidate-number t)) + 'face (doom-modeline-face 'doom-modeline-buffer-path)) + (propertize (format " (%d total) " (helm-get-candidate-number)) + 'face (doom-modeline-face 'doom-modeline-info))))) + +(doom-modeline-def-segment helm-help + "Helm keybindings help." + (when (bound-and-true-p helm-alive-p) + (mapcar + (lambda (s) + (if (string-prefix-p "\\<" s) + (propertize (substitute-command-keys s) + 'face (doom-modeline-face + 'doom-modeline-buffer-file)) + s)) + '("\\<helm-map>\\[helm-help]" "(help) " + "\\<helm-map>\\[helm-select-action]" "(actions) " + "\\<helm-map>\\[helm-maybe-exit-minibuffer]/F1/F2..." "(action) ")))) + +(doom-modeline-def-segment helm-prefix-argument + "Helm prefix argument." + (when (and (bound-and-true-p helm-alive-p) + helm--mode-line-display-prefarg) + (let ((arg (prefix-numeric-value (or prefix-arg current-prefix-arg)))) + (unless (= arg 1) + (propertize (format "C-u %s" arg) + 'face (doom-modeline-face 'doom-modeline-info)))))) + +(defvar doom-modeline--helm-current-source nil + "The currently active helm source.") +(doom-modeline-def-segment helm-follow + "Helm follow indicator." + (and (bound-and-true-p helm-alive-p) + doom-modeline--helm-current-source + (eq 1 (cdr (assq 'follow doom-modeline--helm-current-source))) + "HF")) + +;; +;; Git timemachine +;; + +(doom-modeline-def-segment git-timemachine + (concat + (doom-modeline-spc) + (doom-modeline--buffer-mode-icon) + (doom-modeline--buffer-state-icon) + (propertize + "*%b*" + 'face (doom-modeline-face 'doom-modeline-buffer-timemachine)))) + +;; +;; Markdown/Org preview +;; + +(doom-modeline-def-segment grip + (when (bound-and-true-p grip-mode) + (let ((sep (doom-modeline-spc))) + (concat + sep + (let ((face (doom-modeline-face + (if grip--process + (pcase (process-status grip--process) + ('run 'doom-modeline-info) + ('exit 'doom-modeline-warning) + (_ 'doom-modeline-urgent)) + 'doom-modeline-urgent)))) + (propertize + (doom-modeline-icon 'codicon "nf-cod-open_preview" "🗐" "@" :face face) + 'help-echo (format "Preview on %s +mouse-1: Preview in browser +mouse-2: Stop preview +mouse-3: Restart preview" + (grip--preview-url)) + 'mouse-face 'doom-modeline-highlight + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] + #'grip-browse-preview) + (define-key map [mode-line mouse-2] + #'grip-stop-preview) + (define-key map [mode-line mouse-3] + #'grip-restart-preview) + map))) + sep)))) + +;; +;; Follow mode +;; + +(doom-modeline-def-segment follow + (when (bound-and-true-p follow-mode) + (let* ((windows (follow-all-followers)) + (nwindows (length windows)) + (nfollowing (- (length (memq (selected-window) windows)) 1))) + (concat + (doom-modeline-spc) + (propertize (format "Follow %d/%d" (- nwindows nfollowing) nwindows) + 'face 'doom-modeline-buffer-minor-mode))))) + +;; +;; Display time +;; + +(defconst doom-modeline--clock-hour-hand-ratio 0.45 + "Length of the hour hand as a proportion of the radius.") + +(defconst doom-modeline--clock-minute-hand-ratio 0.7 + "Length of the minute hand as a proportion of the radius.") + +(defun doom-modeline--create-clock-svg (hour minute radius color) + "Construct an SVG clock showing the time HOUR:MINUTE. +The clock will be of the specified RADIUS and COLOR." + (let ((thickness-factor (image-compute-scaling-factor 'auto)) + (hour-x (* radius (sin (* (- 6 hour (/ minute 60.0)) (/ float-pi 6))) + doom-modeline--clock-hour-hand-ratio)) + (hour-y (* radius (cos (* (- 6 hour (/ minute 60.0)) (/ float-pi 6))) + doom-modeline--clock-hour-hand-ratio)) + (minute-x (* radius (sin (* (- 30 minute) (/ float-pi 30))) + doom-modeline--clock-minute-hand-ratio)) + (minute-y (* radius (cos (* (- 30 minute) (/ float-pi 30))) + doom-modeline--clock-minute-hand-ratio)) + (svg (svg-create (* 2 radius) (* 2 radius) :stroke color))) + (svg-circle svg radius radius (- radius thickness-factor) + :fill "none" :stroke-width (* 2 thickness-factor)) + (svg-circle svg radius radius thickness-factor + :fill color :stroke "none") + (svg-line svg radius radius (+ radius hour-x) (+ radius hour-y) + :stroke-width (* 2 thickness-factor)) + (svg-line svg radius radius (+ radius minute-x) (+ radius minute-y) + :stroke-width (* 1.5 thickness-factor)) + svg)) + +(defvar doom-modeline--clock-cache nil + "The last result of `doom-modeline--generate-clock'.") + +(defun doom-modeline--generate-clock () + "Return a string containing the current time as an analogue clock svg. +When the svg library is not available, return nil." + (cdr + (or (and (equal (truncate (float-time) + (* doom-modeline-time-clock-minute-resolution 60)) + (car doom-modeline--clock-cache)) + doom-modeline--clock-cache) + (and (require 'svg nil t) + (setq doom-modeline--clock-cache + (cons (truncate (float-time) + (* doom-modeline-time-clock-minute-resolution 60)) + (propertize + " " + 'display + (svg-image + (doom-modeline--create-clock-svg + (string-to-number (format-time-string "%-I")) ; hour + (* (truncate (string-to-number (format-time-string "%-M")) + doom-modeline-time-clock-minute-resolution) + doom-modeline-time-clock-minute-resolution) ; minute + (if (integerp doom-modeline-time-clock-size) ; radius + doom-modeline-time-clock-size + (* doom-modeline-height 0.5 doom-modeline-time-clock-size)) + "currentColor") + :scale 1 :ascent 'center) + 'face 'doom-modeline-time + 'help-echo (lambda (_window _object _pos) + (format-time-string "%c"))))))))) + +(defun doom-modeline-time-icon () + "Displays the time icon." + (or (and doom-modeline-time-live-icon + doom-modeline-time-analogue-clock + (display-graphic-p) + (doom-modeline--generate-clock)) + (doom-modeline-icon + 'mdicon + (if doom-modeline-time-live-icon + (pcase (% (caddr (decode-time)) 12) + (0 "nf-md-clock_time_twelve_outline") + (1 "nf-md-clock_time_one_outline") + (2 "nf-md-clock_time_two_outline") + (3 "nf-md-clock_time_three_outline") + (4 "nf-md-clock_time_four_outline") + (5 "nf-md-clock_time_five_outline") + (6 "nf-md-clock_time_six_outline") + (7 "nf-md-clock_time_seven_outline") + (8 "nf-md-clock_time_eight_outline") + (9 "nf-md-clock_time_nine_outline") + (10 "nf-md-clock_time_ten_outline") + (11 "nf-md-clock_time_eleven_outline")) + "nf-md-clock_outline") + "⏰" + "" + :face '(:inherit doom-modeline-time :weight normal)))) + +(doom-modeline-def-segment time + (when (and doom-modeline-time + (bound-and-true-p display-time-mode) + (doom-modeline--segment-visible 'time)) + (concat + (doom-modeline-spc) + (when doom-modeline-time-icon + (concat + (doom-modeline-time-icon) + (and (or doom-modeline-icon doom-modeline-unicode-fallback) + (doom-modeline-vspc)))) + (propertize display-time-string + 'face (doom-modeline-face 'doom-modeline-time))))) + +(defun doom-modeline-override-time () + "Override default `display-time' mode-line." + (or global-mode-string (setq global-mode-string '(""))) + (if (and doom-modeline-time + (bound-and-true-p doom-modeline-mode)) + (setq global-mode-string (delq 'display-time-string global-mode-string)) + (or (memq 'display-time-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(display-time-string)))))) +(add-hook 'display-time-mode-hook #'doom-modeline-override-time) +(add-hook 'doom-modeline-mode-hook #'doom-modeline-override-time) + +(doom-modeline-add-variable-watcher + 'doom-modeline-time + (lambda (_sym val op _where) + (when (eq op 'set) + (setq doom-modeline-time val) + (doom-modeline-override-time)))) + +;; +;; Compilation +;; + +(doom-modeline-def-segment compilation + (and (bound-and-true-p compilation-in-progress) + (propertize "[Compiling] " + 'face (doom-modeline-face 'doom-modeline-compilation) + 'help-echo "Compiling; mouse-2: Goto Buffer" + 'mouse-face 'doom-modeline-highlight + 'local-map + (make-mode-line-mouse-map + 'mouse-2 + #'compilation-goto-in-progress-buffer)))) + +;; +;; Eldoc +;; + +(doom-modeline-def-segment eldoc + (and (bound-and-true-p eldoc-mode) + '(eldoc-mode-line-string + (" " eldoc-mode-line-string " ")))) + +(defun doom-modeline-eldoc-minibuffer-message (format-string &rest args) + "Display message specified by FORMAT-STRING and ARGS on the mode-line as needed. +This function displays the message produced by formatting ARGS +with FORMAT-STRING on the mode line when the current buffer is a minibuffer. +Otherwise, it displays the message like `message' would." + (if (minibufferp) + (progn + (add-hook 'minibuffer-exit-hook + (lambda () (setq eldoc-mode-line-string nil + ;; https://debbugs.gnu.org/16920 + eldoc-last-message nil)) + nil t) + (with-current-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window))) + (setq eldoc-mode-line-string + (when (stringp format-string) + (apply #'format-message format-string args))) + (force-mode-line-update))) + (apply #'message format-string args))) + +;; +;; Kubernetes +;; + +(doom-modeline-def-segment k8s + (when (and (bound-and-true-p kele-mode) (doom-modeline--segment-visible 'k8s)) + (let* ((ctx (kele-current-context-name :wait nil)) + (ns (kele-current-namespace :wait nil)) + (icon (doom-modeline-icon 'mdicon "nf-md-kubernetes" "K8s:" "K8s:")) + (sep (doom-modeline-spc)) + (help-msg (let ((msgs (list (format "Current context: %s" ctx)))) + (when ns + (setq msgs (append msgs (list (format "Current namespace: %s" ns))))) + (string-join msgs "\n")))) + (propertize (concat + icon sep ctx + (when (and doom-modeline-k8s-show-namespace ns) (format "(%s)" ns)) + sep) + 'local-map (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] kele-menu-map) + map) + 'mouse-face 'doom-modeline-highlight + 'help-echo help-msg)))) + +(provide 'doom-modeline-segments) + +;;; doom-modeline-segments.el ends here diff --git a/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-segments.elc b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline-segments.elc Binary files differ. diff --git a/emacs/elpa/doom-modeline-20241117.1101/doom-modeline.el b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline.el @@ -0,0 +1,263 @@ +;;; doom-modeline.el --- A minimal and modern mode-line -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2024 Vincent Zhang + +;; Author: Vincent Zhang <seagle0128@gmail.com> +;; Homepage: https://github.com/seagle0128/doom-modeline +;; Package-Version: 20241117.1101 +;; Package-Revision: e6ae2ecfea9b +;; Package-Requires: ((emacs "25.1") (compat "29.1.4.5") (nerd-icons "0.1.0") (shrink-path "0.3.1")) +;; Keywords: faces mode-line + +;; This file is not part of GNU Emacs. + +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; + +;;; Commentary: +;; +;; This package offers a fancy and fast mode-line inspired by minimalism design. +;; +;; It's integrated into Doom Emacs (https://github.com/hlissner/doom-emacs) and +;; Centaur Emacs (https://github.com/seagle0128/.emacs.d). +;; +;; The doom-modeline offers: +;; - A match count panel (for anzu, iedit, multiple-cursors, symbol-overlay, +;; evil-search and evil-substitute) +;; - An indicator for recording a macro +;; - Current environment version (e.g. python, ruby, go, etc.) in the major-mode +;; - A customizable mode-line height (see doom-modeline-height) +;; - A minor modes segment which is compatible with minions +;; - An error/warning count segment for flymake/flycheck +;; - A workspace number segment for eyebrowse +;; - A perspective name segment for persp-mode +;; - A window number segment for winum and window-numbering +;; - An indicator for modal editing state, including evil, overwrite, god, ryo +;; and xah-fly-keys, etc. +;; - An indicator for battery status +;; - An indicator for current input method +;; - An indicator for debug state +;; - An indicator for remote host +;; - An indicator for LSP state with lsp-mode or eglot +;; - An indicator for github notifications +;; - An indicator for unread emails with mu4e-alert +;; - An indicator for unread emails with gnus (basically builtin) +;; - An indicator for irc notifications with circe, rcirc or erc. +;; - An indicator for buffer position which is compatible with nyan-mode or poke-line +;; - An indicator for party parrot +;; - An indicator for PDF page number with pdf-tools +;; - An indicator for markdown/org previews with grip +;; - Truncated file name, file icon, buffer state and project name in buffer +;; information segment, which is compatible with project, find-file-in-project +;; and projectile +;; - New mode-line for Info-mode buffers +;; - New package mode-line for paradox +;; - New mode-line for helm buffers +;; - New mode-line for git-timemachine buffers +;; +;; Installation: +;; From melpa, `M-x package-install RET doom-modeline RET`. +;; In `init.el`, +;; (require 'doom-modeline) +;; (doom-modeline-mode 1) +;; or +;; (use-package doom-modeline +;; :ensure t +;; :hook (after-init . doom-modeline-mode)) +;; + +;;; Code: + +(require 'doom-modeline-core) +(require 'doom-modeline-segments) + + +;; +;; Mode lines +;; + +(doom-modeline-def-modeline 'main + '(eldoc bar workspace-name window-number modals matches follow buffer-info remote-host buffer-position word-count parrot selection-info) + '(compilation objed-state misc-info persp-name battery grip irc mu4e gnus github debug repl lsp minor-modes input-method indent-info buffer-encoding major-mode process vcs check time)) + +(doom-modeline-def-modeline 'minimal + '(bar window-number modals matches buffer-info-simple) + '(media-info major-mode time)) + +(doom-modeline-def-modeline 'special + '(eldoc bar window-number modals matches buffer-info remote-host buffer-position word-count parrot selection-info) + '(compilation objed-state misc-info battery irc-buffers debug minor-modes input-method indent-info buffer-encoding major-mode process time)) + +(doom-modeline-def-modeline 'project + '(bar window-number modals buffer-default-directory remote-host buffer-position) + '(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time)) + +(doom-modeline-def-modeline 'dashboard + '(bar window-number modals buffer-default-directory-simple remote-host) + '(compilation misc-info battery irc mu4e gnus github debug minor-modes input-method major-mode process time)) + +(doom-modeline-def-modeline 'vcs + '(bar window-number modals matches buffer-info remote-host buffer-position parrot selection-info) + '(compilation misc-info battery irc mu4e gnus github debug minor-modes buffer-encoding major-mode process time)) + +(doom-modeline-def-modeline 'package + '(bar window-number modals package) + '(compilation misc-info major-mode process time)) + +(doom-modeline-def-modeline 'info + '(bar window-number modals buffer-info info-nodes buffer-position parrot selection-info) + '(compilation misc-info buffer-encoding major-mode time)) + +(doom-modeline-def-modeline 'media + '(bar window-number modals buffer-size buffer-info) + '(compilation misc-info media-info major-mode process vcs time)) + +(doom-modeline-def-modeline 'message + '(eldoc bar window-number modals matches buffer-info-simple buffer-position word-count parrot selection-info) + '(compilation objed-state misc-info battery debug minor-modes input-method indent-info buffer-encoding major-mode time)) + +(doom-modeline-def-modeline 'pdf + '(bar window-number modals matches buffer-info pdf-pages) + '(compilation misc-info major-mode process vcs time)) + +(doom-modeline-def-modeline 'org-src + '(eldoc bar window-number modals matches buffer-info buffer-position word-count parrot selection-info) + '(compilation objed-state misc-info debug lsp minor-modes input-method indent-info buffer-encoding major-mode process check time)) + +(doom-modeline-def-modeline 'helm + '(bar helm-buffer-id helm-number helm-follow helm-prefix-argument) + '(helm-help time)) + +(doom-modeline-def-modeline 'timemachine + '(eldoc bar window-number modals matches git-timemachine buffer-position word-count parrot selection-info) + '(misc-info minor-modes indent-info buffer-encoding major-mode time)) + +(doom-modeline-def-modeline 'calculator + '(window-number modals matches calc buffer-position) + '(misc-info minor-modes major-mode process)) + + +;; +;; Interfaces +;; + +;;;###autoload +(defun doom-modeline-set-main-modeline (&optional default) + "Set main mode-line. +If DEFAULT is non-nil, set the default mode-line for all buffers." + (doom-modeline-set-modeline 'main default)) + + +;; +;; Minor mode +;; + +;; Suppress warnings +(defvar 2C-mode-line-format) +(defvar flymake-mode-line-format) +(defvar helm-ag-show-status-function) +(declare-function helm-display-mode-line "ext:helm-core") + +(defvar doom-modeline-mode-map (make-sparse-keymap)) + +(defvar doom-modeline-mode-alist + '((message-mode . message) + (git-commit-mode . message) + (magit-mode . vcs) + (dashboard-mode . dashboard) + (Info-mode . info) + (image-mode . media) + (pdf-view-mode . pdf) + (org-src-mode . org-src) + (paradox-menu-mode . package) + (xwidget-webkit-mode . minimal) + (git-timemachine-mode . timemachine) + (calc-mode . calculator) + (calc-trail-mode . calculator) + (circe-mode . special) + (erc-mode . special) + (rcirc-mode . special)) + "Alist of major modes and mode-lines.") + +(defun doom-modeline-auto-set-modeline () + "Set mode-line base on major-mode." + (catch 'found + (dolist (x doom-modeline-mode-alist) + (when (derived-mode-p (car x)) + (doom-modeline-set-modeline (cdr x)) + (throw 'found x))))) + +(defun doom-modeline-set-helm-modeline (&rest _) ; To advice helm + "Set helm mode-line." + (doom-modeline-set-modeline 'helm)) + +;;;###autoload +(define-minor-mode doom-modeline-mode + "Toggle `doom-modeline' on or off." + :group 'doom-modeline + :global t + :lighter nil + :keymap doom-modeline-mode-map + (if doom-modeline-mode + (progn + (doom-modeline-refresh-bars) ; Create bars + (doom-modeline-set-main-modeline t) ; Set default mode-line + + ;; Apply to all existing buffers. + (dolist (buf (buffer-list)) + (with-current-buffer buf + (unless (doom-modeline-auto-set-modeline) + (doom-modeline-set-main-modeline)))) + + ;; For flymake + (setq flymake-mode-line-format nil) ; remove the lighter of minor mode + + ;; For Eldoc + (setq eldoc-message-function #'doom-modeline-eldoc-minibuffer-message) + + ;; For two-column editing + (setq 2C-mode-line-format (doom-modeline 'special)) + + ;; Automatically set mode-lines + (add-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline) + + ;; Special handles + (advice-add #'helm-display-mode-line :after #'doom-modeline-set-helm-modeline) + (setq helm-ag-show-status-function #'doom-modeline-set-helm-modeline)) + (progn + ;; Restore mode-line + (let ((original-format (doom-modeline--original-value 'mode-line-format))) + (setq-default mode-line-format original-format) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (setq mode-line-format original-format)))) + + ;; For flymake + (setq flymake-mode-line-format (doom-modeline--original-value 'flymake-mode-line-format)) + + ;; For Eldoc + (setq eldoc-message-function #'eldoc-minibuffer-message) + + ;; For two-column editing + (setq 2C-mode-line-format (doom-modeline--original-value '2C-mode-line-format)) + + ;; Cleanup + (remove-hook 'after-change-major-mode-hook #'doom-modeline-auto-set-modeline) + (advice-remove #'helm-display-mode-line #'doom-modeline-set-helm-modeline) + (setq helm-ag-show-status-function (default-value 'helm-ag-show-status-function))))) + +(provide 'doom-modeline) + +;;; doom-modeline.el ends here diff --git a/emacs/elpa/doom-modeline-20241102.1416/doom-modeline.elc b/emacs/elpa/doom-modeline-20241117.1101/doom-modeline.elc Binary files differ. diff --git a/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm-autoloads.el b/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm-autoloads.el @@ -0,0 +1,54 @@ +;;; eshell-vterm-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from eshell-vterm.el + +(defvar eshell-vterm-mode nil "\ +Non-nil if Eshell-Vterm mode is enabled. +See the `eshell-vterm-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `eshell-vterm-mode'.") +(custom-autoload 'eshell-vterm-mode "eshell-vterm" nil) +(autoload 'eshell-vterm-mode "eshell-vterm" "\ +Use Vterm for eshell visual commands. + +This is a global minor mode. If called interactively, toggle the +`Eshell-Vterm mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='eshell-vterm-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "eshell-vterm" '("eshell-vterm-")) + +;;; End of scraped data + +(provide 'eshell-vterm-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; eshell-vterm-autoloads.el ends here diff --git a/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm-pkg.el b/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm-pkg.el @@ -0,0 +1,11 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "eshell-vterm" "20240305.1149" + "Vterm for visual commands in eshell." + '((emacs "27.1") + (vterm "0.0.1")) + :url "https://github.com/iostapyshyn/eshell-vterm" + :commit "20f4b246fa605a1533cdfbe3cb7faf31a24e3d2e" + :revdesc "20f4b246fa60" + :keywords '("eshell" "vterm" "terminals" "shell" "visual" "tools" "processes") + :authors '(("Illia Ostapyshyn" . "ilya.ostapyshyn@gmail.com")) + :maintainers '(("Illia Ostapyshyn" . "ilya.ostapyshyn@gmail.com"))) diff --git a/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm.el b/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm.el @@ -0,0 +1,101 @@ +;;; eshell-vterm.el --- Vterm for visual commands in eshell -*- lexical-binding: t; -*- + +;; Author: Illia Ostapyshyn <ilya.ostapyshyn@gmail.com> +;; Maintainer: Illia Ostapyshyn <ilya.ostapyshyn@gmail.com> +;; Created: 2021-06-29 +;; Package-Version: 20240305.1149 +;; Package-Revision: 20f4b246fa60 +;; Package-Requires: ((emacs "27.1") (vterm "0.0.1")) +;; Keywords: eshell, vterm, terminals, shell, visual, tools, processes +;; URL: https://github.com/iostapyshyn/eshell-vterm + +;; This file is not part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides a global minor mode allowing eshell to use +;; vterm for visual commands. + +;;; Code: + +(require 'vterm) +(require 'em-term) +(require 'esh-ext) + +(defvar eshell-parent-buffer) + +(defun eshell-vterm-exec-visual (&rest args) + "Run the specified PROGRAM in a terminal emulation buffer. +ARGS are passed to the program. At the moment, no piping of input is +allowed. In case ARGS is nil, a new VTerm session is created." + (if args + (let* (eshell-interpreter-alist + (interp (eshell-find-interpreter (car args) (cdr args))) + (program (car interp)) + (args (flatten-tree + (eshell-stringify-list (append (cdr interp) + (cdr args))))) + (args (mapconcat #'shell-quote-argument args " ")) + (term-buf (generate-new-buffer + (concat "*" (file-name-nondirectory program) "*"))) + (eshell-buf (current-buffer)) + (vterm-shell (concat (shell-quote-argument + (file-local-name program)) + " " args))) + (save-current-buffer + (switch-to-buffer term-buf) + (cl-letf (((symbol-function 'vterm--get-shell) + (lambda () vterm-shell))) + (vterm-mode)) + (setq-local eshell-parent-buffer eshell-buf) + (let ((proc (get-buffer-process term-buf))) + (if (and proc (eq 'run (process-status proc))) + (set-process-sentinel proc #'eshell-vterm-sentinel) + (error "Failed to invoke visual command"))))) + (vterm '(4))) ; Start a new session + nil) + +(defun eshell-vterm-sentinel (proc msg) + "Clean up the buffer visiting PROC with message MSG. +If `eshell-destroy-buffer-when-process-dies' is non-nil, destroy +the buffer." + (let ((vterm-kill-buffer-on-exit nil)) + (vterm--sentinel proc msg)) ;; First call the normal term sentinel. + (when eshell-destroy-buffer-when-process-dies + (let ((proc-buf (process-buffer proc))) + (when (and proc-buf (buffer-live-p proc-buf) + (not (eq 'run (process-status proc))) + (= (process-exit-status proc) 0)) + (if (eq (current-buffer) proc-buf) + (let ((buf (and (boundp 'eshell-parent-buffer) + eshell-parent-buffer + (buffer-live-p eshell-parent-buffer) + eshell-parent-buffer))) + (if buf + (switch-to-buffer buf)))) + (kill-buffer proc-buf))))) + +;;;###autoload +(define-minor-mode eshell-vterm-mode + "Use Vterm for eshell visual commands." + :global t + :group 'eshell-vterm + (if eshell-vterm-mode + (advice-add #'eshell-exec-visual :override #'eshell-vterm-exec-visual) + (advice-remove #'eshell-exec-visual #'eshell-vterm-exec-visual))) + +(provide 'eshell-vterm) +;;; eshell-vterm.el ends here diff --git a/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm.elc b/emacs/elpa/eshell-vterm-20240305.1149/eshell-vterm.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-org.el b/emacs/elpa/gptel-20241112.624/gptel-org.el @@ -1,594 +0,0 @@ -;;; gptel-org.el --- Org functions for gptel -*- lexical-binding: t; -*- - -;; Copyright (C) 2024 Karthik Chikmagalur - -;; Author: Karthik Chikmagalur <karthikchikmagalur@gmail.com> -;; 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: - -;; - -;;; Code: -(eval-when-compile (require 'cl-lib)) -(require 'org-element) -(require 'outline) - -;; Functions used for saving/restoring gptel state in Org buffers -(defvar gptel--num-messages-to-send) -(defvar org-entry-property-inherited-from) -(defvar gptel-backend) -(defvar gptel--known-backends) -(defvar gptel--system-message) -(defvar gptel-model) -(defvar gptel-temperature) -(defvar gptel-max-tokens) - -(defvar org-link-angle-re) -(defvar org-link-bracket-re) -(declare-function mailcap-file-name-to-mime-type "mailcap") -(declare-function gptel--model-capable-p "gptel") -(declare-function gptel--model-mime-capable-p "gptel") -(declare-function gptel--model-name "gptel") -(declare-function gptel--to-string "gptel") -(declare-function gptel--to-number "gptel") -(declare-function gptel--intern "gptel") -(declare-function gptel--get-buffer-bounds "gptel") -(declare-function gptel-backend-name "gptel") -(declare-function gptel--parse-buffer "gptel") -(declare-function org-entry-get "org") -(declare-function org-entry-put "org") -(declare-function org-with-wide-buffer "org-macs") -(declare-function org-set-property "org") -(declare-function org-property-values "org") -(declare-function org-open-line "org") -(declare-function org-at-heading-p "org") -(declare-function org-get-heading "org") -(declare-function org-at-heading-p "org") - -;; Bundle `org-element-lineage-map' if it's not available (for Org 9.67 or older) -(eval-and-compile - (if (fboundp 'org-element-lineage-map) - (progn (declare-function org-element-lineage-map "org-element-ast") - (defalias 'gptel-org--element-lineage-map 'org-element-lineage-map)) - (defun gptel-org--element-lineage-map (datum fun &optional types with-self first-match) - "Map FUN across ancestors of DATUM, from closest to furthest. - -DATUM is an object or element. For TYPES, WITH-SELF and -FIRST-MATCH see `org-element-lineage-map'. - -This function is provided for compatibility with older versions -of Org." - (declare (indent 2)) - (setq fun (if (functionp fun) fun `(lambda (node) ,fun))) - (let ((up (if with-self datum (org-element-parent datum))) - acc rtn) - (catch :--first-match - (while up - (when (or (not types) (org-element-type-p up types)) - (setq rtn (funcall fun up)) - (if (and first-match rtn) - (throw :--first-match rtn) - (when rtn (push rtn acc)))) - (setq up (org-element-parent up))) - (nreverse acc))))) - (if (fboundp 'org-element-begin) - (progn (declare-function org-element-begin "org-element") - (defalias 'gptel-org--element-begin 'org-element-begin)) - (defun gptel-org--element-begin (node) - "Get `:begin' property of NODE." - (org-element-property :begin node)))) - - -;;; User options -(defcustom gptel-org-branching-context nil - "Use the lineage of the current heading as the context for gptel in Org buffers. - -This makes each same level heading a separate conversation -branch. - -By default, gptel uses a linear context: all the text up to the -cursor is sent to the LLM. Enabling this option makes the -context the hierarchical lineage of the current Org heading. In -this example: - ------ -Top level text - -* Heading 1 -heading 1 text - -* Heading 2 -heading 2 text - -** Heading 2.1 -heading 2.1 text -** Heading 2.2 -heading 2.2 text ------ - -With the cursor at the end of the buffer, the text sent to the -LLM will be limited to - ------ -Top level text - -* Heading 2 -heading 2 text - -** Heading 2.2 -heading 2.2 text ------ - -This makes it feasible to have multiple conversation branches." - :local t - :type 'boolean - :group 'gptel) - - -;;; Setting context and creating queries -(defun gptel-org--get-topic-start () - "If a conversation topic is set, return it." - (when (org-entry-get (point) "GPTEL_TOPIC" 'inherit) - (marker-position org-entry-property-inherited-from))) - -(defun gptel-org-set-topic (topic) - "Set a TOPIC and limit this conversation to the current heading. - -This limits the context sent to the LLM to the text between the -current heading and the cursor position." - (interactive - (list - (progn - (or (derived-mode-p 'org-mode) - (user-error "Support for multiple topics per buffer is only implemented for `org-mode'")) - (completing-read "Set topic as: " - (org-property-values "GPTEL_TOPIC") - nil nil (downcase - (truncate-string-to-width - (substring-no-properties - (replace-regexp-in-string - "\\s-+" "-" - (org-get-heading))) - 50)))))) - (when (stringp topic) (org-set-property "GPTEL_TOPIC" topic))) - -;; NOTE: This can be converted to a cl-defmethod for `gptel--parse-buffer' -;; (conceptually cleaner), but will cause load-order issues in gptel.el and -;; might be harder to debug. -(defun gptel-org--create-prompt (&optional prompt-end) - "Return a full conversation prompt from the contents of this Org buffer. - -If `gptel--num-messages-to-send' is set, limit to that many -recent exchanges. - -The prompt is constructed from the contents of the buffer up to -point, or PROMPT-END if provided. Its contents depend on the -value of `gptel-org-branching-context', which see." - (unless prompt-end (setq prompt-end (point))) - (let ((max-entries (and gptel--num-messages-to-send - (* 2 gptel--num-messages-to-send))) - (topic-start (gptel-org--get-topic-start))) - (when topic-start - ;; narrow to GPTEL_TOPIC property scope - (narrow-to-region topic-start prompt-end)) - (if gptel-org-branching-context - ;; Create prompt from direct ancestors of point - (if (fboundp 'org-element-lineage-map) - (save-excursion - (let* ((org-buf (current-buffer)) - (start-bounds (gptel-org--element-lineage-map - (org-element-at-point) #'gptel-org--element-begin - '(headline org-data) 'with-self)) - (end-bounds - (cl-loop - for pos in (cdr start-bounds) - while - (and (>= pos (point-min)) ;respect narrowing - (goto-char pos) - ;; org-element-lineage always returns an extra - ;; (org-data) element at point 1. If there is also a - ;; heading here, it is either a false positive or we - ;; would be double counting it. So we reject this node - ;; when also at a heading. - (not (and (eq pos 1) (org-at-heading-p)))) - do (outline-next-heading) - collect (point) into ends - finally return (cons prompt-end ends)))) - (with-temp-buffer - (setq-local gptel-backend (buffer-local-value 'gptel-backend org-buf) - gptel--system-message - (buffer-local-value 'gptel--system-message org-buf) - gptel-model (buffer-local-value 'gptel-model org-buf) - gptel-mode (buffer-local-value 'gptel-mode org-buf) - gptel-track-response - (buffer-local-value 'gptel-track-response org-buf) - gptel-track-media - (buffer-local-value 'gptel-track-media org-buf)) - (cl-loop for start in start-bounds - for end in end-bounds - do (insert-buffer-substring org-buf start end) - (goto-char (point-min))) - (goto-char (point-max)) - (let ((major-mode 'org-mode)) - (gptel--parse-buffer gptel-backend max-entries))))) - (display-warning - '(gptel org) - "Using `gptel-org-branching-context' requires Org version 9.6.7 or higher, it will be ignored.") - (gptel--parse-buffer gptel-backend max-entries)) - ;; Create prompt the usual way - (gptel--parse-buffer gptel-backend max-entries)))) - -;; Handle media links in the buffer -(cl-defmethod gptel--parse-media-links ((_mode (eql 'org-mode)) beg end) - "Parse text and actionable links between BEG and END. - -Return a list of the form - ((:text \"some text\") - (:media \"/path/to/media.png\" :mime \"image/png\") - (:text \"More text\")) -for inclusion into the user prompt for the gptel request." - (require 'mailcap) ;FIXME Avoid this somehow - (let ((parts) (from-pt) - (link-regex (concat "\\(?:" org-link-bracket-re "\\|" - org-link-angle-re "\\)"))) - (save-excursion - (setq from-pt (goto-char beg)) - (while (re-search-forward link-regex end t) - (when-let* ((link (org-element-context)) - ((gptel-org--link-standalone-p link)) - (raw-link (org-element-property :raw-link link)) - (path (org-element-property :path link)) - (type (org-element-property :type link)) - ;; FIXME This is not a good place to check for url capability! - ((member type `("attachment" "file" - ,@(and (gptel--model-capable-p 'url) - '("http" "https" "ftp"))))) - (mime (mailcap-file-name-to-mime-type path)) - ((gptel--model-mime-capable-p mime))) - (cond - ((member type '("file" "attachment")) - (when (file-readable-p path) - ;; Collect text up to this image, and - ;; Collect this image - (when-let ((text (string-trim (buffer-substring-no-properties - from-pt (gptel-org--element-begin link))))) - (unless (string-empty-p text) (push (list :text text) parts))) - (push (list :media path :mime mime) parts) - (setq from-pt (point)))) - ((member type '("http" "https" "ftp")) - ;; Collect text up to this image, and - ;; Collect this image url - (when-let ((text (string-trim (buffer-substring-no-properties - from-pt (gptel-org--element-begin link))))) - (unless (string-empty-p text) (push (list :text text) parts))) - (push (list :url raw-link :mime mime) parts) - (setq from-pt (point)))))) - (unless (= from-pt end) - (push (list :text (buffer-substring-no-properties from-pt end)) parts))) - (nreverse parts))) - -(defun gptel-org--link-standalone-p (object) - "Check if link OBJECT is on a line by itself." - ;; Specify ancestor TYPES as list (#245) - (let ((par (org-element-lineage object '(paragraph)))) - (and (= (gptel-org--element-begin object) - (save-excursion - (goto-char (org-element-property :contents-begin par)) - (skip-chars-forward "\t ") - (point))) ;account for leading space - ;before object - (<= (- (org-element-property :contents-end par) - (org-element-property :end object)) - 1)))) - -(defun gptel-org--send-with-props (send-fun &rest args) - "Conditionally modify SEND-FUN's calling environment. - -If in an Org buffer under a heading containing a stored gptel -configuration, use that for requests instead. This includes the -system message, model and provider (backend), among other -parameters. - -ARGS are the original function call arguments." - (if (derived-mode-p 'org-mode) - (pcase-let ((`(,gptel--system-message ,gptel-backend ,gptel-model - ,gptel-temperature ,gptel-max-tokens) - (seq-mapn (lambda (a b) (or a b)) - (gptel-org--entry-properties) - (list gptel--system-message gptel-backend gptel-model - gptel-temperature gptel-max-tokens)))) - (apply send-fun args)) - (apply send-fun args))) - -(advice-add 'gptel-send :around #'gptel-org--send-with-props) -(advice-add 'gptel--suffix-send :around #'gptel-org--send-with-props) - -;; ;; NOTE: Basic uses in org-mode are covered by advising gptel-send and -;; ;; gptel--suffix-send. For custom commands it might be necessary to advise -;; ;; gptel-request instead. -;; (advice-add 'gptel-request :around #'gptel-org--send-with-props) - - -;;; Saving and restoring state -(defun gptel-org--entry-properties (&optional pt) - "Find gptel configuration properties stored at PT." - (pcase-let - ((`(,system ,backend ,model ,temperature ,tokens ,num) - (mapcar - (lambda (prop) (org-entry-get (or pt (point)) prop 'selective)) - '("GPTEL_SYSTEM" "GPTEL_BACKEND" "GPTEL_MODEL" - "GPTEL_TEMPERATURE" "GPTEL_MAX_TOKENS" - "GPTEL_NUM_MESSAGES_TO_SEND")))) - (when system - (setq system (string-replace "\\n" "\n" system))) - (when backend - (setq backend (alist-get backend gptel--known-backends - nil nil #'equal))) - (when model (setq model (gptel--intern model))) - (when temperature - (setq temperature (gptel--to-number temperature))) - (when tokens (setq tokens (gptel--to-number tokens))) - (when num (setq num (gptel--to-number num))) - (list system backend model temperature tokens num))) - -(defun gptel-org--restore-state () - "Restore gptel state for Org buffers when turning on `gptel-mode'." - (save-restriction - (widen) - (condition-case status - (progn - (when-let ((bounds (org-entry-get (point-min) "GPTEL_BOUNDS"))) - (mapc (pcase-lambda (`(,beg . ,end)) - (put-text-property beg end 'gptel 'response)) - (read bounds))) - (pcase-let ((`(,system ,backend ,model ,temperature ,tokens ,num) - (gptel-org--entry-properties (point-min)))) - (when system (setq-local gptel--system-message system)) - (if backend (setq-local gptel-backend backend) - (message - (substitute-command-keys - (concat - "Could not activate gptel backend \"%s\"! " - "Switch backends with \\[universal-argument] \\[gptel-send]" - " before using gptel.")) - backend)) - (when model (setq-local gptel-model model)) - (when temperature (setq-local gptel-temperature temperature)) - (when tokens (setq-local gptel-max-tokens tokens)) - (when num (setq-local gptel--num-messages-to-send num)))) - (:success (message "gptel chat restored.")) - (error (message "Could not restore gptel state, sorry! Error: %s" status))))) - -(defun gptel-org-set-properties (pt &optional msg) - "Store the active gptel configuration under the current heading. - -The active gptel configuration includes the current system -message, language model and provider (backend), and additional -settings when applicable. - -PT is the cursor position by default. If MSG is -non-nil (default), display a message afterwards." - (interactive (list (point) t)) - (org-entry-put pt "GPTEL_MODEL" (gptel--model-name gptel-model)) - (org-entry-put pt "GPTEL_BACKEND" (gptel-backend-name gptel-backend)) - (unless (equal (default-value 'gptel-temperature) gptel-temperature) - (org-entry-put pt "GPTEL_TEMPERATURE" - (number-to-string gptel-temperature))) - (when (natnump gptel--num-messages-to-send) - (org-entry-put pt "GPTEL_NUM_MESSAGES_TO_SEND" - (number-to-string gptel--num-messages-to-send))) - (org-entry-put pt "GPTEL_SYSTEM" - (string-replace "\n" "\\n" gptel--system-message)) - (when gptel-max-tokens - (org-entry-put - pt "GPTEL_MAX_TOKENS" (number-to-string gptel-max-tokens))) - (when msg - (message "Added gptel configuration to current headline."))) - -(defun gptel-org--save-state () - "Write the gptel state to the Org buffer as Org properties." - (org-with-wide-buffer - (goto-char (point-min)) - (when (org-at-heading-p) - (org-open-line 1)) - (gptel-org-set-properties (point-min)) - ;; Save response boundaries - (letrec ((write-bounds - (lambda (attempts) - (let* ((bounds (gptel--get-buffer-bounds)) - (offset (caar bounds)) - (offset-marker (set-marker (make-marker) offset))) - (org-entry-put (point-min) "GPTEL_BOUNDS" - (prin1-to-string (gptel--get-buffer-bounds))) - (when (and (not (= (marker-position offset-marker) offset)) - (> attempts 0)) - (funcall write-bounds (1- attempts))))))) - (funcall write-bounds 6)))) - - -;;; Transforming responses -(defun gptel--convert-markdown->org (str) - "Convert string STR from markdown to org markup. - -This is a very basic converter that handles only a few markup -elements." - (interactive) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (while (re-search-forward "`+\\|\\*\\{1,2\\}\\|_\\|^#+" nil t) - (pcase (match-string 0) - ;; Handle backticks - ((and (guard (eq (char-before) ?`)) ticks) - (gptel--replace-source-marker (length ticks)) - (save-match-data - (catch 'block-end - (while (search-forward ticks nil t) - (unless (or (eq (char-before (match-beginning 0)) ?`) - (eq (char-after) ?`)) - (gptel--replace-source-marker (length ticks) 'end) - (throw 'block-end nil)))))) - ;; Handle headings - ((and (guard (eq (char-before) ?#)) heading) - (when (looking-at "[[:space:]]") - (delete-region (line-beginning-position) (point)) - (insert (make-string (length heading) ?*)))) - ;; Handle emphasis - ("**" (cond - ;; ((looking-at "\\*\\(?:[[:word:]]\\|\s\\)") - ;; (delete-char 1)) - ((looking-back "\\(?:[[:word:][:punct:]\n]\\|\s\\)\\*\\{2\\}" - (max (- (point) 3) (point-min))) - (delete-char -1)))) - ("*" - (cond - ((save-match-data - (and (looking-back "\\(?:[[:space:]]\\|\s\\)\\(?:_\\|\\*\\)" - (max (- (point) 2) (point-min))) - (not (looking-at "[[:space:]]\\|\s")))) - ;; Possible beginning of emphasis - (and - (save-excursion - (when (and (re-search-forward (regexp-quote (match-string 0)) - (line-end-position) t) - (looking-at "[[:space]]\\|\s") - (not (looking-back "\\(?:[[:space]]\\|\s\\)\\(?:_\\|\\*\\)" - (max (- (point) 2) (point-min))))) - (delete-char -1) (insert "/") t)) - (progn (delete-char -1) (insert "/")))) - ((save-excursion - (ignore-errors (backward-char 2)) - (looking-at "\\(?:$\\|\\`\\)\n\\*[[:space:]]")) - ;; Bullet point, replace with hyphen - (delete-char -1) (insert "-")))))) - (buffer-string))) - -(defun gptel--replace-source-marker (num-ticks &optional end) - "Replace markdown style backticks with Org equivalents. - -NUM-TICKS is the number of backticks being replaced. If END is -true these are \"ending\" backticks. - -This is intended for use in the markdown to org stream converter." - (let ((from (match-beginning 0))) - (delete-region from (point)) - (if (and (= num-ticks 3) - (save-excursion (beginning-of-line) - (skip-chars-forward " \t") - (eq (point) from))) - (insert (if end "#+end_src" "#+begin_src ")) - (insert "=")))) - -(defun gptel--stream-convert-markdown->org () - "Return a Markdown to Org converter. - -This function parses a stream of Markdown text to Org -continuously when it is called with successive chunks of the -text stream." - (letrec ((in-src-block nil) ;explicit nil to address BUG #183 - (temp-buf (generate-new-buffer-name "*gptel-temp*")) - (start-pt (make-marker)) - (ticks-total 0) - (cleanup-fn - (lambda (&rest _) - (when (buffer-live-p (get-buffer temp-buf)) - (set-marker start-pt nil) - (kill-buffer temp-buf)) - (remove-hook 'gptel-post-response-functions cleanup-fn)))) - (add-hook 'gptel-post-response-functions cleanup-fn) - (lambda (str) - (let ((noop-p) (ticks 0)) - (with-current-buffer (get-buffer-create temp-buf) - (save-excursion (goto-char (point-max)) (insert str)) - (when (marker-position start-pt) (goto-char start-pt)) - (when in-src-block (setq ticks ticks-total)) - (save-excursion - (while (re-search-forward "`\\|\\*\\{1,2\\}\\|_\\|^#+" nil t) - (pcase (match-string 0) - ("`" - ;; Count number of consecutive backticks - (backward-char) - (while (and (char-after) (eq (char-after) ?`)) - (forward-char) - (if in-src-block (cl-decf ticks) (cl-incf ticks))) - ;; Set the verbatim state of the parser - (if (and (eobp) - ;; Special case heuristic: If the response ends with - ;; ^``` we don't wait for more input. - ;; FIXME: This can have false positives. - (not (save-excursion (beginning-of-line) - (looking-at "^```$")))) - ;; End of input => there could be more backticks coming, - ;; so we wait for more input - (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) - ;; We reached a character other than a backtick - (cond - ;; Ticks balanced, end src block - ((= ticks 0) - (progn (setq in-src-block nil) - (gptel--replace-source-marker ticks-total 'end))) - ;; Positive number of ticks, start an src block - ((and (> ticks 0) (not in-src-block)) - (setq ticks-total ticks - in-src-block t) - (gptel--replace-source-marker ticks-total)) - ;; Negative number of ticks or in a src block already, - ;; reset ticks - (t (setq ticks ticks-total))))) - ;; Handle other chars: heading, emphasis, bold and bullet items - ((and (guard (and (not in-src-block) (eq (char-before) ?#))) heading) - (if (eobp) - ;; Not enough information about the heading yet - (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) - ;; Convert markdown heading to Org heading - (when (looking-at "[[:space:]]") - (delete-region (line-beginning-position) (point)) - (insert (make-string (length heading) ?*))))) - ((and "**" (guard (not in-src-block))) - (cond - ;; TODO Not sure why this branch was needed - ;; ((looking-at "\\*\\(?:[[:word:]]\\|\s\\)") (delete-char 1)) - - ;; Looking back at "w**" or " **" - ((looking-back "\\(?:[[:word:][:punct:]\n]\\|\s\\)\\*\\{2\\}" - (max (- (point) 3) (point-min))) - (delete-char -1)))) - ((and "*" (guard (not in-src-block))) - (if (eobp) - ;; Not enough information about the "*" yet - (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) - ;; "*" is either emphasis or a bullet point - (save-match-data - (save-excursion - (ignore-errors (backward-char 2)) - (cond - ((or (looking-at - "[^[:space:][:punct:]\n]\\(?:_\\|\\*\\)\\(?:[[:space:][:punct:]]\\|$\\)") - (looking-at - "\\(?:[[:space:][:punct:]]\\)\\(?:_\\|\\*\\)\\([^[:space:][:punct:]]\\|$\\)")) - ;; Emphasis, replace with slashes - (forward-char 2) (delete-char -1) (insert "/")) - ((looking-at "\\(?:$\\|\\`\\)\n\\*[[:space:]]") - ;; Bullet point, replace with hyphen - (forward-char 2) (delete-char -1) (insert "-")))))))))) - (if noop-p - (buffer-substring (point) start-pt) - (prog1 (buffer-substring (point) (point-max)) - (set-marker start-pt (point-max))))))))) - -(provide 'gptel-org) -;;; gptel-org.el ends here diff --git a/emacs/elpa/gptel-20241112.624/gptel-org.elc b/emacs/elpa/gptel-20241112.624/gptel-org.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-pkg.el b/emacs/elpa/gptel-20241112.624/gptel-pkg.el @@ -1,12 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "gptel" "20241112.624" - "Interact with ChatGPT or other LLMs." - '((emacs "27.1") - (transient "0.4.0") - (compat "29.1.4.1")) - :url "https://github.com/karthink/gptel" - :commit "4aa6b7ca79b1548c36e593d0d68d2dfa644fa958" - :revdesc "4aa6b7ca79b1" - :keywords '("convenience") - :authors '(("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) - :maintainers '(("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))) diff --git a/emacs/elpa/gptel-20241112.624/gptel-transient.el b/emacs/elpa/gptel-20241112.624/gptel-transient.el @@ -1,1054 +0,0 @@ -;;; gptel-transient.el --- Transient menu for GPTel -*- lexical-binding: t; -*- - -;; Copyright (C) 2023 Karthik Chikmagalur - -;; Author: Karthik Chikmagalur <karthikchikmagalur@gmail.com> -;; Keywords: convenience - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; 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: - -;; - -;;; Code: -(require 'cl-lib) -(require 'gptel) -(require 'transient) - -(declare-function ediff-regions-internal "ediff") -(declare-function ediff-make-cloned-buffer "ediff-utils") - - -;; * Helper functions and vars - -(defvar-local gptel--rewrite-overlays nil - "List of active rewrite overlays in the buffer.") - -(defvar gptel--set-buffer-locally nil - "Set model parameters from `gptel-menu' buffer-locally. - -Affects the system message too.") - -(defun gptel--set-with-scope (sym value &optional scope) - "Set SYMBOL's symbol-value to VALUE with SCOPE. - -If SCOPE is non-nil, set it buffer-locally, else clear any -buffer-local value and set its default global value." - (if scope - (set (make-local-variable sym) value) - (kill-local-variable sym) - (set sym value))) - -(defun gptel--get-directive (args) - "Find the additional directive in the transient ARGS. - -Meant to be called when `gptel-menu' is active." - (cl-some (lambda (s) (and (stringp s) (string-prefix-p ":" s) - (substring s 1))) - args)) - -(defun gptel--instructions-make-overlay (text &optional ov) - "Make or move overlay OV with TEXT." - (save-excursion - ;; Move point to overlay position - (cond - ((use-region-p) - (if (pos-visible-in-window-p (region-beginning)) - (goto-char (region-beginning)))) - ((gptel--in-response-p) - (gptel-beginning-of-response) - (skip-chars-forward "\n \t")) - (t (text-property-search-backward 'gptel 'response) - (skip-chars-forward "\n \t"))) - ;; Make overlay - (if (and ov (overlayp ov)) - (move-overlay ov (point) (point) (current-buffer)) - (setq ov (make-overlay (point) (point) nil t))) - (overlay-put ov 'before-string nil) - ;; (unless (or (bobp) (eq (char-before) "\n")) - ;; (overlay-put ov 'before-string (propertize "\n" 'font-lock-face 'shadow))) - (overlay-put ov 'category 'gptel) - (overlay-put - ov 'after-string - (concat (propertize (concat "DIRECTIVE: " text) - 'font-lock-face '(:inherit shadow :weight bold :box t)) - "\n")) - ov)) - -(defun gptel--transient-read-variable (prompt initial-input history) - "Read value from minibuffer and interpret the result as a Lisp object. - -PROMPT, INITIAL-INPUT and HISTORY are as in the Transient reader -documention." - (ignore-errors - (read-from-minibuffer prompt initial-input read-expression-map t history))) - -(defsubst gptel--refactor-or-rewrite () - "Rewrite should be refactored into refactor. - -Or is it the other way around?" - (if (derived-mode-p 'prog-mode) - "Refactor" "Rewrite")) - -(defun gptel--format-system-message (&optional message) - "Format the system MESSAGE for display in gptel's transient menus." - (setq message (or message gptel--system-message)) - (if (gptel--model-capable-p 'nosystem) - (concat (propertize "[No system message support for model " - 'face 'transient-heading) - (propertize (gptel--model-name gptel-model) - 'face 'warning) - (propertize "]" 'face 'transient-heading)) - (if message - (cl-etypecase message - (string (string-replace - "\n" "⮐ " - (truncate-string-to-width - message - (max (- (window-width) 12) 14) nil nil t))) - (function (gptel--format-system-message (funcall message))) - (list (gptel--format-system-message (car message)))) - "[No system message set]"))) - -(defvar gptel--crowdsourced-prompts-url - "https://raw.githubusercontent.com/f/awesome-chatgpt-prompts/main/prompts.csv" - "URL for crowdsourced LLM system prompts.") - -(defvar gptel--crowdsourced-prompts - (make-hash-table :test #'equal) - "Crowdsourced LLM system prompts.") - -(defun gptel--crowdsourced-prompts () - "Acquire and read crowdsourced LLM system prompts. - -These are stored in the variable `gptel--crowdsourced-prompts', -which see." - (when (hash-table-p gptel--crowdsourced-prompts) - (when (hash-table-empty-p gptel--crowdsourced-prompts) - (unless gptel-crowdsourced-prompts-file - (run-at-time 0 nil #'gptel-system-prompt) - (user-error "No crowdsourced prompts available")) - (unless (and (file-exists-p gptel-crowdsourced-prompts-file) - (time-less-p - (time-subtract (current-time) (days-to-time 14)) - (file-attribute-modification-time - (file-attributes gptel-crowdsourced-prompts-file)))) - (when (y-or-n-p - (concat - "Fetch crowdsourced system prompts from " - (propertize "https://github.com/f/awesome-chatgpt-prompts" 'face 'link) - "?")) - ;; Fetch file - (message "Fetching prompts...") - (let ((dir (file-name-directory gptel-crowdsourced-prompts-file))) - (unless (file-exists-p dir) (mkdir dir 'create-parents)) - (if (url-copy-file gptel--crowdsourced-prompts-url - gptel-crowdsourced-prompts-file - 'ok-if-already-exists) - (message "Fetching prompts... done.") - (message "Could not retrieve new prompts."))))) - (if (not (file-readable-p gptel-crowdsourced-prompts-file)) - (progn (message "No crowdsourced prompts available") - (call-interactively #'gptel-system-prompt)) - (with-temp-buffer - (insert-file-contents gptel-crowdsourced-prompts-file) - (goto-char (point-min)) - (forward-line 1) - (while (not (eobp)) - (when-let ((act (read (current-buffer)))) - (forward-char) - (save-excursion - (while (re-search-forward "\"\"" (line-end-position) t) - (replace-match "\\\\\""))) - (when-let ((prompt (read (current-buffer)))) - (puthash act prompt gptel--crowdsourced-prompts))) - (forward-line 1))))) - gptel--crowdsourced-prompts)) - - -;; * Transient classes and methods for gptel - -(defclass gptel-lisp-variable (transient-lisp-variable) - ((display-nil :initarg :display-nil) ;String to display if value if nil - (display-map :initarg :display-map :initform nil)) ;Display string from alist display-map - "Lisp variables that show :display-nil instead of nil.") - -(cl-defmethod transient-format-value ((obj gptel-lisp-variable)) - (let ((display-value - (with-slots (value display-nil display-map) obj - (cond ((null value) display-nil) - (display-map (cdr (assoc value display-map))) - (t value))))) - (propertize - (if (stringp display-value) display-value (prin1-to-string display-value)) - 'face 'transient-value))) - -(cl-defmethod transient-infix-set ((obj gptel-lisp-variable) value) - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value value) - gptel--set-buffer-locally)) - -(defclass gptel--switches (gptel-lisp-variable) - ((display-if-true :initarg :display-if-true :initform "True") - (display-if-false :initarg :display-if-false :initform "False")) - "Boolean lisp variable class for gptel-transient.") - -(cl-defmethod transient-infix-read ((obj gptel--switches)) - "Cycle through the mutually exclusive switches." - (not (oref obj value))) - -(cl-defmethod transient-format-value ((obj gptel--switches)) - (with-slots (value display-if-true display-if-false) obj - (format - (propertize "(%s)" 'face 'transient-delimiter) - (concat - (propertize display-if-false - 'face (if value 'transient-inactive-value 'transient-value)) - (propertize "|" 'face 'transient-delimiter) - (propertize display-if-true - 'face (if value 'transient-value 'transient-inactive-value)))))) - -(defclass gptel--scope (gptel--switches) - ((display-if-true :initarg :display-if-true :initform "for this buffer") - (display-if-false :initarg :display-if-false :initform "globally")) - "Singleton lisp variable class for `gptel--set-buffer-locally'. - -This is used only for setting this variable via `gptel-menu'.") - -(cl-defmethod transient-infix-set ((obj gptel--scope) value) - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value value))) - -(defclass gptel-provider-variable (transient-lisp-variable) - ((model :initarg :model) - (model-value :initarg :model-value) - (always-read :initform t) - (set-value :initarg :set-value :initform #'set)) - "Class used for gptel-backends.") - -(cl-defmethod transient-format-value ((obj gptel-provider-variable)) - (propertize (concat - (gptel-backend-name (oref obj value)) ":" - (gptel--model-name - (buffer-local-value (oref obj model) transient--original-buffer))) - 'face 'transient-value)) - -(cl-defmethod transient-infix-set ((obj gptel-provider-variable) value) - (pcase-let ((`(,backend-value ,model-value) value)) - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value backend-value) - gptel--set-buffer-locally) - (funcall (oref obj set-value) - (oref obj model) - (oset obj model-value model-value) - gptel--set-buffer-locally)) - (transient-setup)) - -(defclass gptel-option-overlaid (transient-option) - ((display-nil :initarg :display-nil) - (overlay :initarg :overlay)) - "Transient options for overlays displayed in the working buffer.") - -(cl-defmethod transient-format-value ((obj gptel-option-overlaid)) - "set up the in-buffer overlay for additional directive, a string. - -Also format its value in the Transient menu." - (let ((value (oref obj value)) - (ov (oref obj overlay)) - (argument (oref obj argument))) - ;; Making an overlay - (if (or (not value) (string-empty-p value)) - (when ov (delete-overlay ov)) - (with-current-buffer transient--original-buffer - (oset obj overlay (gptel--instructions-make-overlay value ov))) - (letrec ((ov-clear-hook - (lambda () (when-let* ((ov (oref obj overlay)) - ((overlayp ov))) - (remove-hook 'transient-exit-hook - ov-clear-hook) - (delete-overlay ov))))) - (add-hook 'transient-exit-hook ov-clear-hook))) - ;; Updating transient menu display - (if value - (propertize (concat argument (truncate-string-to-width value 25 nil nil "...")) - 'face 'transient-value) - (propertize - (concat "(" (symbol-name (oref obj display-nil)) ")") - 'face 'transient-inactive-value)))) - - -;; * Transient Prefixes - -(define-obsolete-function-alias 'gptel-send-menu 'gptel-menu "0.3.2") - -;; BUG: The `:incompatible' spec doesn't work if there's a `:description' below it. -;;;###autoload (autoload 'gptel-menu "gptel-transient" nil t) -(transient-define-prefix gptel-menu () - "Change parameters of prompt to send to the LLM." - ;; :incompatible '(("-m" "-n" "-k" "-e")) - [:description gptel--format-system-message - ["" - :if (lambda () (not (gptel--model-capable-p 'nosystem))) - "Instructions" - ("s" "Set system message" gptel-system-prompt :transient t) - (gptel--infix-add-directive)] - [:pad-keys t - "" - "Context" - (gptel--infix-context-add-region) - (gptel--infix-context-add-buffer) - (gptel--infix-context-add-file) - (gptel--suffix-context-buffer)]] - [["Request Parameters" - :pad-keys t - (gptel--infix-variable-scope) - (gptel--infix-provider) - (gptel--infix-max-tokens) - (gptel--infix-num-messages-to-send - :if (lambda () (or gptel-mode gptel-track-response))) - (gptel--infix-temperature :if (lambda () gptel-expert-commands)) - (gptel--infix-use-context) - (gptel--infix-track-response - :if (lambda () (and gptel-expert-commands (not gptel-mode)))) - (gptel--infix-track-media - :if (lambda () (and gptel-mode (gptel--model-capable-p 'media))))] - ["Prompt from" - ("m" "Minibuffer instead" "m") - ("y" "Kill-ring instead" "y") - "" - ("i" "Respond in place" "i")] - ["Response to" - ("e" "Echo area instead" "e") - ("g" "gptel session" "g" - :class transient-option - :prompt "Existing or new gptel session: " - :reader - (lambda (prompt _ _history) - (read-buffer - prompt (generate-new-buffer-name - (concat "*" (gptel-backend-name gptel-backend) "*")) - nil (lambda (buf-name) - (if (consp buf-name) (setq buf-name (car buf-name))) - (let ((buf (get-buffer buf-name))) - (and (buffer-local-value 'gptel-mode buf) - (not (eq (current-buffer) buf)))))))) - ("b" "Any buffer" "b" - :class transient-option - :prompt "Output to buffer: " - :reader - (lambda (prompt _ _history) - (read-buffer prompt (buffer-name (other-buffer)) nil))) - ("k" "Kill-ring" "k")]] - [["Send" - (gptel--suffix-send) - ("M-RET" "Regenerate" gptel--regenerate :if gptel--in-response-p)] - [:description (lambda () - (concat - (and gptel--rewrite-overlays "Continue ") - (gptel--refactor-or-rewrite))) - :if (lambda () (or gptel--rewrite-overlays (use-region-p))) - ("r" - ;;FIXME: Transient complains if I use `gptel--refactor-or-rewrite' here. It - ;;reads this function as a suffix instead of a function that returns the - ;;description. - (lambda () (if (derived-mode-p 'prog-mode) - "Refactor" "Rewrite")) - gptel-rewrite-menu)] - ["Tweak Response" :if gptel--in-response-p :pad-keys t - ("SPC" "Mark" gptel--mark-response) - ("P" "Previous variant" gptel--previous-variant - :if gptel--at-response-history-p - :transient t) - ("N" "Next variant" gptel--previous-variant - :if gptel--at-response-history-p - :transient t) - ("E" "Ediff previous" gptel--ediff - :if gptel--at-response-history-p)] - ["Dry Run" :if (lambda () (or gptel-log-level gptel-expert-commands)) - ("I" "Inspect query (Lisp)" - (lambda () - "Inspect the query that will be sent as a lisp object." - (interactive) - (gptel--sanitize-model) - (gptel--inspect-query - (gptel--suffix-send - (cons "I" (transient-args transient-current-command)))))) - ("J" "Inspect query (JSON)" - (lambda () - "Inspect the query that will be sent as a JSON object." - (interactive) - (gptel--sanitize-model) - (gptel--inspect-query - (gptel--suffix-send - (cons "I" (transient-args transient-current-command))) - 'json)))]] - (interactive) - (gptel--sanitize-model) - (transient-setup 'gptel-menu)) - -;; ** Prefix for setting the system prompt. -(defun gptel-system-prompt--setup (_) - "Set up suffixes for system prompt." - (transient-parse-suffixes - 'gptel-system-prompt - (cl-loop for (type . prompt) in gptel-directives - ;; Avoid clashes with the custom directive key - with unused-keys = (delete ?s (number-sequence ?a ?z)) - with width = (window-width) - for name = (symbol-name type) - for key = (seq-find (lambda (k) (member k unused-keys)) name (seq-first unused-keys)) - do (setq unused-keys (delete key unused-keys)) - ;; The explicit declaration ":transient transient--do-return" here - ;; appears to be required for Transient v0.5 and up. Without it, these - ;; are treated as suffixes when invoking `gptel-system-prompt' directly, - ;; and infixes when going through `gptel-menu'. - ;; TODO: Raise an issue with Transient. - collect (list (key-description (list key)) - (concat (capitalize name) " " - (propertize " " 'display '(space :align-to 20)) - (propertize - (concat - "(" - (string-replace - "\n" " " - (truncate-string-to-width prompt (- width 30) nil nil t)) - ")") - 'face 'shadow)) - `(lambda () (interactive) - (message "Directive: %s" - ,(string-replace "\n" "⮐ " - (truncate-string-to-width prompt 100 nil nil t))) - (gptel--set-with-scope 'gptel--system-message ,prompt - gptel--set-buffer-locally)) - :transient 'transient--do-return) - into prompt-suffixes - finally return - (nconc - prompt-suffixes - (list (list "DEL" "None" - (lambda () (interactive) - (message "Directive unset") - (gptel--set-with-scope 'gptel--system-message nil - gptel--set-buffer-locally)) - :transient 'transient--do-return) - (list "SPC" "Pick crowdsourced prompt" - 'gptel--read-crowdsourced-prompt - ;; NOTE: Quitting the completing read when picking a - ;; crowdsourced prompt will cause the transient to exit - ;; instead of returning to the system prompt menu. - :transient 'transient--do-exit)))))) - -;;;###autoload (autoload 'gptel-system-prompt "gptel-transient" nil t) -(transient-define-prefix gptel-system-prompt () - "Set the LLM system message for LLM interactions in this buffer. - -The \"system message\" establishes directives for the chat -session and modifies the behavior of the LLM. Some examples of -system prompts are: - -You are a helpful assistant. Answer as concisely as possible. -Reply only with shell commands and no prose. -You are a poet. Reply only in verse. - -More extensive system messages can be useful for specific tasks. - -Customize `gptel-directives' for task-specific prompts." - [:description gptel--format-system-message - [(gptel--suffix-system-message)] - [(gptel--infix-variable-scope)]] - [:class transient-column - :setup-children gptel-system-prompt--setup - :pad-keys t]) - - -;; * Transient Infixes - -;; ** Infixes for context aggregation - -(transient-define-infix gptel--infix-use-context () - "Describe target destination for context injection. - -gptel will include with the LLM request any additional context -added with `gptel-add'. This context can be ignored, included -with the system message or included with the user prompt. - -Where in the request this context is included depends on the -value of `gptel-use-context', set from here." - :description "Include context" - :class 'gptel-lisp-variable - :variable 'gptel-use-context - :format " %k %d %v" - :set-value #'gptel--set-with-scope - :display-nil "No" - :display-map '((nil . "No") - (system . "with system message") - (user . "with user prompt")) - :key "-i" - :reader (lambda (prompt &rest _) - (let* ((choices '(("No" . nil) - ("with system message" . system) - ("with user prompt" . user))) - (destination (completing-read prompt choices nil t))) - (cdr (assoc destination choices))))) - -;; ** Infixes for model parameters - -(transient-define-infix gptel--infix-variable-scope () - "Set gptel's model parameters and system message in this buffer or globally." - :argument "scope" - :variable 'gptel--set-buffer-locally - :class 'gptel--scope - :format " %k %d %v" - :key "=" - :description (propertize "Set" 'face 'transient-inactive-argument)) - -(transient-define-infix gptel--infix-num-messages-to-send () - "Number of recent messages to send with each exchange. - -By default, the full conversation history is sent with every new -prompt. This retains the full context of the conversation, but -can be expensive in token size. Set how many recent messages to -include." - :description "previous responses" - :class 'gptel-lisp-variable - :variable 'gptel--num-messages-to-send - :set-value #'gptel--set-with-scope - :display-nil 'all - :format " %k %v %d" - :key "-n" - :prompt "Number of past messages to include for context (leave empty for all): " - :reader 'gptel--transient-read-variable) - -(transient-define-infix gptel--infix-max-tokens () - "Max tokens per response. - -This is roughly the number of words in the response. 100-300 is a -reasonable range for short answers, 400 or more for longer -responses." - :description "Response length (tokens)" - :class 'gptel-lisp-variable - :variable 'gptel-max-tokens - :set-value #'gptel--set-with-scope - :display-nil 'auto - :key "-c" - :prompt "Response length in tokens (leave empty: default, 80-200: short, 200-500: long): " - :reader 'gptel--transient-read-variable) - -(transient-define-infix gptel--infix-provider () - "AI Provider for Chat." - :description "GPT Model" - :class 'gptel-provider-variable - :prompt "Model: " - :variable 'gptel-backend - :set-value #'gptel--set-with-scope - :model 'gptel-model - :key "-m" - :reader (lambda (prompt &rest _) - (cl-loop - for (name . backend) in gptel--known-backends - nconc (cl-loop for model in (gptel-backend-models backend) - collect (list (concat name ":" (gptel--model-name model)) - backend model)) - into models-alist - with completion-extra-properties = - `(:annotation-function - ,(lambda (comp) - (let* ((model (nth 2 (assoc comp models-alist))) - (desc (get model :description)) - (caps (get model :capabilities)) - (context (get model :context-window)) - (input-cost (get model :input-cost)) - (output-cost (get model :output-cost)) - (cutoff (get model :cutoff-date))) - (when (or desc caps context input-cost output-cost cutoff) - (concat - (propertize " " 'display `(space :align-to 40)) - (when desc (truncate-string-to-width desc 70 nil ? t t)) - " " (propertize " " 'display `(space :align-to 112)) - (when caps (truncate-string-to-width (prin1-to-string caps) 21 nil ? t t)) - " " (propertize " " 'display `(space :align-to 134)) - (when context (format "%5dk" context)) - " " (propertize " " 'display `(space :align-to 142)) - (when input-cost (format "$%5.2f in" input-cost)) - (if (and input-cost output-cost) "," " ") - " " (propertize " " 'display `(space :align-to 153)) - (when output-cost (format "$%6.2f out" output-cost)) - " " (propertize " " 'display `(space :align-to 166)) - cutoff))))) - finally return - (cdr (assoc (completing-read prompt models-alist nil t) - models-alist))))) - -(transient-define-infix gptel--infix-temperature () - "Temperature of request." - :description "Temperature (0 - 2.0)" - :class 'gptel-lisp-variable - :variable 'gptel-temperature - :set-value #'gptel--set-with-scope - :key "-t" - :prompt "Temperature controls the response randomness (0.0-2.0, leave empty for default): " - :reader 'gptel--transient-read-variable) - -(transient-define-infix gptel--infix-track-response () - "Distinguish between user messages and LLM responses. - -When creating a prompt to send to the LLM, gptel distinguishes -between text entered by the user and past LLM responses. This is -required for multi-turn conversations, and is always the case in -dedicated chat buffers (in `gptel-mode'). - -In regular buffers, you can toggle this behavior here or by -customizing `gptel-track-response'. When response tracking is -turned off, all text will be assigned the \"user\" role when -querying the LLM." - :description "Track LLM responses" - :class 'gptel--switches - :variable 'gptel-track-response - :set-value #'gptel--set-with-scope - :display-if-true "Yes" - :display-if-false "No" - :key "-d") - -(transient-define-infix gptel--infix-track-media () - "Send media from \"standalone\" links in the prompt. - -When the active `gptel-model' supports it, gptel can send images -or other media from links in the buffer to the LLM. Only -\"standalone\" links are considered: these are links on their own -line with no surrounding text. - -What link types are sent depends on the mime-types the model -supports. See `gptel-track-media' for more information." - :description "Send media from links" - :class 'gptel--switches - :variable 'gptel-track-media - :set-value #'gptel--set-with-scope - :display-if-true "Yes" - :display-if-false "No" - :key "-I") - -;; ** Infixes for adding and removing context - -(declare-function gptel-context--at-point "gptel-context") -(declare-function gptel-add "gptel-context") - -(transient-define-suffix gptel--infix-context-add-region () - "Add current region to gptel's context." - :transient 'transient--do-stay - :key "-r" - :if (lambda () (or (use-region-p) - (and (fboundp 'gptel-context--at-point) - (gptel-context--at-point)))) - :description - (lambda () - (if (and (fboundp 'gptel-context--at-point) - (gptel-context--at-point)) - "Remove context at point" - "Add region to context")) - (interactive) - (gptel-add) - (transient-setup)) - -(transient-define-suffix gptel--infix-context-add-buffer () - "Add a buffer to gptel's context." - :transient 'transient--do-stay - :key "-b" - :description "Add a buffer to context" - (interactive) - (gptel-add '(4)) - (transient-setup)) - -(declare-function gptel-add-file "gptel-context") - -(transient-define-suffix gptel--infix-context-add-file () - "Add a file to gptel's context." - :transient 'transient--do-stay - :key "-f" - :description "Add a file to context" - (interactive) - (call-interactively #'gptel-add-file) - (transient-setup)) - -;; ** Infix for the refactor/rewrite system message - -(transient-define-infix gptel--infix-add-directive () - "Additional directive intended for the next query only. - -This is useful to define a quick task on top of a more extensive -or detailed system message. - -For example, with code/text selected: - -- Rewrite this function to do X while avoiding Y. -- Change the tone of the following paragraph to be more direct. - -Or in an extended conversation: - -- Phrase you next response in ten words or less. -- Pretend for now that you're an anthropologist." - :class 'gptel-option-overlaid - ;; :variable 'gptel--instructions - :display-nil 'none - :overlay nil - :argument ":" - :prompt "Instructions for next response only: " - :reader (lambda (prompt initial history) - (let* ((extra (read-string prompt initial history))) - (unless (string-empty-p extra) extra))) - :format " %k %d %v" - :key "d" - :argument ":" - :description "Add directive" - :transient t) - - -;; * Transient Suffixes - -;; ** Suffix to send prompt - -(transient-define-suffix gptel--suffix-send (args) - "Send ARGS." - :key "RET" - :description "Send prompt" - (interactive (list (transient-args - (or transient-current-command 'gptel-menu)))) - (let ((stream gptel-stream) - (in-place (and (member "i" args) t)) - (output-to-other-buffer-p) - (backend gptel-backend) - (model gptel-model) - (backend-name (gptel-backend-name gptel-backend)) - (buffer) (position) - (callback) (gptel-buffer-name) - (system-extra (gptel--get-directive args)) - (dry-run (and (member "I" args) t)) - ;; Input redirection: grab prompt from elsewhere? - (prompt - (cond - ((member "m" args) - (read-string - (format "Ask %s: " (gptel-backend-name gptel-backend)) - (and (use-region-p) - (buffer-substring-no-properties - (region-beginning) (region-end))))) - ((member "y" args) - (unless (car-safe kill-ring) - (user-error "`kill-ring' is empty! Nothing to send")) - (if current-prefix-arg - (read-from-kill-ring "Prompt from kill-ring: ") - (current-kill 0)))))) - - ;; Output redirection: Send response elsewhere? - (cond - ((member "e" args) - (setq stream nil) - (setq callback - (lambda (resp info) - (if resp - (message "%s response: %s" backend-name resp) - (message "%s response error: %s" backend-name (plist-get info :status)))))) - ((member "k" args) - (setq stream nil) - (setq callback - (lambda (resp info) - (if (not resp) - (message "%s response error: %s" backend-name (plist-get info :status)) - (kill-new resp) - (message "%s response: \"%s\" copied to kill-ring." - backend-name - (truncate-string-to-width resp 30)))))) - ((setq gptel-buffer-name - (cl-some (lambda (s) (and (stringp s) (string-prefix-p "g" s) - (substring s 1))) - args)) - (setq output-to-other-buffer-p t) - (let ((reduced-prompt ;For inserting into the gptel buffer as - ;context, not the prompt used for the - ;request itself - (or prompt - (if (use-region-p) - (buffer-substring-no-properties (region-beginning) - (region-end)) - (buffer-substring-no-properties - (save-excursion - (text-property-search-backward - 'gptel 'response - (when (get-char-property (max (point-min) (1- (point))) - 'gptel) - t)) - (point)) - (gptel--at-word-end (point))))))) - (cond - ((buffer-live-p (get-buffer gptel-buffer-name)) - ;; Insert into existing gptel session - (progn - (setq buffer (get-buffer gptel-buffer-name)) - (with-current-buffer buffer - (goto-char (point-max)) - (unless (or buffer-read-only - (get-char-property (point) 'read-only)) - (insert reduced-prompt)) - (setq position (point)) - (when gptel-mode - (gptel--update-status " Waiting..." 'warning))))) - ;; Insert into new gptel session - (t (setq buffer - (gptel gptel-buffer-name - (condition-case nil - (gptel--get-api-key) - ((error user-error) - (setq gptel-api-key - (read-passwd - (format "%s API key: " - (gptel-backend-name - gptel-backend)))))) - reduced-prompt)) - ;; Set backend and model in new session from current buffer - (with-current-buffer buffer - (setq gptel-backend backend) - (setq gptel-model model) - (gptel--update-status " Waiting..." 'warning) - (setq position (point))))))) - ((setq gptel-buffer-name - (cl-some (lambda (s) (and (stringp s) (string-prefix-p "b" s) - (substring s 1))) - args)) - (setq output-to-other-buffer-p t) - (setq buffer (get-buffer-create gptel-buffer-name)) - (with-current-buffer buffer (setq position (point))))) - - (prog1 (gptel-request prompt - :buffer (or buffer (current-buffer)) - :position position - :in-place (and in-place (not output-to-other-buffer-p)) - :stream stream - :system (if system-extra - (concat (if gptel--system-message - (concat gptel--system-message "\n\n")) - system-extra) - gptel--system-message) - :callback callback - :dry-run dry-run) - - (gptel--update-status " Waiting..." 'warning) - - ;; NOTE: Possible future race condition here if Emacs ever drops the GIL. - ;; The HTTP request callback might modify the buffer before the in-place - ;; text is killed below. - (when in-place - ;; Kill the latest prompt - (let ((beg - (if (use-region-p) - (region-beginning) - (save-excursion - (text-property-search-backward - 'gptel 'response - (when (get-char-property (max (point-min) (1- (point))) - 'gptel) - t)) - (point)))) - (end (if (use-region-p) (region-end) (point)))) - (unless output-to-other-buffer-p - ;; store the killed text in gptel-history - (gptel--attach-response-history - (list (buffer-substring-no-properties beg end)))) - (kill-region beg end))) - - (when output-to-other-buffer-p - (message (concat "Prompt sent to buffer: " - (propertize gptel-buffer-name 'face 'help-key-binding))) - (display-buffer - buffer '((display-buffer-reuse-window - display-buffer-pop-up-window) - (reusable-frames . visible))))))) - -;; Allow calling from elisp -(put 'gptel--suffix-send 'interactive-only nil) - -;; ** Suffix to regenerate response - -(defun gptel--regenerate () - "Regenerate gptel response at point." - (interactive) - (when (gptel--in-response-p) - (pcase-let* ((`(,beg . ,end) (gptel--get-bounds)) - (history (get-char-property (point) 'gptel-history)) - (prev-responses (cons (buffer-substring-no-properties beg end) - history))) - (when gptel-mode ;Remove prefix/suffix - (save-excursion - (goto-char beg) - (when (looking-back (concat "\n+" (regexp-quote (gptel-response-prefix-string))) - (point-min) 'greedy) - (setq beg (match-beginning 0))) - (goto-char end) - (when (looking-at - (concat "\n+" (regexp-quote (gptel-prompt-prefix-string)))) - (setq end (match-end 0))))) - (delete-region beg end) - (gptel--attach-response-history prev-responses) - (call-interactively #'gptel--suffix-send)))) - -;; ** Set system message -(defun gptel--read-crowdsourced-prompt () - "Pick a crowdsourced system prompt for gptel. - -This uses the prompts in the variable -`gptel--crowdsourced-prompts', which see." - (interactive) - (if (not (hash-table-empty-p (gptel--crowdsourced-prompts))) - (let ((choice - (completing-read - "Pick and edit prompt: " - (lambda (str pred action) - (if (eq action 'metadata) - `(metadata - (affixation-function . - (lambda (cands) - (mapcar - (lambda (c) - (list c "" - (concat (propertize " " 'display '(space :align-to 22)) - " " (propertize (gethash c gptel--crowdsourced-prompts) - 'face 'completions-annotations)))) - cands)))) - (complete-with-action action gptel--crowdsourced-prompts str pred))) - nil t))) - (when-let ((prompt (gethash choice gptel--crowdsourced-prompts))) - (setq gptel--system-message prompt) - (call-interactively #'gptel--suffix-system-message))) - (message "No prompts available."))) - -(transient-define-suffix gptel--suffix-system-message () - "Edit LLM system message. - -When LOCAL is non-nil, set the system message only in the current buffer." - :transient 'transient--do-exit - :description "Set or edit system message" - :format " %k %d" - :key "s" - (interactive) - (let ((orig-buf (current-buffer)) - (msg-start (make-marker))) - (with-current-buffer (get-buffer-create "*gptel-system*") - (let ((inhibit-read-only t)) - (erase-buffer) - (text-mode) - (setq header-line-format - (concat - "Edit your system message below and press " - (propertize "C-c C-c" 'face 'help-key-binding) - " when ready, or " - (propertize "C-c C-k" 'face 'help-key-binding) - " to abort.")) - (insert - "# Example: You are a helpful assistant. Answer as concisely as possible.\n" - "# Example: Reply only with shell commands and no prose.\n" - "# Example: You are a poet. Reply only in verse.\n\n") - (add-text-properties - (point-min) (1- (point)) - (list 'read-only t 'face 'font-lock-comment-face)) - ;; TODO: make-separator-line requires Emacs 28.1+. - ;; (insert (propertize (make-separator-line) 'rear-nonsticky t)) - (set-marker msg-start (point)) - (save-excursion - (insert (or (buffer-local-value 'gptel--system-message orig-buf) "")) - (push-mark nil 'nomsg)) - (activate-mark)) - (display-buffer (current-buffer) - `((display-buffer-below-selected) - (body-function . ,#'select-window) - (window-height . ,#'fit-window-to-buffer))) - (let ((quit-to-menu - (lambda () - "Cancel system message update and return to `gptel-menu'" - (interactive) - (quit-window) - (display-buffer - orig-buf - `((display-buffer-reuse-window - display-buffer-use-some-window) - (body-function . ,#'select-window))) - (call-interactively #'gptel-menu)))) - (use-local-map - (make-composed-keymap - (define-keymap - "C-c C-c" (lambda () - "Confirm system message and return to `gptel-menu'." - (interactive) - (let ((system-message - (buffer-substring msg-start (point-max)))) - (with-current-buffer orig-buf - (gptel--set-with-scope 'gptel--system-message system-message - gptel--set-buffer-locally))) - (funcall quit-to-menu)) - "C-c C-k" quit-to-menu) - text-mode-map)))))) - -;; ** Suffix for displaying and removing context -(declare-function gptel-context--buffer-setup "gptel-context") -(declare-function gptel-context--collect "gptel-context") - -(transient-define-suffix gptel--suffix-context-buffer () - "Display all contexts from all buffers & files." - :transient 'transient--do-exit - :key " C" - :if (lambda () gptel-context--alist) - :description - (lambda () - (pcase-let* - ((contexts (and gptel-context--alist (gptel-context--collect))) - (buffer-count (length contexts)) - (`(,file-count ,ov-count) - (if (> buffer-count 0) - (cl-loop for (buf-file . ovs) in contexts - if (bufferp buf-file) - sum (length ovs) into ov-count - else count (stringp buf-file) into file-count - finally return (list file-count ov-count)) - (list 0 0)))) - (concat "Inspect " - (format - (propertize "(%s)" 'face 'transient-delimiter) - (propertize - (concat - (and (> ov-count 0) - (format "%d region%s in %d buffer%s" - ov-count (if (> ov-count 1) "s" "") - (- buffer-count file-count) - (if (> ( - buffer-count file-count) 1) "s" ""))) - (and (> file-count 0) - (propertize - (format "%s%d file%s" - (if (> ov-count 0) ", " "") file-count - (if (> file-count 1) "s" ""))))) - 'face (if (zerop (length contexts)) - 'transient-inactive-value - 'transient-value)))))) - (interactive) - (gptel-context--buffer-setup)) - -(provide 'gptel-transient) -;;; gptel-transient.el ends here - -;; Local Variables: -;; outline-regexp: "^;; \\*+" -;; eval: (outline-minor-mode 1) -;; End: diff --git a/emacs/elpa/gptel-20241112.624/gptel-transient.elc b/emacs/elpa/gptel-20241112.624/gptel-transient.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel.el b/emacs/elpa/gptel-20241112.624/gptel.el @@ -1,1888 +0,0 @@ -;;; gptel.el --- Interact with ChatGPT or other LLMs -*- lexical-binding: t; -*- - -;; Copyright (C) 2023 Karthik Chikmagalur - -;; Author: Karthik Chikmagalur <karthik.chikmagalur@gmail.com> -;; Package-Version: 20241112.624 -;; Package-Revision: 4aa6b7ca79b1 -;; Package-Requires: ((emacs "27.1") (transient "0.4.0") (compat "29.1.4.1")) -;; Keywords: convenience -;; URL: https://github.com/karthink/gptel - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; 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/>. - -;; This file is NOT part of GNU Emacs. - -;;; Commentary: - -;; gptel is a simple Large Language Model chat client, with support for multiple -;; models and backends. -;; -;; It works in the spirit of Emacs, available at any time and in any buffer. -;; -;; gptel supports -;; -;; - The services ChatGPT, Azure, Gemini, Anthropic AI, Anyscale, Together.ai, -;; Perplexity, Anyscale, OpenRouter, Groq, PrivateGPT, DeepSeek, Cerebras, -;; Github Models and Kagi (FastGPT & Summarizer) -;; - Local models via Ollama, Llama.cpp, Llamafiles or GPT4All -;; -;; Additionally, any LLM service (local or remote) that provides an -;; OpenAI-compatible API is supported. -;; -;; Features: -;; - It’s async and fast, streams responses. -;; - Interact with LLMs from anywhere in Emacs (any buffer, shell, minibuffer, -;; wherever) -;; - LLM responses are in Markdown or Org markup. -;; - Supports conversations and multiple independent sessions. -;; - Supports multi-modal models (send images, documents). -;; - Save chats as regular Markdown/Org/Text files and resume them later. -;; - You can go back and edit your previous prompts or LLM responses when -;; continuing a conversation. These will be fed back to the model. -;; - Redirect prompts and responses easily -;; - Rewrite, refactor or fill in regions in buffers -;; - Write your own commands for custom tasks with a simple API. -;; -;; Requirements for ChatGPT, Azure, Gemini or Kagi: -;; -;; - You need an appropriate API key. Set the variable `gptel-api-key' to the -;; key or to a function of no arguments that returns the key. (It tries to -;; use `auth-source' by default) -;; -;; ChatGPT is configured out of the box. For the other sources: -;; -;; - For Azure: define a gptel-backend with `gptel-make-azure', which see. -;; - For Gemini: define a gptel-backend with `gptel-make-gemini', which see. -;; - For Anthropic (Claude): define a gptel-backend with `gptel-make-anthropic', -;; which see -;; - For Together.ai, Anyscale, Perplexity, Groq, OpenRouter, DeepSeek, Cerebras or -;; Github Models: define a gptel-backend with `gptel-make-openai', which see. -;; - For PrivateGPT: define a backend with `gptel-make-privategpt', which see. -;; - For Kagi: define a gptel-backend with `gptel-make-kagi', which see. -;; -;; For local models using Ollama, Llama.cpp or GPT4All: -;; -;; - The model has to be running on an accessible address (or localhost) -;; - Define a gptel-backend with `gptel-make-ollama' or `gptel-make-gpt4all', -;; which see. -;; - Llama.cpp or Llamafiles: Define a gptel-backend with `gptel-make-openai', -;; -;; Consult the package README for examples and more help with configuring -;; backends. -;; -;; Usage: -;; -;; gptel can be used in any buffer or in a dedicated chat buffer. The -;; interaction model is simple: Type in a query and the response will be -;; inserted below. You can continue the conversation by typing below the -;; response. -;; -;; To use this in any buffer: -;; -;; - Call `gptel-send' to send the buffer's text up to the cursor. Select a -;; region to send only the region. -;; -;; - You can select previous prompts and responses to continue the conversation. -;; -;; - Call `gptel-send' with a prefix argument to access a menu where you can set -;; your backend, model and other parameters, or to redirect the -;; prompt/response. -;; -;; To use this in a dedicated buffer: -;; -;; - M-x gptel: Start a chat session -;; -;; - In the chat session: Press `C-c RET' (`gptel-send') to send your prompt. -;; Use a prefix argument (`C-u C-c RET') to access a menu. In this menu you -;; can set chat parameters like the system directives, active backend or -;; model, or choose to redirect the input or output elsewhere (such as to the -;; kill ring). -;; -;; - You can save this buffer to a file. When opening this file, turn on -;; `gptel-mode' before editing it to restore the conversation state and -;; continue chatting. -;; -;; - To include media files with your request, you can add them to the context -;; (described next), or include them as links in Org or Markdown mode chat -;; buffers. Sending media is disabled by default, you can turn it on globally -;; via `gptel-track-media', or locally in a chat buffer via the header line. -;; -;; Include more context with requests: -;; -;; If you want to provide the LLM with more context, you can add arbitrary -;; regions, buffers or files to the query with `gptel-add'. To add text or -;; media files, call `gptel-add' in Dired or use the dedicated `gptel-add-file'. -;; -;; You can also add context from gptel's menu instead (gptel-send with a prefix -;; arg), as well as examine or modify context. -;; -;; When context is available, gptel will include it with each LLM query. -;; -;; Rewrite/refactor interface -;; -;; In any buffer: with a region selected, you can rewrite prose, refactor code -;; or fill in the region. Use gptel's menu (C-u M-x `gptel-send') to access -;; this feature. -;; -;; gptel in Org mode: -;; -;; gptel offers a few extra conveniences in Org mode. -;; - You can limit the conversation context to an Org heading with -;; `gptel-org-set-topic'. -;; -;; - You can have branching conversations in Org mode, where each hierarchical -;; outline path through the document is a separate conversation branch. -;; See the variable `gptel-org-branching-context'. -;; -;; - You can declare the gptel model, backend, temperature, system message and -;; other parameters as Org properties with the command -;; `gptel-org-set-properties'. gptel queries under the corresponding heading -;; will always use these settings, allowing you to create mostly reproducible -;; LLM chat notebooks. -;; -;; Finally, gptel offers a general purpose API for writing LLM ineractions -;; that suit your workflow, see `gptel-request'. - -;;; Code: -(declare-function markdown-mode "markdown-mode") -(declare-function gptel-curl-get-response "gptel-curl") -(declare-function gptel-menu "gptel-transient") -(declare-function gptel-system-prompt "gptel-transient") -(declare-function pulse-momentary-highlight-region "pulse") - -(declare-function ediff-make-cloned-buffer "ediff-util") -(declare-function ediff-regions-internal "ediff") - -(declare-function gptel-org--create-prompt "gptel-org") -(declare-function gptel-org-set-topic "gptel-org") -(declare-function gptel-org--save-state "gptel-org") -(declare-function gptel-org--restore-state "gptel-org") -(declare-function gptel--stream-convert-markdown->org "gptel-org") -(declare-function gptel--convert-markdown->org "gptel-org") -(define-obsolete-function-alias - 'gptel-set-topic 'gptel-org-set-topic "0.7.5") - -(eval-when-compile - (require 'subr-x) - (require 'cl-lib)) -(require 'compat nil t) -(require 'url) -(require 'map) -(require 'text-property-search) -(require 'cl-generic) -(require 'gptel-openai) - -(with-eval-after-load 'org - (require 'gptel-org)) - - -;;; User options - -(defgroup gptel nil - "Interact with LLMs from anywhere in Emacs." - :group 'hypermedia) - -;; (defcustom gptel-host "api.openai.com" -;; "The API host queried by gptel." -;; :group 'gptel -;; :type 'string) -(make-obsolete-variable - 'gptel-host - "Use `gptel-make-openai' instead." - "0.5.0") - -(defcustom gptel-proxy "" - "Path to a proxy to use for gptel interactions. -Passed to curl via --proxy arg, for example \"proxy.yourorg.com:80\" -Leave it empty if you don't use a proxy." - :type 'string) - -(defcustom gptel-api-key #'gptel-api-key-from-auth-source - "An API key (string) for the default LLM backend. - -OpenAI by default. - -Can also be a function of no arguments that returns an API -key (more secure) for the active backend." - :type '(choice - (string :tag "API key") - (function :tag "Function that returns the API key"))) - -(defcustom gptel-stream t - "Stream responses from the LLM as they are received. - -This option is ignored unless -- the LLM backend supports streaming, and -- Curl is in use (see `gptel-use-curl') - -When set to nil, Emacs waits for the full response and inserts it -all at once. This wait is asynchronous. - -\='tis a bit silly." - :type 'boolean) -(make-obsolete-variable 'gptel-playback 'gptel-stream "0.3.0") - -(defcustom gptel-use-curl (and (executable-find "curl") t) - "Whether gptel should prefer Curl when available." - :type 'boolean) - -(defcustom gptel-curl-file-size-threshold 130000 - "Size threshold for using file input with Curl. - -Specifies the size threshold for when to use a temporary file to pass data to -Curl in GPTel queries. If the size of the data to be sent exceeds this -threshold, the data is written to a temporary file and passed to Curl using the -`--data-binary' option with a file reference. Otherwise, the data is passed -directly as a command-line argument. - -The value is an integer representing the number of bytes. - -Adjusting this value may be necessary depending on the environment -and the typical size of the data being sent in GPTel queries. -A larger value may improve performance by avoiding the overhead of creating -temporary files for small data payloads, while a smaller value may be needed -if the command-line argument size is limited by the operating system." - :type 'natnum) - -(defcustom gptel-response-filter-functions - (list #'gptel--convert-org) - "Abnormal hook for transforming the response from an LLM. - -This is used to format the response in some way, such as filling -paragraphs, adding annotations or recording information in the -response like links. - -Each function in this hook receives two arguments, the response -string to transform and the LLM interaction buffer. It -should return the transformed string. - -NOTE: This is only used for non-streaming responses. To -transform streaming responses, use `gptel-post-stream-hook' and -`gptel-post-response-functions'." - :type 'hook) - -(defcustom gptel-pre-response-hook nil - "Hook run before inserting the LLM response into the current buffer. - -This hook is called in the buffer where the LLM response will be -inserted. - -Note: this hook only runs if the request succeeds." - :type 'hook) - -(define-obsolete-variable-alias - 'gptel-post-response-hook 'gptel-post-response-functions - "0.6.0" - "Post-response functions are now called with two arguments: the -start and end buffer positions of the response.") - -(defcustom gptel-post-response-functions nil - "Abnormal hook run after inserting the LLM response into the current buffer. - -This hook is called in the buffer to which the LLM response is -sent, and after the full response has been inserted. Each -function is called with two arguments: the response beginning and -end positions. - -Note: this hook runs even if the request fails. In this case the -response beginning and end positions are both the cursor position -at the time of the request." - :type 'hook) - -;; (defcustom gptel-pre-stream-insert-hook nil -;; "Hook run before each insertion of the LLM's streaming response. - -;; This hook is called in the buffer from which the prompt was sent -;; to the LLM, immediately before text insertion." -;; :group 'gptel -;; :type 'hook) - -(defcustom gptel-post-stream-hook nil - "Hook run after each insertion of the LLM's streaming response. - -This hook is called in the buffer from which the prompt was sent -to the LLM, and after a text insertion." - :type 'hook) - -(defcustom gptel-save-state-hook nil - "Hook run before gptel saves model parameters to a file. - -You can use this hook to store additional conversation state or -model parameters to the chat buffer, or to modify the buffer in -some other way." - :type 'hook) - -(defcustom gptel-default-mode (if (fboundp 'markdown-mode) - 'markdown-mode - 'text-mode) - "The default major mode for dedicated chat buffers. - -If `markdown-mode' is available, it is used. Otherwise gptel -defaults to `text-mode'." - :type 'function) - -;; TODO: Handle `prog-mode' using the `comment-start' variable -(defcustom gptel-prompt-prefix-alist - '((markdown-mode . "### ") - (org-mode . "*** ") - (text-mode . "### ")) - "String used as a prefix to the query being sent to the LLM. - -This is meant for the user to distinguish between queries and -responses, and is removed from the query before it is sent. - -This is an alist mapping major modes to the prefix strings. This -is only inserted in dedicated gptel buffers." - :type '(alist :key-type symbol :value-type string)) - -(defcustom gptel-response-prefix-alist - '((markdown-mode . "") - (org-mode . "") - (text-mode . "")) - "String inserted before the response from the LLM. - -This is meant for the user to distinguish between queries and -responses. - -This is an alist mapping major modes to the reply prefix strings. This -is only inserted in dedicated gptel buffers before the AI's response." - :type '(alist :key-type symbol :value-type string)) - -(defcustom gptel-use-header-line t - "Whether `gptel-mode' should use header-line for status information. - -When set to nil, use the mode line for (minimal) status -information and the echo area for messages." - :type 'boolean) - -(defcustom gptel-display-buffer-action '(pop-to-buffer) - "The action used to display gptel chat buffers. - -The gptel buffer is displayed in a window using - - (display-buffer BUFFER gptel-display-buffer-action) - -The value of this option has the form (FUNCTION . ALIST), -where FUNCTION is a function or a list of functions. Each such -function should accept two arguments: a buffer to display and an -alist of the same form as ALIST. See info node `(elisp)Choosing -Window' for details." - :type display-buffer--action-custom-type) - -(defcustom gptel-crowdsourced-prompts-file - (let ((cache-dir (or (eval-when-compile - (require 'xdg) - (xdg-cache-home)) - user-emacs-directory))) - (expand-file-name "gptel-crowdsourced-prompts.csv" cache-dir)) - "File used to store crowdsourced system prompts. - -These are prompts cached from an online source (see -`gptel--crowdsourced-prompts-url'), and can be set from the -transient menu interface provided by `gptel-menu'." - :type 'file) - -;; Model and interaction parameters -(defcustom gptel-directives - '((default . "You are a large language model living in Emacs and a helpful assistant. Respond concisely.") - (programming . "You are a large language model and a careful programmer. Provide code and only code as output without any additional text, prompt or note.") - (writing . "You are a large language model and a writing assistant. Respond concisely.") - (chat . "You are a large language model and a conversation partner. Respond concisely.")) - "System prompts (directives) for the LLM. - -These are system instructions sent at the beginning of each -request to the LLM. - -Each entry in this alist maps a symbol naming the directive to -the string that is sent. To set the directive for a chat session -interactively call `gptel-send' with a prefix argument." - :safe #'always - :type '(alist :key-type symbol :value-type string)) - -(defvar gptel--system-message (alist-get 'default gptel-directives) - "The system message used by gptel.") -(put 'gptel--system-message 'safe-local-variable #'always) - -(defcustom gptel-max-tokens nil - "Max tokens per response. - -This is roughly the number of words in the response. 100-300 is a -reasonable range for short answers, 400 or more for longer -responses. - -To set the target token count for a chat session interactively -call `gptel-send' with a prefix argument." - :safe #'always - :type '(choice (natnum :tag "Specify Token count") - (const :tag "Default" nil))) - -(defcustom gptel-model 'gpt-4o-mini - "GPT Model for chat. - -The name of the model, as a symbol. This is the name as expected -by the LLM provider's API. - -The current options for ChatGPT are -- `gpt-3.5-turbo' -- `gpt-3.5-turbo-16k' -- `gpt-4o-mini' -- `gpt-4' -- `gpt-4o' -- `gpt-4-turbo' -- `gpt-4-turbo-preview' -- `gpt-4-32k' -- `gpt-4-1106-preview' - -To set the model for a chat session interactively call -`gptel-send' with a prefix argument." - :safe #'always - :type '(choice - (symbol :tag "Specify model name") - (const :tag "GPT 4 omni mini" gpt-4o-mini) - (const :tag "GPT 3.5 turbo" gpt-3.5-turbo) - (const :tag "GPT 3.5 turbo 16k" gpt-3.5-turbo-16k) - (const :tag "GPT 4" gpt-4) - (const :tag "GPT 4 omni" gpt-4o) - (const :tag "GPT 4 turbo" gpt-4-turbo) - (const :tag "GPT 4 turbo (preview)" gpt-4-turbo-preview) - (const :tag "GPT 4 32k" gpt-4-32k) - (const :tag "GPT 4 1106 (preview)" gpt-4-1106-preview))) - -(defcustom gptel-temperature 1.0 - "\"Temperature\" of the LLM response. - -This is a number between 0.0 and 2.0 that controls the randomness -of the response, with 2.0 being the most random. - -To set the temperature for a chat session interactively call -`gptel-send' with a prefix argument." - :safe #'always - :type 'number) - -(defvar gptel--known-backends) - -(defconst gptel--openai-models - '((gpt-4o - :description "Advanced model for complex tasks; cheaper & faster than GPT-Turbo" - :capabilities (media tool json url) - :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") - :context-window 128 - :input-cost 2.50 - :output-cost 10 - :cutoff-date "2023-10") - (gpt-4o-mini - :description "Cheap model for fast tasks; cheaper & more capable than GPT-3.5 Turbo" - :capabilities (media tool json url) - :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") - :context-window 128 - :input-cost 0.15 - :output-cost 0.60 - :cutoff-date "2023-10") - (gpt-4-turbo - :description "Previous high-intelligence model" - :capabilities (media tool url) - :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") - :context-window 128 - :input-cost 10 - :output-cost 30 - :cutoff-date "2023-12") - ;; points to gpt-4-0613 - (gpt-4 - :description "GPT-4 snapshot from June 2023 with improved function calling support" - :context-window 8.192 - :input-cost 30 - :output-cost 60 - :cutoff-date "2023-09") - (gpt-4-turbo-preview - :description "Points to gpt-4-0125-preview" - :context-window 128 - :input-cost 10 - :output-cost 30 - :cutoff-date "2023-12") - (gpt-4-0125-preview - :description "GPT-4 Turbo preview model intended to reduce cases of “laziness”" - :context-window 128 - :input-cost 10 - :output-cost 30 - :cutoff-date "2023-12") - (o1-preview - :description "Reasoning model designed to solve hard problems across domains" - :context-window 128 - :input-cost 15 - :output-cost 60 - :cutoff-date "2023-10" - :capabilities (nosystem) - :request-params (:stream :json-false)) - (o1-mini - :description "Faster and cheaper reasoning model good at coding, math, and science" - :context-window 128 - :input-cost 3 - :output-cost 12 - :cutoff-date "2023-10" - :capabilities (nosystem) - :request-params (:stream :json-false)) - ;; limited information available - (gpt-4-32k - :input-cost 60 - :output-cost 120) - (gpt-4-1106-preview - :description "Preview model with improved function calling support" - :context-window 128 - :input-cost 10 - :output-cost 30 - :cutoff-date "2023-04") - (gpt-3.5-turbo - :description "More expensive & less capable than GPT-4o-mini; use that instead" - :capabilities (tool) - :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") - :context-window 16.358 - :input-cost 0.50 - :output-cost 1.50 - :cutoff-date "2021-09") - (gpt-3.5-turbo-16k - :description "More expensive & less capable than GPT-4o-mini; use that instead" - :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") - :context-window 16.385 - :input-cost 3 - :output-cost 4 - :cutoff-date "2021-09")) - "List of available OpenAI models and associated properties. -Keys: - -- `:description': a brief description of the model. - -- `:capabilities': a list of capabilities supported by the model. - -- `:mime-types': a list of supported MIME types for media files. - -- `:context-window': the context window size, in thousands of tokens. - -- `:input-cost': the input cost, in US dollars per million tokens. - -- `:output-cost': the output cost, in US dollars per million tokens. - -- `:cutoff-date': the knowledge cutoff date. - -- `:request-params': a plist of additional request parameters to - include when using this model. - -Information about the OpenAI models was obtained from the following -sources: - -- <https://openai.com/pricing> -- <https://platform.openai.com/docs/models>") - -(defvar gptel--openai - (gptel-make-openai - "ChatGPT" - :key 'gptel-api-key - :stream t - :models gptel--openai-models)) - -(defcustom gptel-backend gptel--openai - "LLM backend to use. - -This is the default \"backend\", an object of type -`gptel-backend' containing connection, authentication and model -information. - -A backend for ChatGPT is pre-defined by gptel. Backends for -other LLM providers (local or remote) may be constructed using -one of the available backend creation functions: -- `gptel-make-openai' -- `gptel-make-azure' -- `gptel-make-ollama' -- `gptel-make-gpt4all' -- `gptel-make-gemini' -See their documentation for more information and the package -README for examples." - :safe #'always - :type `(choice - (const :tag "ChatGPT" ,gptel--openai) - (restricted-sexp :match-alternatives (gptel-backend-p 'nil) - :tag "Other backend"))) - -(defvar gptel-expert-commands nil - "Whether experimental gptel options should be enabled. - -This opens up advanced options in `gptel-menu'.") - -(defvar-local gptel--bounds nil) -(put 'gptel--bounds 'safe-local-variable #'always) - -(defvar gptel--num-messages-to-send nil) -(put 'gptel--num-messages-to-send 'safe-local-variable #'always) - -(defcustom gptel-log-level nil - "Logging level for gptel. - -This is one of nil or the symbols info and debug: - -nil: Don't log responses -info: Log request and response bodies -debug: Log request/response bodies, headers and all other - connection settings. - -When non-nil, information is logged to `gptel--log-buffer-name', -which see." - :type '(choice - (const :tag "No logging" nil) - (const :tag "Limited" info) - (const :tag "Full" debug))) -(make-obsolete-variable - 'gptel--debug 'gptel-log-level "0.6.5") - -(defcustom gptel-track-response t - "Distinguish between user messages and LLM responses. - -When creating a prompt to send to the LLM, gptel distinguishes -between text entered by the user and past LLM responses. This -distinction is necessary for back-and-forth conversation with an -LLM. - -In regular Emacs buffers you can turn this behavior off by -setting `gptel-track-response' to nil. All text, including -past LLM responses, is then treated as user input when sending -queries. - -This variable has no effect in dedicated chat buffers (buffers -with `gptel-mode' enabled), where user prompts and responses are -always handled separately." - :type 'boolean) - -(defcustom gptel-track-media nil - "Whether supported media in chat buffers should be sent. - -When the active `gptel-model' supports it, gptel can send images -or other media from links in chat buffers to the LLM. To use -this, the following steps are required. - -1. `gptel-track-media' (this variable) should be non-nil - -2. The LLM should provide vision or document support. Currently, -only the OpenAI, Anthropic and Ollama APIs are supported. See -the documentation of `gptel-make-openai', `gptel-make-anthropic' -and `gptel-make-ollama' resp. for details on how to specify media -support for models. - -3. Only \"standalone\" links in chat buffers are considered. -These are links on their own line with no surrounding text. -Further: - -- In Org mode, only files or URLs of the form - [[/path/to/media][bracket links]] and <angle/link/path> - are sent. - -- In Markdown mode, only files or URLS of the form - [bracket link](/path/to/media) and <angle/link/path> - are sent. - -This option has no effect in non-chat buffers. To include -media (including images) more generally, use `gptel-add'." - :type 'boolean) - -(defcustom gptel-use-context 'system - "Where in the request to inject gptel's additional context. - -gptel always includes the active region or the buffer up to the -cursor in the request to the LLM. Additionally, you can add -other buffers or their regions to the context with -`gptel-add-context', or from gptel's menu. This data will be -sent with every request. - -This option controls whether and where this additional context is -included in the request. - -Currently supported options are: - - nil - Do not use the context. - system - Include the context with the system message. - user - Include the context with the user prompt." - :group 'gptel - :type '(choice - (const :tag "Don't include context" nil) - (const :tag "With system message" system) - (const :tag "With user prompt" user))) - -(defvar-local gptel--old-header-line nil) - -(defvar gptel-context--alist nil - "List of gptel's context sources. - -Each entry is of the form - (buffer . (overlay1 overlay2 ...)) -or - (\"path/to/file\").") - - -;;; Utility functions - -(defun gptel-api-key-from-auth-source (&optional host user) - "Lookup api key in the auth source. -By default, the LLM host for the active backend is used as HOST, -and \"apikey\" as USER." - (if-let ((secret - (plist-get - (car (auth-source-search - :host (or host (gptel-backend-host gptel-backend)) - :user (or user "apikey") - :require '(:secret))) - :secret))) - (if (functionp secret) - (encode-coding-string (funcall secret) 'utf-8) - secret) - (user-error "No `gptel-api-key' found in the auth source"))) - -;; FIXME Should we utf-8 encode the api-key here? -(defun gptel--get-api-key (&optional key) - "Get api key from KEY, or from `gptel-api-key'." - (when-let ((key-sym (or key (gptel-backend-key gptel-backend)))) - (cl-typecase key-sym - (function (funcall key-sym)) - (string key-sym) - (symbol (if-let ((val (symbol-value key-sym))) - (gptel--get-api-key - (symbol-value key-sym)) - (error "`gptel-api-key' is not valid"))) - (t (error "`gptel-api-key' is not valid"))))) - -(defsubst gptel--to-number (val) - "Ensure VAL is a number." - (cond - ((numberp val) val) - ((stringp val) (string-to-number val)) - ((error "%S cannot be converted to a number" val)))) - -(defsubst gptel--to-string (s) - "Convert S to a string, if possible." - (cl-etypecase s - (symbol (symbol-name s)) - (string s) - (number (number-to-string s)))) - -(defsubst gptel--intern (s) - "Intern S, if possible." - (cl-etypecase s - (symbol s) - (string (intern s)))) - -(defun gptel--merge-plists (&rest plists) - "Merge PLISTS, altering the first one. - -Later plists in the sequence take precedence over earlier ones." - (let (;; (rtn (copy-sequence (pop plists))) - (rtn (pop plists)) - p v ls) - (while plists - (setq ls (pop plists)) - (while ls - (setq p (pop ls) v (pop ls)) - (setq rtn (plist-put rtn p v)))) - rtn)) -(defun gptel-auto-scroll () - "Scroll window if LLM response continues below viewport. - -Note: This will move the cursor." - (when-let ((win (get-buffer-window (current-buffer) 'visible)) - ((not (pos-visible-in-window-p (point) win))) - (scroll-error-top-bottom t)) - (condition-case nil - (with-selected-window win - (scroll-up-command)) - (error nil)))) - -(defun gptel-beginning-of-response (&optional _ _ arg) - "Move point to the beginning of the LLM response ARG times." - (interactive "p") - ;; FIXME: Only works for arg == 1 - (gptel-end-of-response nil nil (- (or arg 1)))) - -(defun gptel-end-of-response (&optional _ _ arg) - "Move point to the end of the LLM response ARG times." - (interactive (list nil nil - (prefix-numeric-value current-prefix-arg))) - (unless arg (setq arg 1)) - (let ((search (if (> arg 0) - #'text-property-search-forward - #'text-property-search-backward))) - (dotimes (_ (abs arg)) - (funcall search 'gptel 'response t) - (if (> arg 0) - (when (looking-at (concat "\n\\{1,2\\}" - (regexp-quote - (gptel-prompt-prefix-string)) - "?")) - (goto-char (match-end 0))) - (when (looking-back (concat (regexp-quote - (gptel-response-prefix-string)) - "?") - (point-min)) - (goto-char (match-beginning 0))))))) - -(defmacro gptel--at-word-end (&rest body) - "Execute BODY at end of the current word or punctuation." - `(save-excursion - (skip-syntax-forward "w.") - ,(macroexp-progn body))) - -(defun gptel-prompt-prefix-string () - "Prefix before user prompts in `gptel-mode'." - (or (alist-get major-mode gptel-prompt-prefix-alist) "")) - -(defun gptel-response-prefix-string () - "Prefix before LLM responses in `gptel-mode'." - (or (alist-get major-mode gptel-response-prefix-alist) "")) - -(defsubst gptel--trim-prefixes (s) - "Remove prompt/response prefixes from string S." - (string-trim s - (format "[\t\r\n ]*\\(?:%s\\)?[\t\r\n ]*" - (regexp-quote (gptel-prompt-prefix-string))) - (format "[\t\r\n ]*\\(?:%s\\)?[\t\r\n ]*" - (regexp-quote (gptel-response-prefix-string))))) - -(defsubst gptel--link-standalone-p (beg end) - "Return non-nil if positions BEG and END are isolated. - -This means the extent from BEG to END is the only non-whitespace -content on this line." - (save-excursion - (and (= beg (progn (goto-char beg) (beginning-of-line) - (skip-chars-forward "\t ") - (point))) - (= end (progn (goto-char end) (end-of-line) - (skip-chars-backward "\t ") - (point)))))) - -(defvar-local gptel--backend-name nil - "Store to persist backend name across Emacs sessions. - -Note: Changing this variable does not affect gptel\\='s behavior -in any way.") -(put 'gptel--backend-name 'safe-local-variable #'always) - -;;;; Model interface -;; NOTE: This interface would be simpler to implement as a defstruct. But then -;; users cannot set `gptel-model' to a symbol/string directly, or we'd need -;; another map from these symbols to the actual model structs. - -(defsubst gptel--model-name (model) - "Get name of gptel MODEL." - (gptel--to-string model)) - -(defsubst gptel--model-capabilities (model) - "Get MODEL capabilities." - (get model :capabilities)) - -(defsubst gptel--model-mimes (model) - "Get supported mime-types for MODEL." - (get model :mime-types)) - -(defsubst gptel--model-capable-p (cap &optional model) - "Return non-nil if MODEL supports capability CAP." - (memq cap (gptel--model-capabilities - (or model gptel-model)))) - -;; TODO Handle model mime specifications like "image/*" -(defsubst gptel--model-mime-capable-p (mime &optional model) - "Return non nil if MODEL can understand MIME type." - (car-safe (member mime (gptel--model-mimes - (or model gptel-model))))) - -(defsubst gptel--model-request-params (model) - "Get model-specific request parameters for MODEL." - (get model :request-params)) - -;;;; File handling -(defun gptel--base64-encode (file) - "Encode FILE as a base64 string. - -FILE is assumed to exist and be a regular file." - (with-temp-buffer - (insert-file-contents-literally file) - (base64-encode-region (point-min) (point-max) - :no-line-break) - (buffer-string))) - -;;;; Response text recognition - -(defun gptel--get-buffer-bounds () - "Return the gptel response boundaries in the buffer as an alist." - (save-excursion - (save-restriction - (widen) - (goto-char (point-max)) - (let ((prop) (bounds)) - (while (setq prop (text-property-search-backward - 'gptel 'response t)) - (push (cons (prop-match-beginning prop) - (prop-match-end prop)) - bounds)) - bounds)))) - -(defun gptel--get-bounds () - "Return the gptel response boundaries around point." - (let (prop) - (save-excursion - (when (text-property-search-backward - 'gptel 'response t) - (when (setq prop (text-property-search-forward - 'gptel 'response t)) - (cons (prop-match-beginning prop) - (prop-match-end prop))))))) - -(defun gptel--in-response-p (&optional pt) - "Check if position PT is inside a gptel response." - (get-char-property (or pt (point)) 'gptel)) - -(defun gptel--at-response-history-p (&optional pt) - "Check if gptel response at position PT has variants." - (get-char-property (or pt (point)) 'gptel-history)) - -(defvar gptel--mode-description-alist - '((js2-mode . "Javascript") - (sh-mode . "Shell") - (enh-ruby-mode . "Ruby") - (yaml-mode . "Yaml") - (yaml-ts-mode . "Yaml") - (rustic-mode . "Rust")) - "Mapping from unconventionally named major modes to languages. - -This is used when generating system prompts for rewriting and -when including context from these major modes.") - -(defun gptel--strip-mode-suffix (mode-sym) - "Remove the -mode suffix from MODE-SYM. - -MODE-SYM is typically a major-mode symbol." - (or (alist-get mode-sym gptel--mode-description-alist) - (let ((mode-name (thread-last - (symbol-name mode-sym) - (string-remove-suffix "-mode") - (string-remove-suffix "-ts")))) - (if (provided-mode-derived-p - mode-sym 'prog-mode 'text-mode 'tex-mode) - mode-name "")))) - - -;;; Logging - -(defconst gptel--log-buffer-name "*gptel-log*" - "Log buffer for gptel.") - -(declare-function json-pretty-print "json") - -(defun gptel--log (data &optional type no-json) - "Log DATA to `gptel--log-buffer-name'. - -TYPE is a label for data being logged. DATA is assumed to be -Valid JSON unless NO-JSON is t." - (with-current-buffer (get-buffer-create gptel--log-buffer-name) - (let ((p (goto-char (point-max)))) - (unless (bobp) (insert "\n")) - (insert (format "{\"gptel\": \"%s\", " (or type "none")) - (format-time-string "\"timestamp\": \"%Y-%m-%d %H:%M:%S\"}\n") - data) - (unless no-json (ignore-errors (json-pretty-print p (point))))))) - - -;;; Saving and restoring state - -(defun gptel--restore-state () - "Restore gptel state when turning on `gptel-mode'." - (when (buffer-file-name) - (if (derived-mode-p 'org-mode) - (progn - (require 'gptel-org) - (gptel-org--restore-state)) - (when gptel--bounds - (mapc (pcase-lambda (`(,beg . ,end)) - (put-text-property beg end 'gptel 'response)) - gptel--bounds) - (message "gptel chat restored.")) - (when gptel--backend-name - (if-let ((backend (alist-get - gptel--backend-name gptel--known-backends - nil nil #'equal))) - (setq-local gptel-backend backend) - (message - (substitute-command-keys - (concat - "Could not activate gptel backend \"%s\"! " - "Switch backends with \\[universal-argument] \\[gptel-send]" - " before using gptel.")) - gptel--backend-name)))))) - -(defun gptel--save-state () - "Write the gptel state to the buffer. - -This saves chat metadata when writing the buffer to disk. To -restore a chat session, turn on `gptel-mode' after opening the -file." - (run-hooks 'gptel-save-state-hook) - (if (derived-mode-p 'org-mode) - (progn - (require 'gptel-org) - (gptel-org--save-state)) - (let ((print-escape-newlines t)) - (save-excursion - (save-restriction - (add-file-local-variable 'gptel-model gptel-model) - (add-file-local-variable 'gptel--backend-name - (gptel-backend-name gptel-backend)) - (unless (equal (default-value 'gptel-temperature) gptel-temperature) - (add-file-local-variable 'gptel-temperature gptel-temperature)) - (unless (string= (default-value 'gptel--system-message) - gptel--system-message) - (add-file-local-variable 'gptel--system-message gptel--system-message)) - (when gptel-max-tokens - (add-file-local-variable 'gptel-max-tokens gptel-max-tokens)) - (when (natnump gptel--num-messages-to-send) - (add-file-local-variable 'gptel--num-messages-to-send - gptel--num-messages-to-send)) - (add-file-local-variable 'gptel--bounds (gptel--get-buffer-bounds))))))) - - -;;; Minor mode and UI - -;; NOTE: It's not clear that this is the best strategy: -(add-to-list 'text-property-default-nonsticky '(gptel . t)) - -;;;###autoload -(define-minor-mode gptel-mode - "Minor mode for interacting with LLMs." - :lighter " GPT" - :keymap - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c RET") #'gptel-send) - map) - (if gptel-mode - (progn - (unless (or (derived-mode-p 'org-mode 'markdown-mode) - (eq major-mode 'text-mode)) - (gptel-mode -1) - (user-error (format "`gptel-mode' is not supported in `%s'." major-mode))) - (add-hook 'before-save-hook #'gptel--save-state nil t) - (gptel--restore-state) - (if gptel-use-header-line - (setq gptel--old-header-line header-line-format - header-line-format - (list '(:eval (concat (propertize " " 'display '(space :align-to 0)) - (format "%s" (gptel-backend-name gptel-backend)))) - (propertize " Ready" 'face 'success) - '(:eval - (let* ((model (gptel--model-name gptel-model)) - (system - (propertize - (buttonize - (format "[Prompt: %s]" - (or (car-safe (rassoc gptel--system-message gptel-directives)) - (truncate-string-to-width gptel--system-message 15 nil nil t))) - (lambda (&rest _) (gptel-system-prompt))) - 'mouse-face 'highlight - 'help-echo "System message for session")) - (context - (and gptel-context--alist - (cl-loop for entry in gptel-context--alist - if (bufferp (car entry)) count it into bufs - else count (stringp (car entry)) into files - finally return - (propertize - (buttonize - (concat "[Context: " - (and (> bufs 0) (format "%d buf" bufs)) - (and (> bufs 1) "s") - (and (> bufs 0) (> files 0) ", ") - (and (> files 0) (format "%d file" files)) - (and (> files 1) "s") - "]") - (lambda (&rest _) - (require 'gptel-context) - (gptel-context--buffer-setup))) - 'mouse-face 'highlight - 'help-echo "Active gptel context")))) - (toggle-track-media - (lambda (&rest _) - (setq-local gptel-track-media - (not gptel-track-media)) - (if gptel-track-media - (message - (concat - "Sending media from included links. To include media, create " - "a \"standalone\" link in a paragraph by itself, separated from surrounding text.")) - (message "Ignoring image links. Only link text will be sent.")) - (run-at-time 0 nil #'force-mode-line-update))) - (track-media - (and (gptel--model-capable-p 'media) - (if gptel-track-media - (propertize - (buttonize "[Sending media]" toggle-track-media) - 'mouse-face 'highlight - 'help-echo - "Sending media from standalone links/urls when supported.\nClick to toggle") - (propertize - (buttonize "[Ignoring media]" toggle-track-media) - 'mouse-face 'highlight - 'help-echo - "Ignoring images from standalone links/urls.\nClick to toggle"))))) - (concat - (propertize - " " 'display - `(space :align-to (- right ,(+ 5 (length model) (length system) - (length track-media) (length context))))) - track-media (and context " ") context " " system " " - (propertize - (buttonize (concat "[" model "]") - (lambda (&rest _) (gptel-menu))) - 'mouse-face 'highlight - 'help-echo "GPT model in use")))))) - (setq mode-line-process - '(:eval (concat " " - (buttonize (gptel--model-name gptel-model) - (lambda (&rest _) (gptel-menu)))))))) - (remove-hook 'before-save-hook #'gptel--save-state t) - (if gptel-use-header-line - (setq header-line-format gptel--old-header-line - gptel--old-header-line nil) - (setq mode-line-process nil)))) - -(defun gptel--update-status (&optional msg face) - "Update status MSG in FACE." - (when gptel-mode - (if gptel-use-header-line - (and (consp header-line-format) - (setf (nth 1 header-line-format) - (propertize msg 'face face))) - (if (member msg '(" Typing..." " Waiting...")) - (setq mode-line-process (propertize msg 'face face)) - (setq mode-line-process - '(:eval (concat " " - (buttonize (gptel--model-name gptel-model) - (lambda (&rest _) (gptel-menu)))))) - (message (propertize msg 'face face)))) - (force-mode-line-update))) - -(declare-function gptel-context--wrap "gptel-context") - - -;;; Send queries, handle responses -(cl-defun gptel-request - (&optional prompt &key callback - (buffer (current-buffer)) - position context dry-run - (stream nil) (in-place nil) - (system gptel--system-message)) - "Request a response from the `gptel-backend' for PROMPT. - -The request is asynchronous, the function immediately returns -with the data that was sent. - -Note: This function is not fully self-contained. Consider -let-binding the parameters `gptel-backend' and `gptel-model' -around calls to it as required. - -If PROMPT is -- a string, it is used to create a full prompt suitable for - sending to the LLM. -- nil but region is active, the region contents are used. -- nil, the current buffer's contents up to (point) are used. - Previous responses from the LLM are identified as responses. -- A list of plists, it is used as is. - -Keyword arguments: - -CALLBACK, if supplied, is a function of two arguments, called -with the RESPONSE (a string) and INFO (a plist): - - (callback RESPONSE INFO) - -RESPONSE is nil if there was no response or an error. - -The INFO plist has (at least) the following keys: -:data - The request data included with the query -:position - marker at the point the request was sent, unless - POSITION is specified. -:buffer - The buffer current when the request was sent, - unless BUFFER is specified. -:status - Short string describing the result of the request - -Example of a callback that messages the user with the response -and info: - - (lambda (response info) - (if response - (let ((posn (marker-position (plist-get info :position))) - (buf (buffer-name (plist-get info :buffer)))) - (message \"Response for request from %S at %d: %s\" - buf posn response)) - (message \"gptel-request failed with message: %s\" - (plist-get info :status)))) - -Or, for just the response: - - (lambda (response _) - ;; Do something with response - (message (rot13-string response))) - -If CALLBACK is omitted, the response is inserted at the point the -request was sent. - -BUFFER and POSITION are the buffer and position (integer or -marker) at which the response is inserted. If a CALLBACK is -specified, no response is inserted and these arguments are -ignored, but they are still available in the INFO plist passed -to CALLBACK for you to use. - -BUFFER defaults to the current buffer, and POSITION to the value -of (point) or (region-end), depending on whether the region is -active. - -CONTEXT is any additional data needed for the callback to run. It -is included in the INFO argument to the callback. - -SYSTEM is the system message (chat directive) sent to the LLM. If -omitted, the value of `gptel--system-message' for the current -buffer is used. - -The following keywords are mainly for internal use: - -IN-PLACE is a boolean used by the default callback when inserting -the response to determine if delimiters are needed between the -prompt and the response. - -STREAM is a boolean that determines if the response should be -streamed, as in `gptel-stream'. Do not set this if you are -specifying a custom CALLBACK! - -If DRY-RUN is non-nil, construct and return the full -query data as usual, but do not send the request. - -Model parameters can be let-bound around calls to this function." - (declare (indent 1)) - ;; TODO Remove this check in version 1.0 - (gptel--sanitize-model) - (let* ((gptel--system-message - ;Add context chunks to system message if required - (if (and gptel-context--alist - (eq gptel-use-context 'system) - (not (gptel--model-capable-p 'nosystem))) - (gptel-context--wrap system) - system)) - (gptel-stream stream) - (start-marker - (cond - ((null position) - (if (use-region-p) - (set-marker (make-marker) (region-end)) - (gptel--at-word-end (point-marker)))) - ((markerp position) position) - ((integerp position) - (set-marker (make-marker) position buffer)))) - (full-prompt - (cond - ((null prompt) - (gptel--create-prompt start-marker)) - ((stringp prompt) - ;; FIXME Dear reader, welcome to Jank City: - (with-temp-buffer - (let ((gptel-model (buffer-local-value 'gptel-model buffer)) - (gptel-backend (buffer-local-value 'gptel-backend buffer))) - (insert prompt) - (gptel--create-prompt)))) - ((consp prompt) prompt))) - (request-data (gptel--request-data gptel-backend full-prompt)) - (info (list :data request-data - :buffer buffer - :position start-marker))) - ;; This context should not be confused with the context aggregation context! - (when context (plist-put info :context context)) - (when in-place (plist-put info :in-place in-place)) - (unless dry-run - (funcall (if gptel-use-curl - #'gptel-curl-get-response #'gptel--url-get-response) - info callback)) - request-data)) - -;; TODO: Handle multiple requests(#15). (Only one request from one buffer at a time?) -;;;###autoload -(defun gptel-send (&optional arg) - "Submit this prompt to the current LLM backend. - -By default, the contents of the buffer up to the cursor position -are sent. If the region is active, its contents are sent -instead. - -The response from the LLM is inserted below the cursor position -at the time of sending. To change this behavior or model -parameters, use prefix arg ARG activate a transient menu with -more options instead. - -This command is asynchronous, you can continue to use Emacs while -waiting for the response." - (interactive "P") - (if (and arg (require 'gptel-transient nil t)) - (call-interactively #'gptel-menu) - (message "Querying %s..." (gptel-backend-name gptel-backend)) - (gptel--sanitize-model) - (gptel-request nil :stream gptel-stream) - (gptel--update-status " Waiting..." 'warning))) - -(declare-function json-pretty-print-buffer "json") -(defun gptel--inspect-query (request-data &optional arg) - "Show REQUEST-DATA, the full LLM query to be sent, in a buffer. - -This functions as a dry run of `gptel-send'. If ARG is -the symbol json, show the encoded JSON query instead of the Lisp -structure gptel uses." - (with-current-buffer (get-buffer-create "*gptel-query*") - (let ((standard-output (current-buffer)) - (inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (if (eq arg 'json) - (progn (fundamental-mode) - (insert (gptel--json-encode request-data)) - (json-pretty-print-buffer)) - (lisp-data-mode) - (prin1 request-data) - (pp-buffer)) - (goto-char (point-min)) - (view-mode 1) - (display-buffer (current-buffer) gptel-display-buffer-action)))) - -(defun gptel--insert-response (response info) - "Insert the LLM RESPONSE into the gptel buffer. - -INFO is a plist containing information relevant to this buffer. -See `gptel--url-get-response' for details." - (let* ((status-str (plist-get info :status)) - (gptel-buffer (plist-get info :buffer)) - (start-marker (plist-get info :position)) - response-beg response-end) - ;; Handle read-only buffers - (when (with-current-buffer gptel-buffer - (or buffer-read-only - (get-char-property start-marker 'read-only))) - (message "Buffer is read only, displaying reply in buffer \"*LLM response*\"") - (display-buffer - (with-current-buffer (get-buffer-create "*LLM response*") - (visual-line-mode 1) - (goto-char (point-max)) - (move-marker start-marker (point) (current-buffer)) - (current-buffer)) - '((display-buffer-reuse-window - display-buffer-pop-up-window) - (reusable-frames . visible)))) - ;; Insert response and status message/error message - (with-current-buffer gptel-buffer - (if response - (progn - (setq response (gptel--transform-response - response gptel-buffer)) - (save-excursion - (put-text-property - 0 (length response) 'gptel 'response response) - (with-current-buffer (marker-buffer start-marker) - (goto-char start-marker) - (run-hooks 'gptel-pre-response-hook) - (unless (or (bobp) (plist-get info :in-place)) - (insert "\n\n") - (when gptel-mode - (insert (gptel-response-prefix-string)))) - (setq response-beg (point)) ;Save response start position - (insert response) - (setq response-end (point)) - (pulse-momentary-highlight-region response-beg response-end) - (when gptel-mode (insert "\n\n" (gptel-prompt-prefix-string)))) ;Save response end position - (when gptel-mode (gptel--update-status " Ready" 'success)))) - (gptel--update-status - (format " Response Error: %s" status-str) 'error) - (message "gptel response error: (%s) %s" - status-str (plist-get info :error)))) - ;; Run hook in visible window to set window-point, BUG #269 - (if-let ((gptel-window (get-buffer-window gptel-buffer 'visible))) - (with-selected-window gptel-window - (run-hook-with-args 'gptel-post-response-functions response-beg response-end)) - (with-current-buffer gptel-buffer - (run-hook-with-args 'gptel-post-response-functions response-beg response-end))))) - -(defun gptel--create-prompt (&optional prompt-end) - "Return a full conversation prompt from the contents of this buffer. - -If `gptel--num-messages-to-send' is set, limit to that many -recent exchanges. - -If the region is active limit the prompt to the region contents -instead. - -If `gptel-context--alist' is non-nil and the additional -context needs to be included with the user prompt, add it. - -If PROMPT-END (a marker) is provided, end the prompt contents -there." - (save-excursion - (save-restriction - (let* ((max-entries (and gptel--num-messages-to-send - (* 2 gptel--num-messages-to-send))) - (prompt-end (or prompt-end (point-max))) - (prompts - (cond - ((use-region-p) - ;; Narrow to region - (narrow-to-region (region-beginning) (region-end)) - (goto-char (point-max)) - (gptel--parse-buffer gptel-backend max-entries)) - ((derived-mode-p 'org-mode) - (require 'gptel-org) - (goto-char prompt-end) - (gptel-org--create-prompt prompt-end)) - (t (goto-char prompt-end) - (gptel--parse-buffer gptel-backend max-entries))))) - ;; NOTE: prompts is modified in place here - (when gptel-context--alist - ;; Inject context chunks into the last user prompt if required. - ;; This is also the fallback for when `gptel-use-context' is set to - ;; 'system but the model does not support system messages. - (when (and gptel-use-context - (or (eq gptel-use-context 'user) - (gptel--model-capable-p 'nosystem)) - (> (length prompts) 0)) ;FIXME context should be injected - ;even when there are no prompts - (gptel--wrap-user-prompt gptel-backend prompts)) - ;; Inject media chunks into the first user prompt if required. Media - ;; chunks are always included with the first user message, - ;; irrespective of the preference in `gptel-use-context'. This is - ;; because media cannot be included (in general) with system messages. - (when (and gptel-use-context gptel-track-media - (gptel--model-capable-p 'media)) - (gptel--wrap-user-prompt gptel-backend prompts :media))) - prompts)))) - -(cl-defgeneric gptel--parse-buffer (backend max-entries) - "Parse current buffer backwards from point and return a list of prompts. - -BACKEND is the LLM backend in use. - -MAX-ENTRIES is the number of queries/responses to include for -contexbt.") - -(cl-defgeneric gptel--parse-media-links (mode beg end) - "Find media links between BEG and END. - -MODE is the major-mode of the buffer. - -Returns a plist where each entry is of the form - (:text \"some text\") -or - (:media \"media uri or file path\")." - (ignore mode) ;byte-compiler - (list `(:text ,(buffer-substring beg end)))) - -(defvar markdown-regex-link-inline) -(defvar markdown-regex-angle-uri) -(declare-function markdown-link-at-pos "markdown-mode") -(declare-function mailcap-file-name-to-mime-type "mailcap") - -(cl-defmethod gptel--parse-media-links ((_mode (eql 'markdown-mode)) beg end) - "Parse text and actionable links between BEG and END. - -Return a list of the form - ((:text \"some text\") - (:media \"/path/to/media.png\" :mime \"image/png\") - (:text \"More text\")) -for inclusion into the user prompt for the gptel request." - (require 'mailcap) ;FIXME Avoid this somehow - (let ((parts) (from-pt)) - (save-excursion - (setq from-pt (goto-char beg)) - (while (re-search-forward - (concat "\\(?:" markdown-regex-link-inline "\\|" - markdown-regex-angle-uri "\\)") - end t) - (when-let* ((link-at-pt (markdown-link-at-pos (point))) - ((gptel--link-standalone-p - (car link-at-pt) (cadr link-at-pt))) - (path (nth 3 link-at-pt)) - (path (string-remove-prefix "file://" path)) - (mime (mailcap-file-name-to-mime-type path)) - ((gptel--model-mime-capable-p mime))) - (cond - ((seq-some (lambda (p) (string-prefix-p p path)) - '("https:" "http:" "ftp:")) - ;; Collect text up to this image, and collect this image url - (when (gptel--model-capable-p 'url) ; FIXME This is not a good place - ; to check for url capability! - (push (list :text (buffer-substring-no-properties from-pt (car link-at-pt))) - parts) - (push (list :url path :mime mime) parts) - (setq from-pt (cadr link-at-pt)))) - ((file-readable-p path) - ;; Collect text up to this image, and collect this image - (push (list :text (buffer-substring-no-properties from-pt (car link-at-pt))) - parts) - (push (list :media path :mime mime) parts) - (setq from-pt (cadr link-at-pt))))))) - (unless (= from-pt end) - (push (list :text (buffer-substring-no-properties from-pt end)) parts)) - (nreverse parts))) - -(cl-defgeneric gptel--wrap-user-prompt (backend _prompts) - "Wrap the last prompt in PROMPTS with gptel's context. - -PROMPTS is a structure as returned by `gptel--parse-buffer'. -Typically this is a list of plists. - -BACKEND is the gptel backend in use." - (display-warning - '(gptel context) - (format "Context support not implemented for backend %s, ignoring context" - (gptel-backend-name backend)))) - -(cl-defgeneric gptel--request-data (backend prompts) - "Generate a plist of all data for an LLM query. - -BACKEND is the LLM backend in use. - -PROMPTS is the plist of previous user queries and LLM responses.") - -;; TODO: Use `run-hook-wrapped' with an accumulator instead to handle -;; buffer-local hooks, etc. -(defun gptel--transform-response (content-str buffer) - "Filter CONTENT-STR through `gptel-response-filter-functions`. - -BUFFER is passed along with CONTENT-STR to each function in this -hook." - (let ((filtered-str content-str)) - (dolist (filter-func gptel-response-filter-functions filtered-str) - (condition-case nil - (when (functionp filter-func) - (setq filtered-str - (funcall filter-func filtered-str buffer))) - (error - (display-warning '(gptel filter-functions) - (format "Function %S returned an error" - filter-func))))))) - -(defun gptel--convert-org (content buffer) - "Transform CONTENT according to required major-mode. - -Currently only `org-mode' is handled. - -BUFFER is the LLM interaction buffer." - (if (with-current-buffer buffer (derived-mode-p 'org-mode)) - (gptel--convert-markdown->org content) - content)) - -(defun gptel--url-get-response (info &optional callback) - "Fetch response to prompt in INFO from the LLM. - -INFO is a plist with the following keys: -- :data (the data being sent) -- :buffer (the gptel buffer) -- :position (marker at which to insert the response). - -Call CALLBACK with the response and INFO afterwards. If omitted -the response is inserted into the current buffer after point." - (let* ((inhibit-message t) - (message-log-max nil) - (backend gptel-backend) - (url-request-method "POST") - (url-request-extra-headers - (append '(("Content-Type" . "application/json")) - (when-let ((header (gptel-backend-header gptel-backend))) - (if (functionp header) - (funcall header) header)))) - (url-request-data - (encode-coding-string - (gptel--json-encode (plist-get info :data)) - 'utf-8))) - ;; why do these checks not occur inside of `gptel--log'? - (when gptel-log-level ;logging - (when (eq gptel-log-level 'debug) - (gptel--log (gptel--json-encode - (mapcar (lambda (pair) (cons (intern (car pair)) (cdr pair))) - url-request-extra-headers)) - "request headers")) - (gptel--log url-request-data "request body")) - (url-retrieve (let ((backend-url (gptel-backend-url gptel-backend))) - (if (functionp backend-url) - (funcall backend-url) backend-url)) - (lambda (_) - (pcase-let ((`(,response ,http-msg ,error) - (gptel--url-parse-response backend (current-buffer)))) - (plist-put info :status http-msg) - (when error (plist-put info :error error)) - (funcall (or callback #'gptel--insert-response) - response info) - (kill-buffer))) - nil t nil))) - -(cl-defgeneric gptel--parse-response (backend response proc-info) - "Response extractor for LLM requests. - -BACKEND is the LLM backend in use. - -RESPONSE is the parsed JSON of the response, as a plist. - -PROC-INFO is a plist with process information and other context. -See `gptel-curl--get-response' for its contents.") - -(defvar url-http-end-of-headers) -(defvar url-http-response-status) -(defun gptel--url-parse-response (backend response-buffer) - "Parse response from BACKEND in RESPONSE-BUFFER." - (when (buffer-live-p response-buffer) - (with-current-buffer response-buffer - (when gptel-log-level ;logging - (save-excursion - (goto-char url-http-end-of-headers) - (when (eq gptel-log-level 'debug) - (gptel--log (gptel--json-encode (buffer-substring-no-properties (point-min) (point))) - "response headers")) - (gptel--log (buffer-substring-no-properties (point) (point-max)) - "response body"))) - (if-let* ((http-msg (string-trim (buffer-substring (line-beginning-position) - (line-end-position)))) - (response (progn (goto-char url-http-end-of-headers) - (condition-case nil - (gptel--json-read) - (error 'json-read-error))))) - (cond - ;; FIXME Handle the case where HTTP 100 is followed by HTTP (not 200) BUG #194 - ((or (memq url-http-response-status '(200 100)) - (string-match-p "\\(?:1\\|2\\)00 OK" http-msg)) - (list (string-trim (gptel--parse-response backend response - `(:buffer ,response-buffer - :backend ,backend))) - http-msg)) - ((plist-get response :error) - (let* ((error-data (plist-get response :error)) - (error-msg (plist-get error-data :message)) - (error-type (plist-get error-data :type)) - (backend-name (gptel-backend-name backend))) - (if (stringp error-data) - (progn - (message "%s error: (%s) %s" backend-name http-msg error-data) - (setq error-msg (string-trim error-data))) - (when (stringp error-msg) - (message "%s error: (%s) %s" backend-name http-msg (string-trim error-msg))) - (when error-type - (setq http-msg (concat "(" http-msg ") " (string-trim error-type))))) - (list nil (concat "(" http-msg ") " (or error-msg ""))))) - ((eq response 'json-read-error) - (list nil (concat "(" http-msg ") Malformed JSON in response.") "json-read-error")) - (t (list nil (concat "(" http-msg ") Could not parse HTTP response.") - "Could not parse HTTP response."))) - (list nil (concat "(" http-msg ") Could not parse HTTP response.") - "Could not parse HTTP response."))))) - -(cl-defun gptel--sanitize-model (&key (backend gptel-backend) - (model gptel-model) - (shoosh t)) - "Check if MODEL is available in BACKEND, adjust accordingly. - -If SHOOSH is true, don't issue a warning." - (let ((available (gptel-backend-models backend))) - (when (stringp model) - (unless shoosh - (display-warning - 'gptel - (format "`gptel-model' expects a symbol, found string \"%s\" - Resetting `gptel-model' to %s" - model model))) - (setq gptel-model (gptel--intern model) - model gptel-model)) - (unless (member model available) - (let ((fallback (car available))) - (unless shoosh - (display-warning - 'gptel - (format (concat "Preferred `gptel-model' \"%s\" not" - "supported in \"%s\", using \"%s\" instead") - model (gptel-backend-name backend) fallback))) - (setq-local gptel-model fallback))))) - -;;;###autoload -(defun gptel (name &optional _ initial interactivep) - "Switch to or start a chat session with NAME. - -Ask for API-KEY if `gptel-api-key' is unset. - -If region is active, use it as the INITIAL prompt. Returns the -buffer created or switched to. - -INTERACTIVEP is t when gptel is called interactively." - (interactive - (let* ((backend (default-value 'gptel-backend)) - (backend-name - (format "*%s*" (gptel-backend-name backend)))) - (list (read-buffer - "Create or choose gptel buffer: " - backend-name nil ; DEFAULT and REQUIRE-MATCH - (lambda (b) ; PREDICATE - ;; NOTE: buffer check is required (#450) - (and-let* ((buf (get-buffer (or (car-safe b) b)))) - (buffer-local-value 'gptel-mode buf)))) - (condition-case nil - (gptel--get-api-key - (gptel-backend-key backend)) - ((error user-error) - (setq gptel-api-key - (read-passwd - (format "%s API key: " backend-name))))) - (and (use-region-p) - (buffer-substring (region-beginning) - (region-end))) - t))) - (with-current-buffer (get-buffer-create name) - (cond ;Set major mode - ((eq major-mode gptel-default-mode)) - ((eq gptel-default-mode 'text-mode) - (text-mode) - (visual-line-mode 1)) - (t (funcall gptel-default-mode))) - (gptel--sanitize-model :backend (default-value 'gptel-backend) - :model (default-value 'gptel-model) - :shoosh nil) - (unless gptel-mode (gptel-mode 1)) - (goto-char (point-max)) - (skip-chars-backward "\t\r\n") - (if (bobp) (insert (or initial (gptel-prompt-prefix-string)))) - (when interactivep - (display-buffer (current-buffer) gptel-display-buffer-action) - (message "Send your query with %s!" - (substitute-command-keys "\\[gptel-send]"))) - (current-buffer))) - - -;;; Response tweaking commands - -(defun gptel--attach-response-history (history &optional buf) - "Attach HISTORY to the next gptel response in buffer BUF. - -HISTORY is a list of strings typically containing text replaced -by gptel. BUF is the current buffer if not specified. - -This is used to maintain variants of prompts or responses to diff -against if required." - (with-current-buffer (or buf (current-buffer)) - (letrec ((gptel--attach-after - (lambda (b e) - (put-text-property b e 'gptel-history - (append (ensure-list history) - (get-char-property (1- e) 'gptel-history))) - (remove-hook 'gptel-post-response-functions - gptel--attach-after 'local)))) - (add-hook 'gptel-post-response-functions gptel--attach-after - nil 'local)))) - -(defun gptel--ediff (&optional arg bounds-func) - "Ediff response at point against previous gptel responses. - -If prefix ARG is non-nil, select the previous response to ediff -against interactively. - -If specified, use BOUNDS-FUNC to compute the bounds of the -response at point. This can be used to include additional -context for the ediff session." - (interactive "P") - (when (gptel--at-response-history-p) - (pcase-let* ((`(,beg . ,end) (funcall (or bounds-func #'gptel--get-bounds))) - (prev-response - (if arg - (completing-read "Choose response variant to diff against: " - (get-char-property (point) 'gptel-history) - nil t) - (car-safe (get-char-property (point) 'gptel-history)))) - (buffer-mode major-mode) - (bufname (buffer-name)) - (`(,new-buf ,new-beg ,new-end) - (with-current-buffer - (get-buffer-create (concat bufname "-PREVIOUS-*")) - (let ((inhibit-read-only t)) - (erase-buffer) - (delay-mode-hooks (funcall buffer-mode)) - (visual-line-mode) - (insert prev-response) - (goto-char (point-min)) - (list (current-buffer) (point-min) (point-max)))))) - (unless prev-response (user-error "gptel response is additive: no changes to ediff")) - (require 'ediff) - (letrec ((cwc (current-window-configuration)) - (gptel--ediff-restore - (lambda () - (when (window-configuration-p cwc) - (set-window-configuration cwc)) - (kill-buffer (get-buffer (concat bufname "-PREVIOUS-*"))) - (kill-buffer (get-buffer (concat bufname "-CURRENT-*"))) - (remove-hook 'ediff-quit-hook gptel--ediff-restore)))) - (add-hook 'ediff-quit-hook gptel--ediff-restore) - (apply - #'ediff-regions-internal - (get-buffer (ediff-make-cloned-buffer (current-buffer) "-CURRENT-*")) - beg end new-buf new-beg new-end - nil - (list 'ediff-regions-wordwise 'word-wise nil) - ;; (if (transient-arg-value "-w" args) - ;; (list 'ediff-regions-wordwise 'word-wise nil) - ;; (list 'ediff-regions-linewise nil nil)) - ))))) - -(defun gptel--mark-response () - "Mark gptel response at point, if any." - (interactive) - (unless (gptel--in-response-p) (user-error "No gptel response at point")) - (pcase-let ((`(,beg . ,end) (gptel--get-bounds))) - (goto-char beg) (push-mark) (goto-char end) (activate-mark))) - -(defun gptel--previous-variant (&optional arg) - "Switch to previous gptel-response at this point, if it exists." - (interactive "p") - (pcase-let* ((`(,beg . ,end) (gptel--get-bounds)) - (history (get-char-property (point) 'gptel-history)) - (alt-response (car-safe history)) - (offset)) - (unless (and history alt-response) - (user-error "No variant responses available")) - (if (> arg 0) - (setq history (append (cdr history) - (list (buffer-substring-no-properties beg end)))) - (setq - alt-response (car (last history)) - history (cons (buffer-substring-no-properties beg end) - (nbutlast history)))) - (add-text-properties - 0 (length alt-response) - `(gptel response gptel-history ,history) - alt-response) - (setq offset (min (- (point) beg) (1- (length alt-response)))) - (delete-region beg end) - (insert alt-response) - (goto-char (+ beg offset)) - (pulse-momentary-highlight-region beg (+ beg (length alt-response))))) - -(defun gptel--next-variant (&optional arg) - "Switch to next gptel-response at this point, if it exists." - (interactive "p") - (gptel--previous-variant (- arg))) - -(provide 'gptel) -;;; gptel.el ends here - -;; Local Variables: -;; bug-reference-url-format: "https://github.com/karthink/gptel/issues/%s" -;; End: diff --git a/emacs/elpa/gptel-20241112.624/gptel-anthropic.el b/emacs/elpa/gptel-20241115.456/gptel-anthropic.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-anthropic.elc b/emacs/elpa/gptel-20241115.456/gptel-anthropic.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-autoloads.el b/emacs/elpa/gptel-20241115.456/gptel-autoloads.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-context.el b/emacs/elpa/gptel-20241115.456/gptel-context.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-context.elc b/emacs/elpa/gptel-20241115.456/gptel-context.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-curl.el b/emacs/elpa/gptel-20241115.456/gptel-curl.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-curl.elc b/emacs/elpa/gptel-20241115.456/gptel-curl.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-gemini.el b/emacs/elpa/gptel-20241115.456/gptel-gemini.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-gemini.elc b/emacs/elpa/gptel-20241115.456/gptel-gemini.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-kagi.el b/emacs/elpa/gptel-20241115.456/gptel-kagi.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-kagi.elc b/emacs/elpa/gptel-20241115.456/gptel-kagi.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-ollama.el b/emacs/elpa/gptel-20241115.456/gptel-ollama.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-ollama.elc b/emacs/elpa/gptel-20241115.456/gptel-ollama.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-openai.el b/emacs/elpa/gptel-20241115.456/gptel-openai.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-openai.elc b/emacs/elpa/gptel-20241115.456/gptel-openai.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241115.456/gptel-org.el b/emacs/elpa/gptel-20241115.456/gptel-org.el @@ -0,0 +1,597 @@ +;;; gptel-org.el --- Org functions for gptel -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Karthik Chikmagalur + +;; Author: Karthik Chikmagalur <karthikchikmagalur@gmail.com> +;; 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: + +;; + +;;; Code: +(eval-when-compile (require 'cl-lib)) +(require 'org-element) +(require 'outline) + +;; Functions used for saving/restoring gptel state in Org buffers +(defvar gptel--num-messages-to-send) +(defvar org-entry-property-inherited-from) +(defvar gptel-backend) +(defvar gptel--known-backends) +(defvar gptel--system-message) +(defvar gptel-model) +(defvar gptel-temperature) +(defvar gptel-max-tokens) + +(defvar org-link-angle-re) +(defvar org-link-bracket-re) +(declare-function mailcap-file-name-to-mime-type "mailcap") +(declare-function gptel--model-capable-p "gptel") +(declare-function gptel--model-mime-capable-p "gptel") +(declare-function gptel--model-name "gptel") +(declare-function gptel--to-string "gptel") +(declare-function gptel--to-number "gptel") +(declare-function gptel--intern "gptel") +(declare-function gptel--get-buffer-bounds "gptel") +(declare-function gptel-backend-name "gptel") +(declare-function gptel--parse-buffer "gptel") +(declare-function org-entry-get "org") +(declare-function org-entry-put "org") +(declare-function org-with-wide-buffer "org-macs") +(declare-function org-set-property "org") +(declare-function org-property-values "org") +(declare-function org-open-line "org") +(declare-function org-at-heading-p "org") +(declare-function org-get-heading "org") +(declare-function org-at-heading-p "org") + +;; Bundle `org-element-lineage-map' if it's not available (for Org 9.67 or older) +(eval-and-compile + (if (fboundp 'org-element-lineage-map) + (progn (declare-function org-element-lineage-map "org-element-ast") + (defalias 'gptel-org--element-lineage-map 'org-element-lineage-map)) + (defun gptel-org--element-lineage-map (datum fun &optional types with-self first-match) + "Map FUN across ancestors of DATUM, from closest to furthest. + +DATUM is an object or element. For TYPES, WITH-SELF and +FIRST-MATCH see `org-element-lineage-map'. + +This function is provided for compatibility with older versions +of Org." + (declare (indent 2)) + (setq fun (if (functionp fun) fun `(lambda (node) ,fun))) + (let ((up (if with-self datum (org-element-parent datum))) + acc rtn) + (catch :--first-match + (while up + (when (or (not types) (org-element-type-p up types)) + (setq rtn (funcall fun up)) + (if (and first-match rtn) + (throw :--first-match rtn) + (when rtn (push rtn acc)))) + (setq up (org-element-parent up))) + (nreverse acc))))) + (if (fboundp 'org-element-begin) + (progn (declare-function org-element-begin "org-element") + (defalias 'gptel-org--element-begin 'org-element-begin)) + (defun gptel-org--element-begin (node) + "Get `:begin' property of NODE." + (org-element-property :begin node)))) + + +;;; User options +(defcustom gptel-org-branching-context nil + "Use the lineage of the current heading as the context for gptel in Org buffers. + +This makes each same level heading a separate conversation +branch. + +By default, gptel uses a linear context: all the text up to the +cursor is sent to the LLM. Enabling this option makes the +context the hierarchical lineage of the current Org heading. In +this example: + +----- +Top level text + +* Heading 1 +heading 1 text + +* Heading 2 +heading 2 text + +** Heading 2.1 +heading 2.1 text +** Heading 2.2 +heading 2.2 text +----- + +With the cursor at the end of the buffer, the text sent to the +LLM will be limited to + +----- +Top level text + +* Heading 2 +heading 2 text + +** Heading 2.2 +heading 2.2 text +----- + +This makes it feasible to have multiple conversation branches." + :local t + :type 'boolean + :group 'gptel) + + +;;; Setting context and creating queries +(defun gptel-org--get-topic-start () + "If a conversation topic is set, return it." + (when (org-entry-get (point) "GPTEL_TOPIC" 'inherit) + (marker-position org-entry-property-inherited-from))) + +(defun gptel-org-set-topic (topic) + "Set a TOPIC and limit this conversation to the current heading. + +This limits the context sent to the LLM to the text between the +current heading and the cursor position." + (interactive + (list + (progn + (or (derived-mode-p 'org-mode) + (user-error "Support for multiple topics per buffer is only implemented for `org-mode'")) + (completing-read "Set topic as: " + (org-property-values "GPTEL_TOPIC") + nil nil (downcase + (truncate-string-to-width + (substring-no-properties + (replace-regexp-in-string + "\\s-+" "-" + (org-get-heading))) + 50)))))) + (when (stringp topic) (org-set-property "GPTEL_TOPIC" topic))) + +;; NOTE: This can be converted to a cl-defmethod for `gptel--parse-buffer' +;; (conceptually cleaner), but will cause load-order issues in gptel.el and +;; might be harder to debug. +(defun gptel-org--create-prompt (&optional prompt-end) + "Return a full conversation prompt from the contents of this Org buffer. + +If `gptel--num-messages-to-send' is set, limit to that many +recent exchanges. + +The prompt is constructed from the contents of the buffer up to +point, or PROMPT-END if provided. Its contents depend on the +value of `gptel-org-branching-context', which see." + (unless prompt-end (setq prompt-end (point))) + (let ((max-entries (and gptel--num-messages-to-send + (* 2 gptel--num-messages-to-send))) + (topic-start (gptel-org--get-topic-start))) + (when topic-start + ;; narrow to GPTEL_TOPIC property scope + (narrow-to-region topic-start prompt-end)) + (if gptel-org-branching-context + ;; Create prompt from direct ancestors of point + (if (fboundp 'org-element-lineage-map) + (save-excursion + (let* ((org-buf (current-buffer)) + (start-bounds (gptel-org--element-lineage-map + (org-element-at-point) #'gptel-org--element-begin + '(headline org-data) 'with-self)) + (end-bounds + (cl-loop + for (pos . rest) on (cdr start-bounds) + while + (and (>= pos (point-min)) ;respect narrowing + (goto-char pos) + ;; org-element-lineage always returns an extra + ;; (org-data) element at point 1. If there is also a + ;; heading here, it is either a false positive or we + ;; would be double counting it. So we reject this node + ;; when also at a heading. + (not (and (eq pos 1) (org-at-heading-p) + ;; Skip if at the last element of start-bounds, + ;; since we captured this heading already (#476) + (null rest)))) + do (outline-next-heading) + collect (point) into ends + finally return (cons prompt-end ends)))) + (with-temp-buffer + (setq-local gptel-backend (buffer-local-value 'gptel-backend org-buf) + gptel--system-message + (buffer-local-value 'gptel--system-message org-buf) + gptel-model (buffer-local-value 'gptel-model org-buf) + gptel-mode (buffer-local-value 'gptel-mode org-buf) + gptel-track-response + (buffer-local-value 'gptel-track-response org-buf) + gptel-track-media + (buffer-local-value 'gptel-track-media org-buf)) + (cl-loop for start in start-bounds + for end in end-bounds + do (insert-buffer-substring org-buf start end) + (goto-char (point-min))) + (goto-char (point-max)) + (let ((major-mode 'org-mode)) + (gptel--parse-buffer gptel-backend max-entries))))) + (display-warning + '(gptel org) + "Using `gptel-org-branching-context' requires Org version 9.6.7 or higher, it will be ignored.") + (gptel--parse-buffer gptel-backend max-entries)) + ;; Create prompt the usual way + (gptel--parse-buffer gptel-backend max-entries)))) + +;; Handle media links in the buffer +(cl-defmethod gptel--parse-media-links ((_mode (eql 'org-mode)) beg end) + "Parse text and actionable links between BEG and END. + +Return a list of the form + ((:text \"some text\") + (:media \"/path/to/media.png\" :mime \"image/png\") + (:text \"More text\")) +for inclusion into the user prompt for the gptel request." + (require 'mailcap) ;FIXME Avoid this somehow + (let ((parts) (from-pt) + (link-regex (concat "\\(?:" org-link-bracket-re "\\|" + org-link-angle-re "\\)"))) + (save-excursion + (setq from-pt (goto-char beg)) + (while (re-search-forward link-regex end t) + (when-let* ((link (org-element-context)) + ((gptel-org--link-standalone-p link)) + (raw-link (org-element-property :raw-link link)) + (path (org-element-property :path link)) + (type (org-element-property :type link)) + ;; FIXME This is not a good place to check for url capability! + ((member type `("attachment" "file" + ,@(and (gptel--model-capable-p 'url) + '("http" "https" "ftp"))))) + (mime (mailcap-file-name-to-mime-type path)) + ((gptel--model-mime-capable-p mime))) + (cond + ((member type '("file" "attachment")) + (when (file-readable-p path) + ;; Collect text up to this image, and + ;; Collect this image + (when-let ((text (string-trim (buffer-substring-no-properties + from-pt (gptel-org--element-begin link))))) + (unless (string-empty-p text) (push (list :text text) parts))) + (push (list :media path :mime mime) parts) + (setq from-pt (point)))) + ((member type '("http" "https" "ftp")) + ;; Collect text up to this image, and + ;; Collect this image url + (when-let ((text (string-trim (buffer-substring-no-properties + from-pt (gptel-org--element-begin link))))) + (unless (string-empty-p text) (push (list :text text) parts))) + (push (list :url raw-link :mime mime) parts) + (setq from-pt (point)))))) + (unless (= from-pt end) + (push (list :text (buffer-substring-no-properties from-pt end)) parts))) + (nreverse parts))) + +(defun gptel-org--link-standalone-p (object) + "Check if link OBJECT is on a line by itself." + ;; Specify ancestor TYPES as list (#245) + (let ((par (org-element-lineage object '(paragraph)))) + (and (= (gptel-org--element-begin object) + (save-excursion + (goto-char (org-element-property :contents-begin par)) + (skip-chars-forward "\t ") + (point))) ;account for leading space + ;before object + (<= (- (org-element-property :contents-end par) + (org-element-property :end object)) + 1)))) + +(defun gptel-org--send-with-props (send-fun &rest args) + "Conditionally modify SEND-FUN's calling environment. + +If in an Org buffer under a heading containing a stored gptel +configuration, use that for requests instead. This includes the +system message, model and provider (backend), among other +parameters. + +ARGS are the original function call arguments." + (if (derived-mode-p 'org-mode) + (pcase-let ((`(,gptel--system-message ,gptel-backend ,gptel-model + ,gptel-temperature ,gptel-max-tokens) + (seq-mapn (lambda (a b) (or a b)) + (gptel-org--entry-properties) + (list gptel--system-message gptel-backend gptel-model + gptel-temperature gptel-max-tokens)))) + (apply send-fun args)) + (apply send-fun args))) + +(advice-add 'gptel-send :around #'gptel-org--send-with-props) +(advice-add 'gptel--suffix-send :around #'gptel-org--send-with-props) + +;; ;; NOTE: Basic uses in org-mode are covered by advising gptel-send and +;; ;; gptel--suffix-send. For custom commands it might be necessary to advise +;; ;; gptel-request instead. +;; (advice-add 'gptel-request :around #'gptel-org--send-with-props) + + +;;; Saving and restoring state +(defun gptel-org--entry-properties (&optional pt) + "Find gptel configuration properties stored at PT." + (pcase-let + ((`(,system ,backend ,model ,temperature ,tokens ,num) + (mapcar + (lambda (prop) (org-entry-get (or pt (point)) prop 'selective)) + '("GPTEL_SYSTEM" "GPTEL_BACKEND" "GPTEL_MODEL" + "GPTEL_TEMPERATURE" "GPTEL_MAX_TOKENS" + "GPTEL_NUM_MESSAGES_TO_SEND")))) + (when system + (setq system (string-replace "\\n" "\n" system))) + (when backend + (setq backend (alist-get backend gptel--known-backends + nil nil #'equal))) + (when model (setq model (gptel--intern model))) + (when temperature + (setq temperature (gptel--to-number temperature))) + (when tokens (setq tokens (gptel--to-number tokens))) + (when num (setq num (gptel--to-number num))) + (list system backend model temperature tokens num))) + +(defun gptel-org--restore-state () + "Restore gptel state for Org buffers when turning on `gptel-mode'." + (save-restriction + (widen) + (condition-case status + (progn + (when-let ((bounds (org-entry-get (point-min) "GPTEL_BOUNDS"))) + (mapc (pcase-lambda (`(,beg . ,end)) + (put-text-property beg end 'gptel 'response)) + (read bounds))) + (pcase-let ((`(,system ,backend ,model ,temperature ,tokens ,num) + (gptel-org--entry-properties (point-min)))) + (when system (setq-local gptel--system-message system)) + (if backend (setq-local gptel-backend backend) + (message + (substitute-command-keys + (concat + "Could not activate gptel backend \"%s\"! " + "Switch backends with \\[universal-argument] \\[gptel-send]" + " before using gptel.")) + backend)) + (when model (setq-local gptel-model model)) + (when temperature (setq-local gptel-temperature temperature)) + (when tokens (setq-local gptel-max-tokens tokens)) + (when num (setq-local gptel--num-messages-to-send num)))) + (:success (message "gptel chat restored.")) + (error (message "Could not restore gptel state, sorry! Error: %s" status))))) + +(defun gptel-org-set-properties (pt &optional msg) + "Store the active gptel configuration under the current heading. + +The active gptel configuration includes the current system +message, language model and provider (backend), and additional +settings when applicable. + +PT is the cursor position by default. If MSG is +non-nil (default), display a message afterwards." + (interactive (list (point) t)) + (org-entry-put pt "GPTEL_MODEL" (gptel--model-name gptel-model)) + (org-entry-put pt "GPTEL_BACKEND" (gptel-backend-name gptel-backend)) + (unless (equal (default-value 'gptel-temperature) gptel-temperature) + (org-entry-put pt "GPTEL_TEMPERATURE" + (number-to-string gptel-temperature))) + (when (natnump gptel--num-messages-to-send) + (org-entry-put pt "GPTEL_NUM_MESSAGES_TO_SEND" + (number-to-string gptel--num-messages-to-send))) + (org-entry-put pt "GPTEL_SYSTEM" + (string-replace "\n" "\\n" gptel--system-message)) + (when gptel-max-tokens + (org-entry-put + pt "GPTEL_MAX_TOKENS" (number-to-string gptel-max-tokens))) + (when msg + (message "Added gptel configuration to current headline."))) + +(defun gptel-org--save-state () + "Write the gptel state to the Org buffer as Org properties." + (org-with-wide-buffer + (goto-char (point-min)) + (when (org-at-heading-p) + (org-open-line 1)) + (gptel-org-set-properties (point-min)) + ;; Save response boundaries + (letrec ((write-bounds + (lambda (attempts) + (let* ((bounds (gptel--get-buffer-bounds)) + (offset (caar bounds)) + (offset-marker (set-marker (make-marker) offset))) + (org-entry-put (point-min) "GPTEL_BOUNDS" + (prin1-to-string (gptel--get-buffer-bounds))) + (when (and (not (= (marker-position offset-marker) offset)) + (> attempts 0)) + (funcall write-bounds (1- attempts))))))) + (funcall write-bounds 6)))) + + +;;; Transforming responses +(defun gptel--convert-markdown->org (str) + "Convert string STR from markdown to org markup. + +This is a very basic converter that handles only a few markup +elements." + (interactive) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (re-search-forward "`+\\|\\*\\{1,2\\}\\|_\\|^#+" nil t) + (pcase (match-string 0) + ;; Handle backticks + ((and (guard (eq (char-before) ?`)) ticks) + (gptel--replace-source-marker (length ticks)) + (save-match-data + (catch 'block-end + (while (search-forward ticks nil t) + (unless (or (eq (char-before (match-beginning 0)) ?`) + (eq (char-after) ?`)) + (gptel--replace-source-marker (length ticks) 'end) + (throw 'block-end nil)))))) + ;; Handle headings + ((and (guard (eq (char-before) ?#)) heading) + (when (looking-at "[[:space:]]") + (delete-region (line-beginning-position) (point)) + (insert (make-string (length heading) ?*)))) + ;; Handle emphasis + ("**" (cond + ;; ((looking-at "\\*\\(?:[[:word:]]\\|\s\\)") + ;; (delete-char 1)) + ((looking-back "\\(?:[[:word:][:punct:]\n]\\|\s\\)\\*\\{2\\}" + (max (- (point) 3) (point-min))) + (delete-char -1)))) + ("*" + (cond + ((save-match-data + (and (looking-back "\\(?:[[:space:]]\\|\s\\)\\(?:_\\|\\*\\)" + (max (- (point) 2) (point-min))) + (not (looking-at "[[:space:]]\\|\s")))) + ;; Possible beginning of emphasis + (and + (save-excursion + (when (and (re-search-forward (regexp-quote (match-string 0)) + (line-end-position) t) + (looking-at "[[:space]]\\|\s") + (not (looking-back "\\(?:[[:space]]\\|\s\\)\\(?:_\\|\\*\\)" + (max (- (point) 2) (point-min))))) + (delete-char -1) (insert "/") t)) + (progn (delete-char -1) (insert "/")))) + ((save-excursion + (ignore-errors (backward-char 2)) + (looking-at "\\(?:$\\|\\`\\)\n\\*[[:space:]]")) + ;; Bullet point, replace with hyphen + (delete-char -1) (insert "-")))))) + (buffer-string))) + +(defun gptel--replace-source-marker (num-ticks &optional end) + "Replace markdown style backticks with Org equivalents. + +NUM-TICKS is the number of backticks being replaced. If END is +true these are \"ending\" backticks. + +This is intended for use in the markdown to org stream converter." + (let ((from (match-beginning 0))) + (delete-region from (point)) + (if (and (= num-ticks 3) + (save-excursion (beginning-of-line) + (skip-chars-forward " \t") + (eq (point) from))) + (insert (if end "#+end_src" "#+begin_src ")) + (insert "=")))) + +(defun gptel--stream-convert-markdown->org () + "Return a Markdown to Org converter. + +This function parses a stream of Markdown text to Org +continuously when it is called with successive chunks of the +text stream." + (letrec ((in-src-block nil) ;explicit nil to address BUG #183 + (temp-buf (generate-new-buffer-name "*gptel-temp*")) + (start-pt (make-marker)) + (ticks-total 0) + (cleanup-fn + (lambda (&rest _) + (when (buffer-live-p (get-buffer temp-buf)) + (set-marker start-pt nil) + (kill-buffer temp-buf)) + (remove-hook 'gptel-post-response-functions cleanup-fn)))) + (add-hook 'gptel-post-response-functions cleanup-fn) + (lambda (str) + (let ((noop-p) (ticks 0)) + (with-current-buffer (get-buffer-create temp-buf) + (save-excursion (goto-char (point-max)) (insert str)) + (when (marker-position start-pt) (goto-char start-pt)) + (when in-src-block (setq ticks ticks-total)) + (save-excursion + (while (re-search-forward "`\\|\\*\\{1,2\\}\\|_\\|^#+" nil t) + (pcase (match-string 0) + ("`" + ;; Count number of consecutive backticks + (backward-char) + (while (and (char-after) (eq (char-after) ?`)) + (forward-char) + (if in-src-block (cl-decf ticks) (cl-incf ticks))) + ;; Set the verbatim state of the parser + (if (and (eobp) + ;; Special case heuristic: If the response ends with + ;; ^``` we don't wait for more input. + ;; FIXME: This can have false positives. + (not (save-excursion (beginning-of-line) + (looking-at "^```$")))) + ;; End of input => there could be more backticks coming, + ;; so we wait for more input + (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) + ;; We reached a character other than a backtick + (cond + ;; Ticks balanced, end src block + ((= ticks 0) + (progn (setq in-src-block nil) + (gptel--replace-source-marker ticks-total 'end))) + ;; Positive number of ticks, start an src block + ((and (> ticks 0) (not in-src-block)) + (setq ticks-total ticks + in-src-block t) + (gptel--replace-source-marker ticks-total)) + ;; Negative number of ticks or in a src block already, + ;; reset ticks + (t (setq ticks ticks-total))))) + ;; Handle other chars: heading, emphasis, bold and bullet items + ((and (guard (and (not in-src-block) (eq (char-before) ?#))) heading) + (if (eobp) + ;; Not enough information about the heading yet + (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) + ;; Convert markdown heading to Org heading + (when (looking-at "[[:space:]]") + (delete-region (line-beginning-position) (point)) + (insert (make-string (length heading) ?*))))) + ((and "**" (guard (not in-src-block))) + (cond + ;; TODO Not sure why this branch was needed + ;; ((looking-at "\\*\\(?:[[:word:]]\\|\s\\)") (delete-char 1)) + + ;; Looking back at "w**" or " **" + ((looking-back "\\(?:[[:word:][:punct:]\n]\\|\s\\)\\*\\{2\\}" + (max (- (point) 3) (point-min))) + (delete-char -1)))) + ((and "*" (guard (not in-src-block))) + (if (eobp) + ;; Not enough information about the "*" yet + (progn (setq noop-p t) (set-marker start-pt (match-beginning 0))) + ;; "*" is either emphasis or a bullet point + (save-match-data + (save-excursion + (ignore-errors (backward-char 2)) + (cond + ((or (looking-at + "[^[:space:][:punct:]\n]\\(?:_\\|\\*\\)\\(?:[[:space:][:punct:]]\\|$\\)") + (looking-at + "\\(?:[[:space:][:punct:]]\\)\\(?:_\\|\\*\\)\\([^[:space:][:punct:]]\\|$\\)")) + ;; Emphasis, replace with slashes + (forward-char 2) (delete-char -1) (insert "/")) + ((looking-at "\\(?:$\\|\\`\\)\n\\*[[:space:]]") + ;; Bullet point, replace with hyphen + (forward-char 2) (delete-char -1) (insert "-")))))))))) + (if noop-p + (buffer-substring (point) start-pt) + (prog1 (buffer-substring (point) (point-max)) + (set-marker start-pt (point-max))))))))) + +(provide 'gptel-org) +;;; gptel-org.el ends here diff --git a/emacs/elpa/gptel-20241115.456/gptel-org.elc b/emacs/elpa/gptel-20241115.456/gptel-org.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241115.456/gptel-pkg.el b/emacs/elpa/gptel-20241115.456/gptel-pkg.el @@ -0,0 +1,12 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "gptel" "20241115.456" + "Interact with ChatGPT or other LLMs." + '((emacs "27.1") + (transient "0.4.0") + (compat "29.1.4.1")) + :url "https://github.com/karthink/gptel" + :commit "51ae43f4edefe0375acbcb836d94d8d0348a531d" + :revdesc "51ae43f4edef" + :keywords '("convenience") + :authors '(("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com")) + :maintainers '(("Karthik Chikmagalur" . "karthik.chikmagalur@gmail.com"))) diff --git a/emacs/elpa/gptel-20241112.624/gptel-privategpt.el b/emacs/elpa/gptel-20241115.456/gptel-privategpt.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-privategpt.elc b/emacs/elpa/gptel-20241115.456/gptel-privategpt.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241112.624/gptel-rewrite.el b/emacs/elpa/gptel-20241115.456/gptel-rewrite.el diff --git a/emacs/elpa/gptel-20241112.624/gptel-rewrite.elc b/emacs/elpa/gptel-20241115.456/gptel-rewrite.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241115.456/gptel-transient.el b/emacs/elpa/gptel-20241115.456/gptel-transient.el @@ -0,0 +1,1054 @@ +;;; gptel-transient.el --- Transient menu for GPTel -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Karthik Chikmagalur + +;; Author: Karthik Chikmagalur <karthikchikmagalur@gmail.com> +;; Keywords: convenience + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; 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: + +;; + +;;; Code: +(require 'cl-lib) +(require 'gptel) +(require 'transient) + +(declare-function ediff-regions-internal "ediff") +(declare-function ediff-make-cloned-buffer "ediff-utils") + + +;; * Helper functions and vars + +(defvar-local gptel--rewrite-overlays nil + "List of active rewrite overlays in the buffer.") + +(defvar gptel--set-buffer-locally nil + "Set model parameters from `gptel-menu' buffer-locally. + +Affects the system message too.") + +(defun gptel--set-with-scope (sym value &optional scope) + "Set SYMBOL's symbol-value to VALUE with SCOPE. + +If SCOPE is non-nil, set it buffer-locally, else clear any +buffer-local value and set its default global value." + (if scope + (set (make-local-variable sym) value) + (kill-local-variable sym) + (set sym value))) + +(defun gptel--get-directive (args) + "Find the additional directive in the transient ARGS. + +Meant to be called when `gptel-menu' is active." + (cl-some (lambda (s) (and (stringp s) (string-prefix-p ":" s) + (substring s 1))) + args)) + +(defun gptel--instructions-make-overlay (text &optional ov) + "Make or move overlay OV with TEXT." + (save-excursion + ;; Move point to overlay position + (cond + ((use-region-p) + (if (pos-visible-in-window-p (region-beginning)) + (goto-char (region-beginning)))) + ((gptel--in-response-p) + (gptel-beginning-of-response) + (skip-chars-forward "\n \t")) + (t (text-property-search-backward 'gptel 'response) + (skip-chars-forward "\n \t"))) + ;; Make overlay + (if (and ov (overlayp ov)) + (move-overlay ov (point) (point) (current-buffer)) + (setq ov (make-overlay (point) (point) nil t))) + (overlay-put ov 'before-string nil) + ;; (unless (or (bobp) (eq (char-before) "\n")) + ;; (overlay-put ov 'before-string (propertize "\n" 'font-lock-face 'shadow))) + (overlay-put ov 'category 'gptel) + (overlay-put + ov 'after-string + (concat (propertize (concat "DIRECTIVE: " text) + 'font-lock-face '(:inherit shadow :weight bold :box t)) + "\n")) + ov)) + +(defun gptel--transient-read-variable (prompt initial-input history) + "Read value from minibuffer and interpret the result as a Lisp object. + +PROMPT, INITIAL-INPUT and HISTORY are as in the Transient reader +documention." + (ignore-errors + (read-from-minibuffer prompt initial-input read-expression-map t history))) + +(defsubst gptel--refactor-or-rewrite () + "Rewrite should be refactored into refactor. + +Or is it the other way around?" + (if (derived-mode-p 'prog-mode) + "Refactor" "Rewrite")) + +(defun gptel--format-system-message (&optional message) + "Format the system MESSAGE for display in gptel's transient menus." + (setq message (or message gptel--system-message)) + (if (gptel--model-capable-p 'nosystem) + (concat (propertize "[No system message support for model " + 'face 'transient-heading) + (propertize (gptel--model-name gptel-model) + 'face 'warning) + (propertize "]" 'face 'transient-heading)) + (if message + (cl-etypecase message + (string (string-replace + "\n" "⮐ " + (truncate-string-to-width + message + (max (- (window-width) 12) 14) nil nil t))) + (function (gptel--format-system-message (funcall message))) + (list (gptel--format-system-message (car message)))) + "[No system message set]"))) + +(defvar gptel--crowdsourced-prompts-url + "https://raw.githubusercontent.com/f/awesome-chatgpt-prompts/main/prompts.csv" + "URL for crowdsourced LLM system prompts.") + +(defvar gptel--crowdsourced-prompts + (make-hash-table :test #'equal) + "Crowdsourced LLM system prompts.") + +(defun gptel--crowdsourced-prompts () + "Acquire and read crowdsourced LLM system prompts. + +These are stored in the variable `gptel--crowdsourced-prompts', +which see." + (when (hash-table-p gptel--crowdsourced-prompts) + (when (hash-table-empty-p gptel--crowdsourced-prompts) + (unless gptel-crowdsourced-prompts-file + (run-at-time 0 nil #'gptel-system-prompt) + (user-error "No crowdsourced prompts available")) + (unless (and (file-exists-p gptel-crowdsourced-prompts-file) + (time-less-p + (time-subtract (current-time) (days-to-time 14)) + (file-attribute-modification-time + (file-attributes gptel-crowdsourced-prompts-file)))) + (when (y-or-n-p + (concat + "Fetch crowdsourced system prompts from " + (propertize "https://github.com/f/awesome-chatgpt-prompts" 'face 'link) + "?")) + ;; Fetch file + (message "Fetching prompts...") + (let ((dir (file-name-directory gptel-crowdsourced-prompts-file))) + (unless (file-exists-p dir) (mkdir dir 'create-parents)) + (if (url-copy-file gptel--crowdsourced-prompts-url + gptel-crowdsourced-prompts-file + 'ok-if-already-exists) + (message "Fetching prompts... done.") + (message "Could not retrieve new prompts."))))) + (if (not (file-readable-p gptel-crowdsourced-prompts-file)) + (progn (message "No crowdsourced prompts available") + (call-interactively #'gptel-system-prompt)) + (with-temp-buffer + (insert-file-contents gptel-crowdsourced-prompts-file) + (goto-char (point-min)) + (forward-line 1) + (while (not (eobp)) + (when-let ((act (read (current-buffer)))) + (forward-char) + (save-excursion + (while (re-search-forward "\"\"" (line-end-position) t) + (replace-match "\\\\\""))) + (when-let ((prompt (read (current-buffer)))) + (puthash act prompt gptel--crowdsourced-prompts))) + (forward-line 1))))) + gptel--crowdsourced-prompts)) + + +;; * Transient classes and methods for gptel + +(defclass gptel-lisp-variable (transient-lisp-variable) + ((display-nil :initarg :display-nil) ;String to display if value if nil + (display-map :initarg :display-map :initform nil)) ;Display string from alist display-map + "Lisp variables that show :display-nil instead of nil.") + +(cl-defmethod transient-format-value ((obj gptel-lisp-variable)) + (let ((display-value + (with-slots (value display-nil display-map) obj + (cond ((null value) display-nil) + (display-map (cdr (assoc value display-map))) + (t value))))) + (propertize + (if (stringp display-value) display-value (prin1-to-string display-value)) + 'face 'transient-value))) + +(cl-defmethod transient-infix-set ((obj gptel-lisp-variable) value) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value value) + gptel--set-buffer-locally)) + +(defclass gptel--switches (gptel-lisp-variable) + ((display-if-true :initarg :display-if-true :initform "True") + (display-if-false :initarg :display-if-false :initform "False")) + "Boolean lisp variable class for gptel-transient.") + +(cl-defmethod transient-infix-read ((obj gptel--switches)) + "Cycle through the mutually exclusive switches." + (not (oref obj value))) + +(cl-defmethod transient-format-value ((obj gptel--switches)) + (with-slots (value display-if-true display-if-false) obj + (format + (propertize "(%s)" 'face 'transient-delimiter) + (concat + (propertize display-if-false + 'face (if value 'transient-inactive-value 'transient-value)) + (propertize "|" 'face 'transient-delimiter) + (propertize display-if-true + 'face (if value 'transient-value 'transient-inactive-value)))))) + +(defclass gptel--scope (gptel--switches) + ((display-if-true :initarg :display-if-true :initform "for this buffer") + (display-if-false :initarg :display-if-false :initform "globally")) + "Singleton lisp variable class for `gptel--set-buffer-locally'. + +This is used only for setting this variable via `gptel-menu'.") + +(cl-defmethod transient-infix-set ((obj gptel--scope) value) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value value))) + +(defclass gptel-provider-variable (transient-lisp-variable) + ((model :initarg :model) + (model-value :initarg :model-value) + (always-read :initform t) + (set-value :initarg :set-value :initform #'set)) + "Class used for gptel-backends.") + +(cl-defmethod transient-format-value ((obj gptel-provider-variable)) + (propertize (concat + (gptel-backend-name (oref obj value)) ":" + (gptel--model-name + (buffer-local-value (oref obj model) transient--original-buffer))) + 'face 'transient-value)) + +(cl-defmethod transient-infix-set ((obj gptel-provider-variable) value) + (pcase-let ((`(,backend-value ,model-value) value)) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value backend-value) + gptel--set-buffer-locally) + (funcall (oref obj set-value) + (oref obj model) + (oset obj model-value model-value) + gptel--set-buffer-locally)) + (transient-setup)) + +(defclass gptel-option-overlaid (transient-option) + ((display-nil :initarg :display-nil) + (overlay :initarg :overlay)) + "Transient options for overlays displayed in the working buffer.") + +(cl-defmethod transient-format-value ((obj gptel-option-overlaid)) + "set up the in-buffer overlay for additional directive, a string. + +Also format its value in the Transient menu." + (let ((value (oref obj value)) + (ov (oref obj overlay)) + (argument (oref obj argument))) + ;; Making an overlay + (if (or (not value) (string-empty-p value)) + (when ov (delete-overlay ov)) + (with-current-buffer transient--original-buffer + (oset obj overlay (gptel--instructions-make-overlay value ov))) + (letrec ((ov-clear-hook + (lambda () (when-let* ((ov (oref obj overlay)) + ((overlayp ov))) + (remove-hook 'transient-exit-hook + ov-clear-hook) + (delete-overlay ov))))) + (add-hook 'transient-exit-hook ov-clear-hook))) + ;; Updating transient menu display + (if value + (propertize (concat argument (truncate-string-to-width value 25 nil nil "...")) + 'face 'transient-value) + (propertize + (concat "(" (symbol-name (oref obj display-nil)) ")") + 'face 'transient-inactive-value)))) + + +;; * Transient Prefixes + +(define-obsolete-function-alias 'gptel-send-menu 'gptel-menu "0.3.2") + +;; BUG: The `:incompatible' spec doesn't work if there's a `:description' below it. +;;;###autoload (autoload 'gptel-menu "gptel-transient" nil t) +(transient-define-prefix gptel-menu () + "Change parameters of prompt to send to the LLM." + ;; :incompatible '(("-m" "-n" "-k" "-e")) + [:description gptel--format-system-message + ["" + :if (lambda () (not (gptel--model-capable-p 'nosystem))) + "Instructions" + ("s" "Set system message" gptel-system-prompt :transient t) + (gptel--infix-add-directive)] + [:pad-keys t + "" + "Context" + (gptel--infix-context-add-region) + (gptel--infix-context-add-buffer) + (gptel--infix-context-add-file) + (gptel--suffix-context-buffer)]] + [["Request Parameters" + :pad-keys t + (gptel--infix-variable-scope) + (gptel--infix-provider) + (gptel--infix-max-tokens) + (gptel--infix-num-messages-to-send + :if (lambda () (or gptel-mode gptel-track-response))) + (gptel--infix-temperature :if (lambda () gptel-expert-commands)) + (gptel--infix-use-context) + (gptel--infix-track-response + :if (lambda () (and gptel-expert-commands (not gptel-mode)))) + (gptel--infix-track-media + :if (lambda () (and gptel-mode (gptel--model-capable-p 'media))))] + ["Prompt from" + ("m" "Minibuffer instead" "m") + ("y" "Kill-ring instead" "y") + "" + ("i" "Respond in place" "i")] + ["Response to" + ("e" "Echo area instead" "e") + ("g" "gptel session" "g" + :class transient-option + :prompt "Existing or new gptel session: " + :reader + (lambda (prompt _ _history) + (read-buffer + prompt (generate-new-buffer-name + (concat "*" (gptel-backend-name gptel-backend) "*")) + nil (lambda (buf-name) + (if (consp buf-name) (setq buf-name (car buf-name))) + (let ((buf (get-buffer buf-name))) + (and (buffer-local-value 'gptel-mode buf) + (not (eq (current-buffer) buf)))))))) + ("b" "Any buffer" "b" + :class transient-option + :prompt "Output to buffer: " + :reader + (lambda (prompt _ _history) + (read-buffer prompt (buffer-name (other-buffer)) nil))) + ("k" "Kill-ring" "k")]] + [["Send" + (gptel--suffix-send) + ("M-RET" "Regenerate" gptel--regenerate :if gptel--in-response-p)] + [:description (lambda () + (concat + (and gptel--rewrite-overlays "Continue ") + (gptel--refactor-or-rewrite))) + :if (lambda () (or gptel--rewrite-overlays (use-region-p))) + ("r" + ;;FIXME: Transient complains if I use `gptel--refactor-or-rewrite' here. It + ;;reads this function as a suffix instead of a function that returns the + ;;description. + (lambda () (if (derived-mode-p 'prog-mode) + "Refactor" "Rewrite")) + gptel-rewrite-menu)] + ["Tweak Response" :if gptel--in-response-p :pad-keys t + ("SPC" "Mark" gptel--mark-response) + ("P" "Previous variant" gptel--previous-variant + :if gptel--at-response-history-p + :transient t) + ("N" "Next variant" gptel--previous-variant + :if gptel--at-response-history-p + :transient t) + ("E" "Ediff previous" gptel--ediff + :if gptel--at-response-history-p)] + ["Dry Run" :if (lambda () (or gptel-log-level gptel-expert-commands)) + ("I" "Inspect query (Lisp)" + (lambda () + "Inspect the query that will be sent as a lisp object." + (interactive) + (gptel--sanitize-model) + (gptel--inspect-query + (gptel--suffix-send + (cons "I" (transient-args transient-current-command)))))) + ("J" "Inspect query (JSON)" + (lambda () + "Inspect the query that will be sent as a JSON object." + (interactive) + (gptel--sanitize-model) + (gptel--inspect-query + (gptel--suffix-send + (cons "I" (transient-args transient-current-command))) + 'json)))]] + (interactive) + (gptel--sanitize-model) + (transient-setup 'gptel-menu)) + +;; ** Prefix for setting the system prompt. +(defun gptel-system-prompt--setup (_) + "Set up suffixes for system prompt." + (transient-parse-suffixes + 'gptel-system-prompt + (cl-loop for (type . prompt) in gptel-directives + ;; Avoid clashes with the custom directive key + with unused-keys = (delete ?s (number-sequence ?a ?z)) + with width = (window-width) + for name = (symbol-name type) + for key = (seq-find (lambda (k) (member k unused-keys)) name (seq-first unused-keys)) + do (setq unused-keys (delete key unused-keys)) + ;; The explicit declaration ":transient transient--do-return" here + ;; appears to be required for Transient v0.5 and up. Without it, these + ;; are treated as suffixes when invoking `gptel-system-prompt' directly, + ;; and infixes when going through `gptel-menu'. + ;; TODO: Raise an issue with Transient. + collect (list (key-description (list key)) + (concat (capitalize name) " " + (propertize " " 'display '(space :align-to 20)) + (propertize + (concat + "(" + (string-replace + "\n" " " + (truncate-string-to-width prompt (- width 30) nil nil t)) + ")") + 'face 'shadow)) + `(lambda () (interactive) + (message "Directive: %s" + ,(string-replace "\n" "⮐ " + (truncate-string-to-width prompt 100 nil nil t))) + (gptel--set-with-scope 'gptel--system-message ,prompt + gptel--set-buffer-locally)) + :transient 'transient--do-return) + into prompt-suffixes + finally return + (nconc + prompt-suffixes + (list (list "DEL" "None" + (lambda () (interactive) + (message "Directive unset") + (gptel--set-with-scope 'gptel--system-message nil + gptel--set-buffer-locally)) + :transient 'transient--do-return) + (list "SPC" "Pick crowdsourced prompt" + 'gptel--read-crowdsourced-prompt + ;; NOTE: Quitting the completing read when picking a + ;; crowdsourced prompt will cause the transient to exit + ;; instead of returning to the system prompt menu. + :transient 'transient--do-exit)))))) + +;;;###autoload (autoload 'gptel-system-prompt "gptel-transient" nil t) +(transient-define-prefix gptel-system-prompt () + "Set the LLM system message for LLM interactions in this buffer. + +The \"system message\" establishes directives for the chat +session and modifies the behavior of the LLM. Some examples of +system prompts are: + +You are a helpful assistant. Answer as concisely as possible. +Reply only with shell commands and no prose. +You are a poet. Reply only in verse. + +More extensive system messages can be useful for specific tasks. + +Customize `gptel-directives' for task-specific prompts." + [:description gptel--format-system-message + [(gptel--suffix-system-message)] + [(gptel--infix-variable-scope)]] + [:class transient-column + :setup-children gptel-system-prompt--setup + :pad-keys t]) + + +;; * Transient Infixes + +;; ** Infixes for context aggregation + +(transient-define-infix gptel--infix-use-context () + "Describe target destination for context injection. + +gptel will include with the LLM request any additional context +added with `gptel-add'. This context can be ignored, included +with the system message or included with the user prompt. + +Where in the request this context is included depends on the +value of `gptel-use-context', set from here." + :description "Include context" + :class 'gptel-lisp-variable + :variable 'gptel-use-context + :format " %k %d %v" + :set-value #'gptel--set-with-scope + :display-nil "No" + :display-map '((nil . "No") + (system . "with system message") + (user . "with user prompt")) + :key "-i" + :reader (lambda (prompt &rest _) + (let* ((choices '(("No" . nil) + ("with system message" . system) + ("with user prompt" . user))) + (destination (completing-read prompt choices nil t))) + (cdr (assoc destination choices))))) + +;; ** Infixes for model parameters + +(transient-define-infix gptel--infix-variable-scope () + "Set gptel's model parameters and system message in this buffer or globally." + :argument "scope" + :variable 'gptel--set-buffer-locally + :class 'gptel--scope + :format " %k %d %v" + :key "=" + :description (propertize "Set" 'face 'transient-inactive-argument)) + +(transient-define-infix gptel--infix-num-messages-to-send () + "Number of recent messages to send with each exchange. + +By default, the full conversation history is sent with every new +prompt. This retains the full context of the conversation, but +can be expensive in token size. Set how many recent messages to +include." + :description "previous responses" + :class 'gptel-lisp-variable + :variable 'gptel--num-messages-to-send + :set-value #'gptel--set-with-scope + :display-nil 'all + :format " %k %v %d" + :key "-n" + :prompt "Number of past messages to include for context (leave empty for all): " + :reader 'gptel--transient-read-variable) + +(transient-define-infix gptel--infix-max-tokens () + "Max tokens per response. + +This is roughly the number of words in the response. 100-300 is a +reasonable range for short answers, 400 or more for longer +responses." + :description "Response length (tokens)" + :class 'gptel-lisp-variable + :variable 'gptel-max-tokens + :set-value #'gptel--set-with-scope + :display-nil 'auto + :key "-c" + :prompt "Response length in tokens (leave empty: default, 80-200: short, 200-500: long): " + :reader 'gptel--transient-read-variable) + +(transient-define-infix gptel--infix-provider () + "AI Provider for Chat." + :description "GPT Model" + :class 'gptel-provider-variable + :prompt "Model: " + :variable 'gptel-backend + :set-value #'gptel--set-with-scope + :model 'gptel-model + :key "-m" + :reader (lambda (prompt &rest _) + (cl-loop + for (name . backend) in gptel--known-backends + nconc (cl-loop for model in (gptel-backend-models backend) + collect (list (concat name ":" (gptel--model-name model)) + backend model)) + into models-alist + with completion-extra-properties = + `(:annotation-function + ,(lambda (comp) + (let* ((model (nth 2 (assoc comp models-alist))) + (desc (get model :description)) + (caps (get model :capabilities)) + (context (get model :context-window)) + (input-cost (get model :input-cost)) + (output-cost (get model :output-cost)) + (cutoff (get model :cutoff-date))) + (when (or desc caps context input-cost output-cost cutoff) + (concat + (propertize " " 'display `(space :align-to 40)) + (when desc (truncate-string-to-width desc 70 nil ? t t)) + " " (propertize " " 'display `(space :align-to 112)) + (when caps (truncate-string-to-width (prin1-to-string caps) 21 nil ? t t)) + " " (propertize " " 'display `(space :align-to 134)) + (when context (format "%5dk" context)) + " " (propertize " " 'display `(space :align-to 142)) + (when input-cost (format "$%5.2f in" input-cost)) + (if (and input-cost output-cost) "," " ") + " " (propertize " " 'display `(space :align-to 153)) + (when output-cost (format "$%6.2f out" output-cost)) + " " (propertize " " 'display `(space :align-to 166)) + cutoff))))) + finally return + (cdr (assoc (completing-read prompt models-alist nil t) + models-alist))))) + +(transient-define-infix gptel--infix-temperature () + "Temperature of request." + :description "Temperature (0 - 2.0)" + :class 'gptel-lisp-variable + :variable 'gptel-temperature + :set-value #'gptel--set-with-scope + :key "-t" + :prompt "Temperature controls the response randomness (0.0-2.0, leave empty for default): " + :reader 'gptel--transient-read-variable) + +(transient-define-infix gptel--infix-track-response () + "Distinguish between user messages and LLM responses. + +When creating a prompt to send to the LLM, gptel distinguishes +between text entered by the user and past LLM responses. This is +required for multi-turn conversations, and is always the case in +dedicated chat buffers (in `gptel-mode'). + +In regular buffers, you can toggle this behavior here or by +customizing `gptel-track-response'. When response tracking is +turned off, all text will be assigned the \"user\" role when +querying the LLM." + :description "Track LLM responses" + :class 'gptel--switches + :variable 'gptel-track-response + :set-value #'gptel--set-with-scope + :display-if-true "Yes" + :display-if-false "No" + :key "-d") + +(transient-define-infix gptel--infix-track-media () + "Send media from \"standalone\" links in the prompt. + +When the active `gptel-model' supports it, gptel can send images +or other media from links in the buffer to the LLM. Only +\"standalone\" links are considered: these are links on their own +line with no surrounding text. + +What link types are sent depends on the mime-types the model +supports. See `gptel-track-media' for more information." + :description "Send media from links" + :class 'gptel--switches + :variable 'gptel-track-media + :set-value #'gptel--set-with-scope + :display-if-true "Yes" + :display-if-false "No" + :key "-I") + +;; ** Infixes for adding and removing context + +(declare-function gptel-context--at-point "gptel-context") +(declare-function gptel-add "gptel-context") + +(transient-define-suffix gptel--infix-context-add-region () + "Add current region to gptel's context." + :transient 'transient--do-stay + :key "-r" + :if (lambda () (or (use-region-p) + (and (fboundp 'gptel-context--at-point) + (gptel-context--at-point)))) + :description + (lambda () + (if (and (fboundp 'gptel-context--at-point) + (gptel-context--at-point)) + "Remove context at point" + "Add region to context")) + (interactive) + (gptel-add) + (transient-setup)) + +(transient-define-suffix gptel--infix-context-add-buffer () + "Add a buffer to gptel's context." + :transient 'transient--do-stay + :key "-b" + :description "Add a buffer to context" + (interactive) + (gptel-add '(4)) + (transient-setup)) + +(declare-function gptel-add-file "gptel-context") + +(transient-define-suffix gptel--infix-context-add-file () + "Add a file to gptel's context." + :transient 'transient--do-stay + :key "-f" + :description "Add a file to context" + (interactive) + (call-interactively #'gptel-add-file) + (transient-setup)) + +;; ** Infix for the refactor/rewrite system message + +(transient-define-infix gptel--infix-add-directive () + "Additional directive intended for the next query only. + +This is useful to define a quick task on top of a more extensive +or detailed system message. + +For example, with code/text selected: + +- Rewrite this function to do X while avoiding Y. +- Change the tone of the following paragraph to be more direct. + +Or in an extended conversation: + +- Phrase you next response in ten words or less. +- Pretend for now that you're an anthropologist." + :class 'gptel-option-overlaid + ;; :variable 'gptel--instructions + :display-nil 'none + :overlay nil + :argument ":" + :prompt "Instructions for next response only: " + :reader (lambda (prompt initial history) + (let* ((extra (read-string prompt initial history))) + (unless (string-empty-p extra) extra))) + :format " %k %d %v" + :key "d" + :argument ":" + :description "Add directive" + :transient t) + + +;; * Transient Suffixes + +;; ** Suffix to send prompt + +(transient-define-suffix gptel--suffix-send (args) + "Send ARGS." + :key "RET" + :description "Send prompt" + (interactive (list (transient-args + (or transient-current-command 'gptel-menu)))) + (let ((stream gptel-stream) + (in-place (and (member "i" args) t)) + (output-to-other-buffer-p) + (backend gptel-backend) + (model gptel-model) + (backend-name (gptel-backend-name gptel-backend)) + (buffer) (position) + (callback) (gptel-buffer-name) + (system-extra (gptel--get-directive args)) + (dry-run (and (member "I" args) t)) + ;; Input redirection: grab prompt from elsewhere? + (prompt + (cond + ((member "m" args) + (read-string + (format "Ask %s: " (gptel-backend-name gptel-backend)) + (and (use-region-p) + (buffer-substring-no-properties + (region-beginning) (region-end))))) + ((member "y" args) + (unless (car-safe kill-ring) + (user-error "`kill-ring' is empty! Nothing to send")) + (if current-prefix-arg + (read-from-kill-ring "Prompt from kill-ring: ") + (current-kill 0)))))) + + ;; Output redirection: Send response elsewhere? + (cond + ((member "e" args) + (setq stream nil) + (setq callback + (lambda (resp info) + (if resp + (message "%s response: %s" backend-name resp) + (message "%s response error: %s" backend-name (plist-get info :status)))))) + ((member "k" args) + (setq stream nil) + (setq callback + (lambda (resp info) + (if (not resp) + (message "%s response error: %s" backend-name (plist-get info :status)) + (kill-new resp) + (message "%s response: \"%s\" copied to kill-ring." + backend-name + (truncate-string-to-width resp 30)))))) + ((setq gptel-buffer-name + (cl-some (lambda (s) (and (stringp s) (string-prefix-p "g" s) + (substring s 1))) + args)) + (setq output-to-other-buffer-p t) + (let ((reduced-prompt ;For inserting into the gptel buffer as + ;context, not the prompt used for the + ;request itself + (or prompt + (if (use-region-p) + (buffer-substring-no-properties (region-beginning) + (region-end)) + (buffer-substring-no-properties + (save-excursion + (text-property-search-backward + 'gptel 'response + (when (get-char-property (max (point-min) (1- (point))) + 'gptel) + t)) + (point)) + (gptel--at-word-end (point))))))) + (cond + ((buffer-live-p (get-buffer gptel-buffer-name)) + ;; Insert into existing gptel session + (progn + (setq buffer (get-buffer gptel-buffer-name)) + (with-current-buffer buffer + (goto-char (point-max)) + (unless (or buffer-read-only + (get-char-property (point) 'read-only)) + (insert reduced-prompt)) + (setq position (point)) + (when gptel-mode + (gptel--update-status " Waiting..." 'warning))))) + ;; Insert into new gptel session + (t (setq buffer + (gptel gptel-buffer-name + (condition-case nil + (gptel--get-api-key) + ((error user-error) + (setq gptel-api-key + (read-passwd + (format "%s API key: " + (gptel-backend-name + gptel-backend)))))) + reduced-prompt)) + ;; Set backend and model in new session from current buffer + (with-current-buffer buffer + (setq gptel-backend backend) + (setq gptel-model model) + (gptel--update-status " Waiting..." 'warning) + (setq position (point))))))) + ((setq gptel-buffer-name + (cl-some (lambda (s) (and (stringp s) (string-prefix-p "b" s) + (substring s 1))) + args)) + (setq output-to-other-buffer-p t) + (setq buffer (get-buffer-create gptel-buffer-name)) + (with-current-buffer buffer (setq position (point))))) + + (prog1 (gptel-request prompt + :buffer (or buffer (current-buffer)) + :position position + :in-place (and in-place (not output-to-other-buffer-p)) + :stream stream + :system (if system-extra + (concat (if gptel--system-message + (concat gptel--system-message "\n\n")) + system-extra) + gptel--system-message) + :callback callback + :dry-run dry-run) + + (gptel--update-status " Waiting..." 'warning) + + ;; NOTE: Possible future race condition here if Emacs ever drops the GIL. + ;; The HTTP request callback might modify the buffer before the in-place + ;; text is killed below. + (when in-place + ;; Kill the latest prompt + (let ((beg + (if (use-region-p) + (region-beginning) + (save-excursion + (text-property-search-backward + 'gptel 'response + (when (get-char-property (max (point-min) (1- (point))) + 'gptel) + t)) + (point)))) + (end (if (use-region-p) (region-end) (point)))) + (unless output-to-other-buffer-p + ;; store the killed text in gptel-history + (gptel--attach-response-history + (list (buffer-substring-no-properties beg end)))) + (kill-region beg end))) + + (when output-to-other-buffer-p + (message (concat "Prompt sent to buffer: " + (propertize gptel-buffer-name 'face 'help-key-binding))) + (display-buffer + buffer '((display-buffer-reuse-window + display-buffer-pop-up-window) + (reusable-frames . visible))))))) + +;; Allow calling from elisp +(put 'gptel--suffix-send 'interactive-only nil) + +;; ** Suffix to regenerate response + +(defun gptel--regenerate () + "Regenerate gptel response at point." + (interactive) + (when (gptel--in-response-p) + (pcase-let* ((`(,beg . ,end) (gptel--get-bounds)) + (history (get-char-property (point) 'gptel-history)) + (prev-responses (cons (buffer-substring-no-properties beg end) + history))) + (when gptel-mode ;Remove prefix/suffix + (save-excursion + (goto-char beg) + (when (looking-back (concat "\n+" (regexp-quote (gptel-response-prefix-string))) + (point-min) 'greedy) + (setq beg (match-beginning 0))) + (goto-char end) + (when (looking-at + (concat "\n+" (regexp-quote (gptel-prompt-prefix-string)))) + (setq end (match-end 0))))) + (delete-region beg end) + (gptel--attach-response-history prev-responses) + (call-interactively #'gptel--suffix-send)))) + +;; ** Set system message +(defun gptel--read-crowdsourced-prompt () + "Pick a crowdsourced system prompt for gptel. + +This uses the prompts in the variable +`gptel--crowdsourced-prompts', which see." + (interactive) + (if (not (hash-table-empty-p (gptel--crowdsourced-prompts))) + (let ((choice + (completing-read + "Pick and edit prompt: " + (lambda (str pred action) + (if (eq action 'metadata) + `(metadata + (affixation-function . + (lambda (cands) + (mapcar + (lambda (c) + (list c "" + (concat (propertize " " 'display '(space :align-to 22)) + " " (propertize (gethash c gptel--crowdsourced-prompts) + 'face 'completions-annotations)))) + cands)))) + (complete-with-action action gptel--crowdsourced-prompts str pred))) + nil t))) + (when-let ((prompt (gethash choice gptel--crowdsourced-prompts))) + (setq gptel--system-message prompt) + (call-interactively #'gptel--suffix-system-message))) + (message "No prompts available."))) + +(transient-define-suffix gptel--suffix-system-message () + "Edit LLM system message. + +When LOCAL is non-nil, set the system message only in the current buffer." + :transient 'transient--do-exit + :description "Set or edit system message" + :format " %k %d" + :key "s" + (interactive) + (let ((orig-buf (current-buffer)) + (msg-start (make-marker))) + (with-current-buffer (get-buffer-create "*gptel-system*") + (let ((inhibit-read-only t)) + (erase-buffer) + (text-mode) + (setq header-line-format + (concat + "Edit your system message below and press " + (propertize "C-c C-c" 'face 'help-key-binding) + " when ready, or " + (propertize "C-c C-k" 'face 'help-key-binding) + " to abort.")) + (insert + "# Example: You are a helpful assistant. Answer as concisely as possible.\n" + "# Example: Reply only with shell commands and no prose.\n" + "# Example: You are a poet. Reply only in verse.\n\n") + (add-text-properties + (point-min) (1- (point)) + (list 'read-only t 'face 'font-lock-comment-face)) + ;; TODO: make-separator-line requires Emacs 28.1+. + ;; (insert (propertize (make-separator-line) 'rear-nonsticky t)) + (set-marker msg-start (point)) + (save-excursion + (insert (or (buffer-local-value 'gptel--system-message orig-buf) "")) + (push-mark nil 'nomsg)) + (activate-mark)) + (display-buffer (current-buffer) + `((display-buffer-below-selected) + (body-function . ,#'select-window) + (window-height . ,#'fit-window-to-buffer))) + (let ((quit-to-menu + (lambda () + "Cancel system message update and return to `gptel-menu'" + (interactive) + (quit-window) + (display-buffer + orig-buf + `((display-buffer-reuse-window + display-buffer-use-some-window) + (body-function . ,#'select-window))) + (call-interactively #'gptel-menu)))) + (use-local-map + (make-composed-keymap + (define-keymap + "C-c C-c" (lambda () + "Confirm system message and return to `gptel-menu'." + (interactive) + (let ((system-message + (buffer-substring-no-properties msg-start (point-max)))) + (with-current-buffer orig-buf + (gptel--set-with-scope 'gptel--system-message system-message + gptel--set-buffer-locally))) + (funcall quit-to-menu)) + "C-c C-k" quit-to-menu) + text-mode-map)))))) + +;; ** Suffix for displaying and removing context +(declare-function gptel-context--buffer-setup "gptel-context") +(declare-function gptel-context--collect "gptel-context") + +(transient-define-suffix gptel--suffix-context-buffer () + "Display all contexts from all buffers & files." + :transient 'transient--do-exit + :key " C" + :if (lambda () gptel-context--alist) + :description + (lambda () + (pcase-let* + ((contexts (and gptel-context--alist (gptel-context--collect))) + (buffer-count (length contexts)) + (`(,file-count ,ov-count) + (if (> buffer-count 0) + (cl-loop for (buf-file . ovs) in contexts + if (bufferp buf-file) + sum (length ovs) into ov-count + else count (stringp buf-file) into file-count + finally return (list file-count ov-count)) + (list 0 0)))) + (concat "Inspect " + (format + (propertize "(%s)" 'face 'transient-delimiter) + (propertize + (concat + (and (> ov-count 0) + (format "%d region%s in %d buffer%s" + ov-count (if (> ov-count 1) "s" "") + (- buffer-count file-count) + (if (> ( - buffer-count file-count) 1) "s" ""))) + (and (> file-count 0) + (propertize + (format "%s%d file%s" + (if (> ov-count 0) ", " "") file-count + (if (> file-count 1) "s" ""))))) + 'face (if (zerop (length contexts)) + 'transient-inactive-value + 'transient-value)))))) + (interactive) + (gptel-context--buffer-setup)) + +(provide 'gptel-transient) +;;; gptel-transient.el ends here + +;; Local Variables: +;; outline-regexp: "^;; \\*+" +;; eval: (outline-minor-mode 1) +;; End: diff --git a/emacs/elpa/gptel-20241115.456/gptel-transient.elc b/emacs/elpa/gptel-20241115.456/gptel-transient.elc Binary files differ. diff --git a/emacs/elpa/gptel-20241115.456/gptel.el b/emacs/elpa/gptel-20241115.456/gptel.el @@ -0,0 +1,1888 @@ +;;; gptel.el --- Interact with ChatGPT or other LLMs -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Karthik Chikmagalur + +;; Author: Karthik Chikmagalur <karthik.chikmagalur@gmail.com> +;; Package-Version: 20241115.456 +;; Package-Revision: 51ae43f4edef +;; Package-Requires: ((emacs "27.1") (transient "0.4.0") (compat "29.1.4.1")) +;; Keywords: convenience +;; URL: https://github.com/karthink/gptel + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; 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/>. + +;; This file is NOT part of GNU Emacs. + +;;; Commentary: + +;; gptel is a simple Large Language Model chat client, with support for multiple +;; models and backends. +;; +;; It works in the spirit of Emacs, available at any time and in any buffer. +;; +;; gptel supports +;; +;; - The services ChatGPT, Azure, Gemini, Anthropic AI, Anyscale, Together.ai, +;; Perplexity, Anyscale, OpenRouter, Groq, PrivateGPT, DeepSeek, Cerebras, +;; Github Models and Kagi (FastGPT & Summarizer) +;; - Local models via Ollama, Llama.cpp, Llamafiles or GPT4All +;; +;; Additionally, any LLM service (local or remote) that provides an +;; OpenAI-compatible API is supported. +;; +;; Features: +;; - It’s async and fast, streams responses. +;; - Interact with LLMs from anywhere in Emacs (any buffer, shell, minibuffer, +;; wherever) +;; - LLM responses are in Markdown or Org markup. +;; - Supports conversations and multiple independent sessions. +;; - Supports multi-modal models (send images, documents). +;; - Save chats as regular Markdown/Org/Text files and resume them later. +;; - You can go back and edit your previous prompts or LLM responses when +;; continuing a conversation. These will be fed back to the model. +;; - Redirect prompts and responses easily +;; - Rewrite, refactor or fill in regions in buffers +;; - Write your own commands for custom tasks with a simple API. +;; +;; Requirements for ChatGPT, Azure, Gemini or Kagi: +;; +;; - You need an appropriate API key. Set the variable `gptel-api-key' to the +;; key or to a function of no arguments that returns the key. (It tries to +;; use `auth-source' by default) +;; +;; ChatGPT is configured out of the box. For the other sources: +;; +;; - For Azure: define a gptel-backend with `gptel-make-azure', which see. +;; - For Gemini: define a gptel-backend with `gptel-make-gemini', which see. +;; - For Anthropic (Claude): define a gptel-backend with `gptel-make-anthropic', +;; which see +;; - For Together.ai, Anyscale, Perplexity, Groq, OpenRouter, DeepSeek, Cerebras or +;; Github Models: define a gptel-backend with `gptel-make-openai', which see. +;; - For PrivateGPT: define a backend with `gptel-make-privategpt', which see. +;; - For Kagi: define a gptel-backend with `gptel-make-kagi', which see. +;; +;; For local models using Ollama, Llama.cpp or GPT4All: +;; +;; - The model has to be running on an accessible address (or localhost) +;; - Define a gptel-backend with `gptel-make-ollama' or `gptel-make-gpt4all', +;; which see. +;; - Llama.cpp or Llamafiles: Define a gptel-backend with `gptel-make-openai', +;; +;; Consult the package README for examples and more help with configuring +;; backends. +;; +;; Usage: +;; +;; gptel can be used in any buffer or in a dedicated chat buffer. The +;; interaction model is simple: Type in a query and the response will be +;; inserted below. You can continue the conversation by typing below the +;; response. +;; +;; To use this in any buffer: +;; +;; - Call `gptel-send' to send the buffer's text up to the cursor. Select a +;; region to send only the region. +;; +;; - You can select previous prompts and responses to continue the conversation. +;; +;; - Call `gptel-send' with a prefix argument to access a menu where you can set +;; your backend, model and other parameters, or to redirect the +;; prompt/response. +;; +;; To use this in a dedicated buffer: +;; +;; - M-x gptel: Start a chat session +;; +;; - In the chat session: Press `C-c RET' (`gptel-send') to send your prompt. +;; Use a prefix argument (`C-u C-c RET') to access a menu. In this menu you +;; can set chat parameters like the system directives, active backend or +;; model, or choose to redirect the input or output elsewhere (such as to the +;; kill ring). +;; +;; - You can save this buffer to a file. When opening this file, turn on +;; `gptel-mode' before editing it to restore the conversation state and +;; continue chatting. +;; +;; - To include media files with your request, you can add them to the context +;; (described next), or include them as links in Org or Markdown mode chat +;; buffers. Sending media is disabled by default, you can turn it on globally +;; via `gptel-track-media', or locally in a chat buffer via the header line. +;; +;; Include more context with requests: +;; +;; If you want to provide the LLM with more context, you can add arbitrary +;; regions, buffers or files to the query with `gptel-add'. To add text or +;; media files, call `gptel-add' in Dired or use the dedicated `gptel-add-file'. +;; +;; You can also add context from gptel's menu instead (gptel-send with a prefix +;; arg), as well as examine or modify context. +;; +;; When context is available, gptel will include it with each LLM query. +;; +;; Rewrite/refactor interface +;; +;; In any buffer: with a region selected, you can rewrite prose, refactor code +;; or fill in the region. Use gptel's menu (C-u M-x `gptel-send') to access +;; this feature. +;; +;; gptel in Org mode: +;; +;; gptel offers a few extra conveniences in Org mode. +;; - You can limit the conversation context to an Org heading with +;; `gptel-org-set-topic'. +;; +;; - You can have branching conversations in Org mode, where each hierarchical +;; outline path through the document is a separate conversation branch. +;; See the variable `gptel-org-branching-context'. +;; +;; - You can declare the gptel model, backend, temperature, system message and +;; other parameters as Org properties with the command +;; `gptel-org-set-properties'. gptel queries under the corresponding heading +;; will always use these settings, allowing you to create mostly reproducible +;; LLM chat notebooks. +;; +;; Finally, gptel offers a general purpose API for writing LLM ineractions +;; that suit your workflow, see `gptel-request'. + +;;; Code: +(declare-function markdown-mode "markdown-mode") +(declare-function gptel-curl-get-response "gptel-curl") +(declare-function gptel-menu "gptel-transient") +(declare-function gptel-system-prompt "gptel-transient") +(declare-function pulse-momentary-highlight-region "pulse") + +(declare-function ediff-make-cloned-buffer "ediff-util") +(declare-function ediff-regions-internal "ediff") + +(declare-function gptel-org--create-prompt "gptel-org") +(declare-function gptel-org-set-topic "gptel-org") +(declare-function gptel-org--save-state "gptel-org") +(declare-function gptel-org--restore-state "gptel-org") +(declare-function gptel--stream-convert-markdown->org "gptel-org") +(declare-function gptel--convert-markdown->org "gptel-org") +(define-obsolete-function-alias + 'gptel-set-topic 'gptel-org-set-topic "0.7.5") + +(eval-when-compile + (require 'subr-x) + (require 'cl-lib)) +(require 'compat nil t) +(require 'url) +(require 'map) +(require 'text-property-search) +(require 'cl-generic) +(require 'gptel-openai) + +(with-eval-after-load 'org + (require 'gptel-org)) + + +;;; User options + +(defgroup gptel nil + "Interact with LLMs from anywhere in Emacs." + :group 'hypermedia) + +;; (defcustom gptel-host "api.openai.com" +;; "The API host queried by gptel." +;; :group 'gptel +;; :type 'string) +(make-obsolete-variable + 'gptel-host + "Use `gptel-make-openai' instead." + "0.5.0") + +(defcustom gptel-proxy "" + "Path to a proxy to use for gptel interactions. +Passed to curl via --proxy arg, for example \"proxy.yourorg.com:80\" +Leave it empty if you don't use a proxy." + :type 'string) + +(defcustom gptel-api-key #'gptel-api-key-from-auth-source + "An API key (string) for the default LLM backend. + +OpenAI by default. + +Can also be a function of no arguments that returns an API +key (more secure) for the active backend." + :type '(choice + (string :tag "API key") + (function :tag "Function that returns the API key"))) + +(defcustom gptel-stream t + "Stream responses from the LLM as they are received. + +This option is ignored unless +- the LLM backend supports streaming, and +- Curl is in use (see `gptel-use-curl') + +When set to nil, Emacs waits for the full response and inserts it +all at once. This wait is asynchronous. + +\='tis a bit silly." + :type 'boolean) +(make-obsolete-variable 'gptel-playback 'gptel-stream "0.3.0") + +(defcustom gptel-use-curl (and (executable-find "curl") t) + "Whether gptel should prefer Curl when available." + :type 'boolean) + +(defcustom gptel-curl-file-size-threshold 130000 + "Size threshold for using file input with Curl. + +Specifies the size threshold for when to use a temporary file to pass data to +Curl in GPTel queries. If the size of the data to be sent exceeds this +threshold, the data is written to a temporary file and passed to Curl using the +`--data-binary' option with a file reference. Otherwise, the data is passed +directly as a command-line argument. + +The value is an integer representing the number of bytes. + +Adjusting this value may be necessary depending on the environment +and the typical size of the data being sent in GPTel queries. +A larger value may improve performance by avoiding the overhead of creating +temporary files for small data payloads, while a smaller value may be needed +if the command-line argument size is limited by the operating system." + :type 'natnum) + +(defcustom gptel-response-filter-functions + (list #'gptel--convert-org) + "Abnormal hook for transforming the response from an LLM. + +This is used to format the response in some way, such as filling +paragraphs, adding annotations or recording information in the +response like links. + +Each function in this hook receives two arguments, the response +string to transform and the LLM interaction buffer. It +should return the transformed string. + +NOTE: This is only used for non-streaming responses. To +transform streaming responses, use `gptel-post-stream-hook' and +`gptel-post-response-functions'." + :type 'hook) + +(defcustom gptel-pre-response-hook nil + "Hook run before inserting the LLM response into the current buffer. + +This hook is called in the buffer where the LLM response will be +inserted. + +Note: this hook only runs if the request succeeds." + :type 'hook) + +(define-obsolete-variable-alias + 'gptel-post-response-hook 'gptel-post-response-functions + "0.6.0" + "Post-response functions are now called with two arguments: the +start and end buffer positions of the response.") + +(defcustom gptel-post-response-functions nil + "Abnormal hook run after inserting the LLM response into the current buffer. + +This hook is called in the buffer to which the LLM response is +sent, and after the full response has been inserted. Each +function is called with two arguments: the response beginning and +end positions. + +Note: this hook runs even if the request fails. In this case the +response beginning and end positions are both the cursor position +at the time of the request." + :type 'hook) + +;; (defcustom gptel-pre-stream-insert-hook nil +;; "Hook run before each insertion of the LLM's streaming response. + +;; This hook is called in the buffer from which the prompt was sent +;; to the LLM, immediately before text insertion." +;; :group 'gptel +;; :type 'hook) + +(defcustom gptel-post-stream-hook nil + "Hook run after each insertion of the LLM's streaming response. + +This hook is called in the buffer from which the prompt was sent +to the LLM, and after a text insertion." + :type 'hook) + +(defcustom gptel-save-state-hook nil + "Hook run before gptel saves model parameters to a file. + +You can use this hook to store additional conversation state or +model parameters to the chat buffer, or to modify the buffer in +some other way." + :type 'hook) + +(defcustom gptel-default-mode (if (fboundp 'markdown-mode) + 'markdown-mode + 'text-mode) + "The default major mode for dedicated chat buffers. + +If `markdown-mode' is available, it is used. Otherwise gptel +defaults to `text-mode'." + :type 'function) + +;; TODO: Handle `prog-mode' using the `comment-start' variable +(defcustom gptel-prompt-prefix-alist + '((markdown-mode . "### ") + (org-mode . "*** ") + (text-mode . "### ")) + "String used as a prefix to the query being sent to the LLM. + +This is meant for the user to distinguish between queries and +responses, and is removed from the query before it is sent. + +This is an alist mapping major modes to the prefix strings. This +is only inserted in dedicated gptel buffers." + :type '(alist :key-type symbol :value-type string)) + +(defcustom gptel-response-prefix-alist + '((markdown-mode . "") + (org-mode . "") + (text-mode . "")) + "String inserted before the response from the LLM. + +This is meant for the user to distinguish between queries and +responses. + +This is an alist mapping major modes to the reply prefix strings. This +is only inserted in dedicated gptel buffers before the AI's response." + :type '(alist :key-type symbol :value-type string)) + +(defcustom gptel-use-header-line t + "Whether `gptel-mode' should use header-line for status information. + +When set to nil, use the mode line for (minimal) status +information and the echo area for messages." + :type 'boolean) + +(defcustom gptel-display-buffer-action '(pop-to-buffer) + "The action used to display gptel chat buffers. + +The gptel buffer is displayed in a window using + + (display-buffer BUFFER gptel-display-buffer-action) + +The value of this option has the form (FUNCTION . ALIST), +where FUNCTION is a function or a list of functions. Each such +function should accept two arguments: a buffer to display and an +alist of the same form as ALIST. See info node `(elisp)Choosing +Window' for details." + :type display-buffer--action-custom-type) + +(defcustom gptel-crowdsourced-prompts-file + (let ((cache-dir (or (eval-when-compile + (require 'xdg) + (xdg-cache-home)) + user-emacs-directory))) + (expand-file-name "gptel-crowdsourced-prompts.csv" cache-dir)) + "File used to store crowdsourced system prompts. + +These are prompts cached from an online source (see +`gptel--crowdsourced-prompts-url'), and can be set from the +transient menu interface provided by `gptel-menu'." + :type 'file) + +;; Model and interaction parameters +(defcustom gptel-directives + '((default . "You are a large language model living in Emacs and a helpful assistant. Respond concisely.") + (programming . "You are a large language model and a careful programmer. Provide code and only code as output without any additional text, prompt or note.") + (writing . "You are a large language model and a writing assistant. Respond concisely.") + (chat . "You are a large language model and a conversation partner. Respond concisely.")) + "System prompts (directives) for the LLM. + +These are system instructions sent at the beginning of each +request to the LLM. + +Each entry in this alist maps a symbol naming the directive to +the string that is sent. To set the directive for a chat session +interactively call `gptel-send' with a prefix argument." + :safe #'always + :type '(alist :key-type symbol :value-type string)) + +(defvar gptel--system-message (alist-get 'default gptel-directives) + "The system message used by gptel.") +(put 'gptel--system-message 'safe-local-variable #'always) + +(defcustom gptel-max-tokens nil + "Max tokens per response. + +This is roughly the number of words in the response. 100-300 is a +reasonable range for short answers, 400 or more for longer +responses. + +To set the target token count for a chat session interactively +call `gptel-send' with a prefix argument." + :safe #'always + :type '(choice (natnum :tag "Specify Token count") + (const :tag "Default" nil))) + +(defcustom gptel-model 'gpt-4o-mini + "GPT Model for chat. + +The name of the model, as a symbol. This is the name as expected +by the LLM provider's API. + +The current options for ChatGPT are +- `gpt-3.5-turbo' +- `gpt-3.5-turbo-16k' +- `gpt-4o-mini' +- `gpt-4' +- `gpt-4o' +- `gpt-4-turbo' +- `gpt-4-turbo-preview' +- `gpt-4-32k' +- `gpt-4-1106-preview' + +To set the model for a chat session interactively call +`gptel-send' with a prefix argument." + :safe #'always + :type '(choice + (symbol :tag "Specify model name") + (const :tag "GPT 4 omni mini" gpt-4o-mini) + (const :tag "GPT 3.5 turbo" gpt-3.5-turbo) + (const :tag "GPT 3.5 turbo 16k" gpt-3.5-turbo-16k) + (const :tag "GPT 4" gpt-4) + (const :tag "GPT 4 omni" gpt-4o) + (const :tag "GPT 4 turbo" gpt-4-turbo) + (const :tag "GPT 4 turbo (preview)" gpt-4-turbo-preview) + (const :tag "GPT 4 32k" gpt-4-32k) + (const :tag "GPT 4 1106 (preview)" gpt-4-1106-preview))) + +(defcustom gptel-temperature 1.0 + "\"Temperature\" of the LLM response. + +This is a number between 0.0 and 2.0 that controls the randomness +of the response, with 2.0 being the most random. + +To set the temperature for a chat session interactively call +`gptel-send' with a prefix argument." + :safe #'always + :type 'number) + +(defvar gptel--known-backends) + +(defconst gptel--openai-models + '((gpt-4o + :description "Advanced model for complex tasks; cheaper & faster than GPT-Turbo" + :capabilities (media tool json url) + :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") + :context-window 128 + :input-cost 2.50 + :output-cost 10 + :cutoff-date "2023-10") + (gpt-4o-mini + :description "Cheap model for fast tasks; cheaper & more capable than GPT-3.5 Turbo" + :capabilities (media tool json url) + :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") + :context-window 128 + :input-cost 0.15 + :output-cost 0.60 + :cutoff-date "2023-10") + (gpt-4-turbo + :description "Previous high-intelligence model" + :capabilities (media tool url) + :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") + :context-window 128 + :input-cost 10 + :output-cost 30 + :cutoff-date "2023-12") + ;; points to gpt-4-0613 + (gpt-4 + :description "GPT-4 snapshot from June 2023 with improved function calling support" + :context-window 8.192 + :input-cost 30 + :output-cost 60 + :cutoff-date "2023-09") + (gpt-4-turbo-preview + :description "Points to gpt-4-0125-preview" + :context-window 128 + :input-cost 10 + :output-cost 30 + :cutoff-date "2023-12") + (gpt-4-0125-preview + :description "GPT-4 Turbo preview model intended to reduce cases of “laziness”" + :context-window 128 + :input-cost 10 + :output-cost 30 + :cutoff-date "2023-12") + (o1-preview + :description "Reasoning model designed to solve hard problems across domains" + :context-window 128 + :input-cost 15 + :output-cost 60 + :cutoff-date "2023-10" + :capabilities (nosystem) + :request-params (:stream :json-false)) + (o1-mini + :description "Faster and cheaper reasoning model good at coding, math, and science" + :context-window 128 + :input-cost 3 + :output-cost 12 + :cutoff-date "2023-10" + :capabilities (nosystem) + :request-params (:stream :json-false)) + ;; limited information available + (gpt-4-32k + :input-cost 60 + :output-cost 120) + (gpt-4-1106-preview + :description "Preview model with improved function calling support" + :context-window 128 + :input-cost 10 + :output-cost 30 + :cutoff-date "2023-04") + (gpt-3.5-turbo + :description "More expensive & less capable than GPT-4o-mini; use that instead" + :capabilities (tool) + :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") + :context-window 16.358 + :input-cost 0.50 + :output-cost 1.50 + :cutoff-date "2021-09") + (gpt-3.5-turbo-16k + :description "More expensive & less capable than GPT-4o-mini; use that instead" + :mime-types ("image/jpeg" "image/png" "image/gif" "image/webp") + :context-window 16.385 + :input-cost 3 + :output-cost 4 + :cutoff-date "2021-09")) + "List of available OpenAI models and associated properties. +Keys: + +- `:description': a brief description of the model. + +- `:capabilities': a list of capabilities supported by the model. + +- `:mime-types': a list of supported MIME types for media files. + +- `:context-window': the context window size, in thousands of tokens. + +- `:input-cost': the input cost, in US dollars per million tokens. + +- `:output-cost': the output cost, in US dollars per million tokens. + +- `:cutoff-date': the knowledge cutoff date. + +- `:request-params': a plist of additional request parameters to + include when using this model. + +Information about the OpenAI models was obtained from the following +sources: + +- <https://openai.com/pricing> +- <https://platform.openai.com/docs/models>") + +(defvar gptel--openai + (gptel-make-openai + "ChatGPT" + :key 'gptel-api-key + :stream t + :models gptel--openai-models)) + +(defcustom gptel-backend gptel--openai + "LLM backend to use. + +This is the default \"backend\", an object of type +`gptel-backend' containing connection, authentication and model +information. + +A backend for ChatGPT is pre-defined by gptel. Backends for +other LLM providers (local or remote) may be constructed using +one of the available backend creation functions: +- `gptel-make-openai' +- `gptel-make-azure' +- `gptel-make-ollama' +- `gptel-make-gpt4all' +- `gptel-make-gemini' +See their documentation for more information and the package +README for examples." + :safe #'always + :type `(choice + (const :tag "ChatGPT" ,gptel--openai) + (restricted-sexp :match-alternatives (gptel-backend-p 'nil) + :tag "Other backend"))) + +(defvar gptel-expert-commands nil + "Whether experimental gptel options should be enabled. + +This opens up advanced options in `gptel-menu'.") + +(defvar-local gptel--bounds nil) +(put 'gptel--bounds 'safe-local-variable #'always) + +(defvar gptel--num-messages-to-send nil) +(put 'gptel--num-messages-to-send 'safe-local-variable #'always) + +(defcustom gptel-log-level nil + "Logging level for gptel. + +This is one of nil or the symbols info and debug: + +nil: Don't log responses +info: Log request and response bodies +debug: Log request/response bodies, headers and all other + connection settings. + +When non-nil, information is logged to `gptel--log-buffer-name', +which see." + :type '(choice + (const :tag "No logging" nil) + (const :tag "Limited" info) + (const :tag "Full" debug))) +(make-obsolete-variable + 'gptel--debug 'gptel-log-level "0.6.5") + +(defcustom gptel-track-response t + "Distinguish between user messages and LLM responses. + +When creating a prompt to send to the LLM, gptel distinguishes +between text entered by the user and past LLM responses. This +distinction is necessary for back-and-forth conversation with an +LLM. + +In regular Emacs buffers you can turn this behavior off by +setting `gptel-track-response' to nil. All text, including +past LLM responses, is then treated as user input when sending +queries. + +This variable has no effect in dedicated chat buffers (buffers +with `gptel-mode' enabled), where user prompts and responses are +always handled separately." + :type 'boolean) + +(defcustom gptel-track-media nil + "Whether supported media in chat buffers should be sent. + +When the active `gptel-model' supports it, gptel can send images +or other media from links in chat buffers to the LLM. To use +this, the following steps are required. + +1. `gptel-track-media' (this variable) should be non-nil + +2. The LLM should provide vision or document support. Currently, +only the OpenAI, Anthropic and Ollama APIs are supported. See +the documentation of `gptel-make-openai', `gptel-make-anthropic' +and `gptel-make-ollama' resp. for details on how to specify media +support for models. + +3. Only \"standalone\" links in chat buffers are considered. +These are links on their own line with no surrounding text. +Further: + +- In Org mode, only files or URLs of the form + [[/path/to/media][bracket links]] and <angle/link/path> + are sent. + +- In Markdown mode, only files or URLS of the form + [bracket link](/path/to/media) and <angle/link/path> + are sent. + +This option has no effect in non-chat buffers. To include +media (including images) more generally, use `gptel-add'." + :type 'boolean) + +(defcustom gptel-use-context 'system + "Where in the request to inject gptel's additional context. + +gptel always includes the active region or the buffer up to the +cursor in the request to the LLM. Additionally, you can add +other buffers or their regions to the context with +`gptel-add-context', or from gptel's menu. This data will be +sent with every request. + +This option controls whether and where this additional context is +included in the request. + +Currently supported options are: + + nil - Do not use the context. + system - Include the context with the system message. + user - Include the context with the user prompt." + :group 'gptel + :type '(choice + (const :tag "Don't include context" nil) + (const :tag "With system message" system) + (const :tag "With user prompt" user))) + +(defvar-local gptel--old-header-line nil) + +(defvar gptel-context--alist nil + "List of gptel's context sources. + +Each entry is of the form + (buffer . (overlay1 overlay2 ...)) +or + (\"path/to/file\").") + + +;;; Utility functions + +(defun gptel-api-key-from-auth-source (&optional host user) + "Lookup api key in the auth source. +By default, the LLM host for the active backend is used as HOST, +and \"apikey\" as USER." + (if-let ((secret + (plist-get + (car (auth-source-search + :host (or host (gptel-backend-host gptel-backend)) + :user (or user "apikey") + :require '(:secret))) + :secret))) + (if (functionp secret) + (encode-coding-string (funcall secret) 'utf-8) + secret) + (user-error "No `gptel-api-key' found in the auth source"))) + +;; FIXME Should we utf-8 encode the api-key here? +(defun gptel--get-api-key (&optional key) + "Get api key from KEY, or from `gptel-api-key'." + (when-let ((key-sym (or key (gptel-backend-key gptel-backend)))) + (cl-typecase key-sym + (function (funcall key-sym)) + (string key-sym) + (symbol (if-let ((val (symbol-value key-sym))) + (gptel--get-api-key + (symbol-value key-sym)) + (error "`gptel-api-key' is not valid"))) + (t (error "`gptel-api-key' is not valid"))))) + +(defsubst gptel--to-number (val) + "Ensure VAL is a number." + (cond + ((numberp val) val) + ((stringp val) (string-to-number val)) + ((error "%S cannot be converted to a number" val)))) + +(defsubst gptel--to-string (s) + "Convert S to a string, if possible." + (cl-etypecase s + (symbol (symbol-name s)) + (string s) + (number (number-to-string s)))) + +(defsubst gptel--intern (s) + "Intern S, if possible." + (cl-etypecase s + (symbol s) + (string (intern s)))) + +(defun gptel--merge-plists (&rest plists) + "Merge PLISTS, altering the first one. + +Later plists in the sequence take precedence over earlier ones." + (let (;; (rtn (copy-sequence (pop plists))) + (rtn (pop plists)) + p v ls) + (while plists + (setq ls (pop plists)) + (while ls + (setq p (pop ls) v (pop ls)) + (setq rtn (plist-put rtn p v)))) + rtn)) +(defun gptel-auto-scroll () + "Scroll window if LLM response continues below viewport. + +Note: This will move the cursor." + (when-let ((win (get-buffer-window (current-buffer) 'visible)) + ((not (pos-visible-in-window-p (point) win))) + (scroll-error-top-bottom t)) + (condition-case nil + (with-selected-window win + (scroll-up-command)) + (error nil)))) + +(defun gptel-beginning-of-response (&optional _ _ arg) + "Move point to the beginning of the LLM response ARG times." + (interactive "p") + ;; FIXME: Only works for arg == 1 + (gptel-end-of-response nil nil (- (or arg 1)))) + +(defun gptel-end-of-response (&optional _ _ arg) + "Move point to the end of the LLM response ARG times." + (interactive (list nil nil + (prefix-numeric-value current-prefix-arg))) + (unless arg (setq arg 1)) + (let ((search (if (> arg 0) + #'text-property-search-forward + #'text-property-search-backward))) + (dotimes (_ (abs arg)) + (funcall search 'gptel 'response t) + (if (> arg 0) + (when (looking-at (concat "\n\\{1,2\\}" + (regexp-quote + (gptel-prompt-prefix-string)) + "?")) + (goto-char (match-end 0))) + (when (looking-back (concat (regexp-quote + (gptel-response-prefix-string)) + "?") + (point-min)) + (goto-char (match-beginning 0))))))) + +(defmacro gptel--at-word-end (&rest body) + "Execute BODY at end of the current word or punctuation." + `(save-excursion + (skip-syntax-forward "w.") + ,(macroexp-progn body))) + +(defun gptel-prompt-prefix-string () + "Prefix before user prompts in `gptel-mode'." + (or (alist-get major-mode gptel-prompt-prefix-alist) "")) + +(defun gptel-response-prefix-string () + "Prefix before LLM responses in `gptel-mode'." + (or (alist-get major-mode gptel-response-prefix-alist) "")) + +(defsubst gptel--trim-prefixes (s) + "Remove prompt/response prefixes from string S." + (string-trim s + (format "[\t\r\n ]*\\(?:%s\\)?[\t\r\n ]*" + (regexp-quote (gptel-prompt-prefix-string))) + (format "[\t\r\n ]*\\(?:%s\\)?[\t\r\n ]*" + (regexp-quote (gptel-response-prefix-string))))) + +(defsubst gptel--link-standalone-p (beg end) + "Return non-nil if positions BEG and END are isolated. + +This means the extent from BEG to END is the only non-whitespace +content on this line." + (save-excursion + (and (= beg (progn (goto-char beg) (beginning-of-line) + (skip-chars-forward "\t ") + (point))) + (= end (progn (goto-char end) (end-of-line) + (skip-chars-backward "\t ") + (point)))))) + +(defvar-local gptel--backend-name nil + "Store to persist backend name across Emacs sessions. + +Note: Changing this variable does not affect gptel\\='s behavior +in any way.") +(put 'gptel--backend-name 'safe-local-variable #'always) + +;;;; Model interface +;; NOTE: This interface would be simpler to implement as a defstruct. But then +;; users cannot set `gptel-model' to a symbol/string directly, or we'd need +;; another map from these symbols to the actual model structs. + +(defsubst gptel--model-name (model) + "Get name of gptel MODEL." + (gptel--to-string model)) + +(defsubst gptel--model-capabilities (model) + "Get MODEL capabilities." + (get model :capabilities)) + +(defsubst gptel--model-mimes (model) + "Get supported mime-types for MODEL." + (get model :mime-types)) + +(defsubst gptel--model-capable-p (cap &optional model) + "Return non-nil if MODEL supports capability CAP." + (memq cap (gptel--model-capabilities + (or model gptel-model)))) + +;; TODO Handle model mime specifications like "image/*" +(defsubst gptel--model-mime-capable-p (mime &optional model) + "Return non nil if MODEL can understand MIME type." + (car-safe (member mime (gptel--model-mimes + (or model gptel-model))))) + +(defsubst gptel--model-request-params (model) + "Get model-specific request parameters for MODEL." + (get model :request-params)) + +;;;; File handling +(defun gptel--base64-encode (file) + "Encode FILE as a base64 string. + +FILE is assumed to exist and be a regular file." + (with-temp-buffer + (insert-file-contents-literally file) + (base64-encode-region (point-min) (point-max) + :no-line-break) + (buffer-string))) + +;;;; Response text recognition + +(defun gptel--get-buffer-bounds () + "Return the gptel response boundaries in the buffer as an alist." + (save-excursion + (save-restriction + (widen) + (goto-char (point-max)) + (let ((prop) (bounds)) + (while (setq prop (text-property-search-backward + 'gptel 'response t)) + (push (cons (prop-match-beginning prop) + (prop-match-end prop)) + bounds)) + bounds)))) + +(defun gptel--get-bounds () + "Return the gptel response boundaries around point." + (let (prop) + (save-excursion + (when (text-property-search-backward + 'gptel 'response t) + (when (setq prop (text-property-search-forward + 'gptel 'response t)) + (cons (prop-match-beginning prop) + (prop-match-end prop))))))) + +(defun gptel--in-response-p (&optional pt) + "Check if position PT is inside a gptel response." + (get-char-property (or pt (point)) 'gptel)) + +(defun gptel--at-response-history-p (&optional pt) + "Check if gptel response at position PT has variants." + (get-char-property (or pt (point)) 'gptel-history)) + +(defvar gptel--mode-description-alist + '((js2-mode . "Javascript") + (sh-mode . "Shell") + (enh-ruby-mode . "Ruby") + (yaml-mode . "Yaml") + (yaml-ts-mode . "Yaml") + (rustic-mode . "Rust")) + "Mapping from unconventionally named major modes to languages. + +This is used when generating system prompts for rewriting and +when including context from these major modes.") + +(defun gptel--strip-mode-suffix (mode-sym) + "Remove the -mode suffix from MODE-SYM. + +MODE-SYM is typically a major-mode symbol." + (or (alist-get mode-sym gptel--mode-description-alist) + (let ((mode-name (thread-last + (symbol-name mode-sym) + (string-remove-suffix "-mode") + (string-remove-suffix "-ts")))) + (if (provided-mode-derived-p + mode-sym 'prog-mode 'text-mode 'tex-mode) + mode-name "")))) + + +;;; Logging + +(defconst gptel--log-buffer-name "*gptel-log*" + "Log buffer for gptel.") + +(declare-function json-pretty-print "json") + +(defun gptel--log (data &optional type no-json) + "Log DATA to `gptel--log-buffer-name'. + +TYPE is a label for data being logged. DATA is assumed to be +Valid JSON unless NO-JSON is t." + (with-current-buffer (get-buffer-create gptel--log-buffer-name) + (let ((p (goto-char (point-max)))) + (unless (bobp) (insert "\n")) + (insert (format "{\"gptel\": \"%s\", " (or type "none")) + (format-time-string "\"timestamp\": \"%Y-%m-%d %H:%M:%S\"}\n") + data) + (unless no-json (ignore-errors (json-pretty-print p (point))))))) + + +;;; Saving and restoring state + +(defun gptel--restore-state () + "Restore gptel state when turning on `gptel-mode'." + (when (buffer-file-name) + (if (derived-mode-p 'org-mode) + (progn + (require 'gptel-org) + (gptel-org--restore-state)) + (when gptel--bounds + (mapc (pcase-lambda (`(,beg . ,end)) + (put-text-property beg end 'gptel 'response)) + gptel--bounds) + (message "gptel chat restored.")) + (when gptel--backend-name + (if-let ((backend (alist-get + gptel--backend-name gptel--known-backends + nil nil #'equal))) + (setq-local gptel-backend backend) + (message + (substitute-command-keys + (concat + "Could not activate gptel backend \"%s\"! " + "Switch backends with \\[universal-argument] \\[gptel-send]" + " before using gptel.")) + gptel--backend-name)))))) + +(defun gptel--save-state () + "Write the gptel state to the buffer. + +This saves chat metadata when writing the buffer to disk. To +restore a chat session, turn on `gptel-mode' after opening the +file." + (run-hooks 'gptel-save-state-hook) + (if (derived-mode-p 'org-mode) + (progn + (require 'gptel-org) + (gptel-org--save-state)) + (let ((print-escape-newlines t)) + (save-excursion + (save-restriction + (add-file-local-variable 'gptel-model gptel-model) + (add-file-local-variable 'gptel--backend-name + (gptel-backend-name gptel-backend)) + (unless (equal (default-value 'gptel-temperature) gptel-temperature) + (add-file-local-variable 'gptel-temperature gptel-temperature)) + (unless (string= (default-value 'gptel--system-message) + gptel--system-message) + (add-file-local-variable 'gptel--system-message gptel--system-message)) + (when gptel-max-tokens + (add-file-local-variable 'gptel-max-tokens gptel-max-tokens)) + (when (natnump gptel--num-messages-to-send) + (add-file-local-variable 'gptel--num-messages-to-send + gptel--num-messages-to-send)) + (add-file-local-variable 'gptel--bounds (gptel--get-buffer-bounds))))))) + + +;;; Minor mode and UI + +;; NOTE: It's not clear that this is the best strategy: +(add-to-list 'text-property-default-nonsticky '(gptel . t)) + +;;;###autoload +(define-minor-mode gptel-mode + "Minor mode for interacting with LLMs." + :lighter " GPT" + :keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c RET") #'gptel-send) + map) + (if gptel-mode + (progn + (unless (or (derived-mode-p 'org-mode 'markdown-mode) + (eq major-mode 'text-mode)) + (gptel-mode -1) + (user-error (format "`gptel-mode' is not supported in `%s'." major-mode))) + (add-hook 'before-save-hook #'gptel--save-state nil t) + (gptel--restore-state) + (if gptel-use-header-line + (setq gptel--old-header-line header-line-format + header-line-format + (list '(:eval (concat (propertize " " 'display '(space :align-to 0)) + (format "%s" (gptel-backend-name gptel-backend)))) + (propertize " Ready" 'face 'success) + '(:eval + (let* ((model (gptel--model-name gptel-model)) + (system + (propertize + (buttonize + (format "[Prompt: %s]" + (or (car-safe (rassoc gptel--system-message gptel-directives)) + (truncate-string-to-width gptel--system-message 15 nil nil t))) + (lambda (&rest _) (gptel-system-prompt))) + 'mouse-face 'highlight + 'help-echo "System message for session")) + (context + (and gptel-context--alist + (cl-loop for entry in gptel-context--alist + if (bufferp (car entry)) count it into bufs + else count (stringp (car entry)) into files + finally return + (propertize + (buttonize + (concat "[Context: " + (and (> bufs 0) (format "%d buf" bufs)) + (and (> bufs 1) "s") + (and (> bufs 0) (> files 0) ", ") + (and (> files 0) (format "%d file" files)) + (and (> files 1) "s") + "]") + (lambda (&rest _) + (require 'gptel-context) + (gptel-context--buffer-setup))) + 'mouse-face 'highlight + 'help-echo "Active gptel context")))) + (toggle-track-media + (lambda (&rest _) + (setq-local gptel-track-media + (not gptel-track-media)) + (if gptel-track-media + (message + (concat + "Sending media from included links. To include media, create " + "a \"standalone\" link in a paragraph by itself, separated from surrounding text.")) + (message "Ignoring image links. Only link text will be sent.")) + (run-at-time 0 nil #'force-mode-line-update))) + (track-media + (and (gptel--model-capable-p 'media) + (if gptel-track-media + (propertize + (buttonize "[Sending media]" toggle-track-media) + 'mouse-face 'highlight + 'help-echo + "Sending media from standalone links/urls when supported.\nClick to toggle") + (propertize + (buttonize "[Ignoring media]" toggle-track-media) + 'mouse-face 'highlight + 'help-echo + "Ignoring images from standalone links/urls.\nClick to toggle"))))) + (concat + (propertize + " " 'display + `(space :align-to (- right ,(+ 5 (length model) (length system) + (length track-media) (length context))))) + track-media (and context " ") context " " system " " + (propertize + (buttonize (concat "[" model "]") + (lambda (&rest _) (gptel-menu))) + 'mouse-face 'highlight + 'help-echo "GPT model in use")))))) + (setq mode-line-process + '(:eval (concat " " + (buttonize (gptel--model-name gptel-model) + (lambda (&rest _) (gptel-menu)))))))) + (remove-hook 'before-save-hook #'gptel--save-state t) + (if gptel-use-header-line + (setq header-line-format gptel--old-header-line + gptel--old-header-line nil) + (setq mode-line-process nil)))) + +(defun gptel--update-status (&optional msg face) + "Update status MSG in FACE." + (when gptel-mode + (if gptel-use-header-line + (and (consp header-line-format) + (setf (nth 1 header-line-format) + (propertize msg 'face face))) + (if (member msg '(" Typing..." " Waiting...")) + (setq mode-line-process (propertize msg 'face face)) + (setq mode-line-process + '(:eval (concat " " + (buttonize (gptel--model-name gptel-model) + (lambda (&rest _) (gptel-menu)))))) + (message (propertize msg 'face face)))) + (force-mode-line-update))) + +(declare-function gptel-context--wrap "gptel-context") + + +;;; Send queries, handle responses +(cl-defun gptel-request + (&optional prompt &key callback + (buffer (current-buffer)) + position context dry-run + (stream nil) (in-place nil) + (system gptel--system-message)) + "Request a response from the `gptel-backend' for PROMPT. + +The request is asynchronous, the function immediately returns +with the data that was sent. + +Note: This function is not fully self-contained. Consider +let-binding the parameters `gptel-backend' and `gptel-model' +around calls to it as required. + +If PROMPT is +- a string, it is used to create a full prompt suitable for + sending to the LLM. +- nil but region is active, the region contents are used. +- nil, the current buffer's contents up to (point) are used. + Previous responses from the LLM are identified as responses. +- A list of plists, it is used as is. + +Keyword arguments: + +CALLBACK, if supplied, is a function of two arguments, called +with the RESPONSE (a string) and INFO (a plist): + + (callback RESPONSE INFO) + +RESPONSE is nil if there was no response or an error. + +The INFO plist has (at least) the following keys: +:data - The request data included with the query +:position - marker at the point the request was sent, unless + POSITION is specified. +:buffer - The buffer current when the request was sent, + unless BUFFER is specified. +:status - Short string describing the result of the request + +Example of a callback that messages the user with the response +and info: + + (lambda (response info) + (if response + (let ((posn (marker-position (plist-get info :position))) + (buf (buffer-name (plist-get info :buffer)))) + (message \"Response for request from %S at %d: %s\" + buf posn response)) + (message \"gptel-request failed with message: %s\" + (plist-get info :status)))) + +Or, for just the response: + + (lambda (response _) + ;; Do something with response + (message (rot13-string response))) + +If CALLBACK is omitted, the response is inserted at the point the +request was sent. + +BUFFER and POSITION are the buffer and position (integer or +marker) at which the response is inserted. If a CALLBACK is +specified, no response is inserted and these arguments are +ignored, but they are still available in the INFO plist passed +to CALLBACK for you to use. + +BUFFER defaults to the current buffer, and POSITION to the value +of (point) or (region-end), depending on whether the region is +active. + +CONTEXT is any additional data needed for the callback to run. It +is included in the INFO argument to the callback. + +SYSTEM is the system message (chat directive) sent to the LLM. If +omitted, the value of `gptel--system-message' for the current +buffer is used. + +The following keywords are mainly for internal use: + +IN-PLACE is a boolean used by the default callback when inserting +the response to determine if delimiters are needed between the +prompt and the response. + +STREAM is a boolean that determines if the response should be +streamed, as in `gptel-stream'. Do not set this if you are +specifying a custom CALLBACK! + +If DRY-RUN is non-nil, construct and return the full +query data as usual, but do not send the request. + +Model parameters can be let-bound around calls to this function." + (declare (indent 1)) + ;; TODO Remove this check in version 1.0 + (gptel--sanitize-model) + (let* ((gptel--system-message + ;Add context chunks to system message if required + (if (and gptel-context--alist + (eq gptel-use-context 'system) + (not (gptel--model-capable-p 'nosystem))) + (gptel-context--wrap system) + system)) + (gptel-stream stream) + (start-marker + (cond + ((null position) + (if (use-region-p) + (set-marker (make-marker) (region-end)) + (gptel--at-word-end (point-marker)))) + ((markerp position) position) + ((integerp position) + (set-marker (make-marker) position buffer)))) + (full-prompt + (cond + ((null prompt) + (gptel--create-prompt start-marker)) + ((stringp prompt) + ;; FIXME Dear reader, welcome to Jank City: + (with-temp-buffer + (let ((gptel-model (buffer-local-value 'gptel-model buffer)) + (gptel-backend (buffer-local-value 'gptel-backend buffer))) + (insert prompt) + (gptel--create-prompt)))) + ((consp prompt) prompt))) + (request-data (gptel--request-data gptel-backend full-prompt)) + (info (list :data request-data + :buffer buffer + :position start-marker))) + ;; This context should not be confused with the context aggregation context! + (when context (plist-put info :context context)) + (when in-place (plist-put info :in-place in-place)) + (unless dry-run + (funcall (if gptel-use-curl + #'gptel-curl-get-response #'gptel--url-get-response) + info callback)) + request-data)) + +;; TODO: Handle multiple requests(#15). (Only one request from one buffer at a time?) +;;;###autoload +(defun gptel-send (&optional arg) + "Submit this prompt to the current LLM backend. + +By default, the contents of the buffer up to the cursor position +are sent. If the region is active, its contents are sent +instead. + +The response from the LLM is inserted below the cursor position +at the time of sending. To change this behavior or model +parameters, use prefix arg ARG activate a transient menu with +more options instead. + +This command is asynchronous, you can continue to use Emacs while +waiting for the response." + (interactive "P") + (if (and arg (require 'gptel-transient nil t)) + (call-interactively #'gptel-menu) + (message "Querying %s..." (gptel-backend-name gptel-backend)) + (gptel--sanitize-model) + (gptel-request nil :stream gptel-stream) + (gptel--update-status " Waiting..." 'warning))) + +(declare-function json-pretty-print-buffer "json") +(defun gptel--inspect-query (request-data &optional arg) + "Show REQUEST-DATA, the full LLM query to be sent, in a buffer. + +This functions as a dry run of `gptel-send'. If ARG is +the symbol json, show the encoded JSON query instead of the Lisp +structure gptel uses." + (with-current-buffer (get-buffer-create "*gptel-query*") + (let ((standard-output (current-buffer)) + (inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (if (eq arg 'json) + (progn (fundamental-mode) + (insert (gptel--json-encode request-data)) + (json-pretty-print-buffer)) + (lisp-data-mode) + (prin1 request-data) + (pp-buffer)) + (goto-char (point-min)) + (view-mode 1) + (display-buffer (current-buffer) gptel-display-buffer-action)))) + +(defun gptel--insert-response (response info) + "Insert the LLM RESPONSE into the gptel buffer. + +INFO is a plist containing information relevant to this buffer. +See `gptel--url-get-response' for details." + (let* ((status-str (plist-get info :status)) + (gptel-buffer (plist-get info :buffer)) + (start-marker (plist-get info :position)) + response-beg response-end) + ;; Handle read-only buffers + (when (with-current-buffer gptel-buffer + (or buffer-read-only + (get-char-property start-marker 'read-only))) + (message "Buffer is read only, displaying reply in buffer \"*LLM response*\"") + (display-buffer + (with-current-buffer (get-buffer-create "*LLM response*") + (visual-line-mode 1) + (goto-char (point-max)) + (move-marker start-marker (point) (current-buffer)) + (current-buffer)) + '((display-buffer-reuse-window + display-buffer-pop-up-window) + (reusable-frames . visible)))) + ;; Insert response and status message/error message + (with-current-buffer gptel-buffer + (if response + (progn + (setq response (gptel--transform-response + response gptel-buffer)) + (save-excursion + (put-text-property + 0 (length response) 'gptel 'response response) + (with-current-buffer (marker-buffer start-marker) + (goto-char start-marker) + (run-hooks 'gptel-pre-response-hook) + (unless (or (bobp) (plist-get info :in-place)) + (insert "\n\n") + (when gptel-mode + (insert (gptel-response-prefix-string)))) + (setq response-beg (point)) ;Save response start position + (insert response) + (setq response-end (point)) + (pulse-momentary-highlight-region response-beg response-end) + (when gptel-mode (insert "\n\n" (gptel-prompt-prefix-string)))) ;Save response end position + (when gptel-mode (gptel--update-status " Ready" 'success)))) + (gptel--update-status + (format " Response Error: %s" status-str) 'error) + (message "gptel response error: (%s) %s" + status-str (plist-get info :error)))) + ;; Run hook in visible window to set window-point, BUG #269 + (if-let ((gptel-window (get-buffer-window gptel-buffer 'visible))) + (with-selected-window gptel-window + (run-hook-with-args 'gptel-post-response-functions response-beg response-end)) + (with-current-buffer gptel-buffer + (run-hook-with-args 'gptel-post-response-functions response-beg response-end))))) + +(defun gptel--create-prompt (&optional prompt-end) + "Return a full conversation prompt from the contents of this buffer. + +If `gptel--num-messages-to-send' is set, limit to that many +recent exchanges. + +If the region is active limit the prompt to the region contents +instead. + +If `gptel-context--alist' is non-nil and the additional +context needs to be included with the user prompt, add it. + +If PROMPT-END (a marker) is provided, end the prompt contents +there." + (save-excursion + (save-restriction + (let* ((max-entries (and gptel--num-messages-to-send + (* 2 gptel--num-messages-to-send))) + (prompt-end (or prompt-end (point-max))) + (prompts + (cond + ((use-region-p) + ;; Narrow to region + (narrow-to-region (region-beginning) (region-end)) + (goto-char (point-max)) + (gptel--parse-buffer gptel-backend max-entries)) + ((derived-mode-p 'org-mode) + (require 'gptel-org) + (goto-char prompt-end) + (gptel-org--create-prompt prompt-end)) + (t (goto-char prompt-end) + (gptel--parse-buffer gptel-backend max-entries))))) + ;; NOTE: prompts is modified in place here + (when gptel-context--alist + ;; Inject context chunks into the last user prompt if required. + ;; This is also the fallback for when `gptel-use-context' is set to + ;; 'system but the model does not support system messages. + (when (and gptel-use-context + (or (eq gptel-use-context 'user) + (gptel--model-capable-p 'nosystem)) + (> (length prompts) 0)) ;FIXME context should be injected + ;even when there are no prompts + (gptel--wrap-user-prompt gptel-backend prompts)) + ;; Inject media chunks into the first user prompt if required. Media + ;; chunks are always included with the first user message, + ;; irrespective of the preference in `gptel-use-context'. This is + ;; because media cannot be included (in general) with system messages. + (when (and gptel-use-context gptel-track-media + (gptel--model-capable-p 'media)) + (gptel--wrap-user-prompt gptel-backend prompts :media))) + prompts)))) + +(cl-defgeneric gptel--parse-buffer (backend max-entries) + "Parse current buffer backwards from point and return a list of prompts. + +BACKEND is the LLM backend in use. + +MAX-ENTRIES is the number of queries/responses to include for +contexbt.") + +(cl-defgeneric gptel--parse-media-links (mode beg end) + "Find media links between BEG and END. + +MODE is the major-mode of the buffer. + +Returns a plist where each entry is of the form + (:text \"some text\") +or + (:media \"media uri or file path\")." + (ignore mode) ;byte-compiler + (list `(:text ,(buffer-substring beg end)))) + +(defvar markdown-regex-link-inline) +(defvar markdown-regex-angle-uri) +(declare-function markdown-link-at-pos "markdown-mode") +(declare-function mailcap-file-name-to-mime-type "mailcap") + +(cl-defmethod gptel--parse-media-links ((_mode (eql 'markdown-mode)) beg end) + "Parse text and actionable links between BEG and END. + +Return a list of the form + ((:text \"some text\") + (:media \"/path/to/media.png\" :mime \"image/png\") + (:text \"More text\")) +for inclusion into the user prompt for the gptel request." + (require 'mailcap) ;FIXME Avoid this somehow + (let ((parts) (from-pt)) + (save-excursion + (setq from-pt (goto-char beg)) + (while (re-search-forward + (concat "\\(?:" markdown-regex-link-inline "\\|" + markdown-regex-angle-uri "\\)") + end t) + (when-let* ((link-at-pt (markdown-link-at-pos (point))) + ((gptel--link-standalone-p + (car link-at-pt) (cadr link-at-pt))) + (path (nth 3 link-at-pt)) + (path (string-remove-prefix "file://" path)) + (mime (mailcap-file-name-to-mime-type path)) + ((gptel--model-mime-capable-p mime))) + (cond + ((seq-some (lambda (p) (string-prefix-p p path)) + '("https:" "http:" "ftp:")) + ;; Collect text up to this image, and collect this image url + (when (gptel--model-capable-p 'url) ; FIXME This is not a good place + ; to check for url capability! + (push (list :text (buffer-substring-no-properties from-pt (car link-at-pt))) + parts) + (push (list :url path :mime mime) parts) + (setq from-pt (cadr link-at-pt)))) + ((file-readable-p path) + ;; Collect text up to this image, and collect this image + (push (list :text (buffer-substring-no-properties from-pt (car link-at-pt))) + parts) + (push (list :media path :mime mime) parts) + (setq from-pt (cadr link-at-pt))))))) + (unless (= from-pt end) + (push (list :text (buffer-substring-no-properties from-pt end)) parts)) + (nreverse parts))) + +(cl-defgeneric gptel--wrap-user-prompt (backend _prompts) + "Wrap the last prompt in PROMPTS with gptel's context. + +PROMPTS is a structure as returned by `gptel--parse-buffer'. +Typically this is a list of plists. + +BACKEND is the gptel backend in use." + (display-warning + '(gptel context) + (format "Context support not implemented for backend %s, ignoring context" + (gptel-backend-name backend)))) + +(cl-defgeneric gptel--request-data (backend prompts) + "Generate a plist of all data for an LLM query. + +BACKEND is the LLM backend in use. + +PROMPTS is the plist of previous user queries and LLM responses.") + +;; TODO: Use `run-hook-wrapped' with an accumulator instead to handle +;; buffer-local hooks, etc. +(defun gptel--transform-response (content-str buffer) + "Filter CONTENT-STR through `gptel-response-filter-functions`. + +BUFFER is passed along with CONTENT-STR to each function in this +hook." + (let ((filtered-str content-str)) + (dolist (filter-func gptel-response-filter-functions filtered-str) + (condition-case nil + (when (functionp filter-func) + (setq filtered-str + (funcall filter-func filtered-str buffer))) + (error + (display-warning '(gptel filter-functions) + (format "Function %S returned an error" + filter-func))))))) + +(defun gptel--convert-org (content buffer) + "Transform CONTENT according to required major-mode. + +Currently only `org-mode' is handled. + +BUFFER is the LLM interaction buffer." + (if (with-current-buffer buffer (derived-mode-p 'org-mode)) + (gptel--convert-markdown->org content) + content)) + +(defun gptel--url-get-response (info &optional callback) + "Fetch response to prompt in INFO from the LLM. + +INFO is a plist with the following keys: +- :data (the data being sent) +- :buffer (the gptel buffer) +- :position (marker at which to insert the response). + +Call CALLBACK with the response and INFO afterwards. If omitted +the response is inserted into the current buffer after point." + (let* ((inhibit-message t) + (message-log-max nil) + (backend gptel-backend) + (url-request-method "POST") + (url-request-extra-headers + (append '(("Content-Type" . "application/json")) + (when-let ((header (gptel-backend-header gptel-backend))) + (if (functionp header) + (funcall header) header)))) + (url-request-data + (encode-coding-string + (gptel--json-encode (plist-get info :data)) + 'utf-8))) + ;; why do these checks not occur inside of `gptel--log'? + (when gptel-log-level ;logging + (when (eq gptel-log-level 'debug) + (gptel--log (gptel--json-encode + (mapcar (lambda (pair) (cons (intern (car pair)) (cdr pair))) + url-request-extra-headers)) + "request headers")) + (gptel--log url-request-data "request body")) + (url-retrieve (let ((backend-url (gptel-backend-url gptel-backend))) + (if (functionp backend-url) + (funcall backend-url) backend-url)) + (lambda (_) + (pcase-let ((`(,response ,http-msg ,error) + (gptel--url-parse-response backend (current-buffer)))) + (plist-put info :status http-msg) + (when error (plist-put info :error error)) + (funcall (or callback #'gptel--insert-response) + response info) + (kill-buffer))) + nil t nil))) + +(cl-defgeneric gptel--parse-response (backend response proc-info) + "Response extractor for LLM requests. + +BACKEND is the LLM backend in use. + +RESPONSE is the parsed JSON of the response, as a plist. + +PROC-INFO is a plist with process information and other context. +See `gptel-curl--get-response' for its contents.") + +(defvar url-http-end-of-headers) +(defvar url-http-response-status) +(defun gptel--url-parse-response (backend response-buffer) + "Parse response from BACKEND in RESPONSE-BUFFER." + (when (buffer-live-p response-buffer) + (with-current-buffer response-buffer + (when gptel-log-level ;logging + (save-excursion + (goto-char url-http-end-of-headers) + (when (eq gptel-log-level 'debug) + (gptel--log (gptel--json-encode (buffer-substring-no-properties (point-min) (point))) + "response headers")) + (gptel--log (buffer-substring-no-properties (point) (point-max)) + "response body"))) + (if-let* ((http-msg (string-trim (buffer-substring (line-beginning-position) + (line-end-position)))) + (response (progn (goto-char url-http-end-of-headers) + (condition-case nil + (gptel--json-read) + (error 'json-read-error))))) + (cond + ;; FIXME Handle the case where HTTP 100 is followed by HTTP (not 200) BUG #194 + ((or (memq url-http-response-status '(200 100)) + (string-match-p "\\(?:1\\|2\\)00 OK" http-msg)) + (list (string-trim (gptel--parse-response backend response + `(:buffer ,response-buffer + :backend ,backend))) + http-msg)) + ((plist-get response :error) + (let* ((error-data (plist-get response :error)) + (error-msg (plist-get error-data :message)) + (error-type (plist-get error-data :type)) + (backend-name (gptel-backend-name backend))) + (if (stringp error-data) + (progn + (message "%s error: (%s) %s" backend-name http-msg error-data) + (setq error-msg (string-trim error-data))) + (when (stringp error-msg) + (message "%s error: (%s) %s" backend-name http-msg (string-trim error-msg))) + (when error-type + (setq http-msg (concat "(" http-msg ") " (string-trim error-type))))) + (list nil (concat "(" http-msg ") " (or error-msg ""))))) + ((eq response 'json-read-error) + (list nil (concat "(" http-msg ") Malformed JSON in response.") "json-read-error")) + (t (list nil (concat "(" http-msg ") Could not parse HTTP response.") + "Could not parse HTTP response."))) + (list nil (concat "(" http-msg ") Could not parse HTTP response.") + "Could not parse HTTP response."))))) + +(cl-defun gptel--sanitize-model (&key (backend gptel-backend) + (model gptel-model) + (shoosh t)) + "Check if MODEL is available in BACKEND, adjust accordingly. + +If SHOOSH is true, don't issue a warning." + (let ((available (gptel-backend-models backend))) + (when (stringp model) + (unless shoosh + (display-warning + 'gptel + (format "`gptel-model' expects a symbol, found string \"%s\" + Resetting `gptel-model' to %s" + model model))) + (setq gptel-model (gptel--intern model) + model gptel-model)) + (unless (member model available) + (let ((fallback (car available))) + (unless shoosh + (display-warning + 'gptel + (format (concat "Preferred `gptel-model' \"%s\" not" + "supported in \"%s\", using \"%s\" instead") + model (gptel-backend-name backend) fallback))) + (setq-local gptel-model fallback))))) + +;;;###autoload +(defun gptel (name &optional _ initial interactivep) + "Switch to or start a chat session with NAME. + +Ask for API-KEY if `gptel-api-key' is unset. + +If region is active, use it as the INITIAL prompt. Returns the +buffer created or switched to. + +INTERACTIVEP is t when gptel is called interactively." + (interactive + (let* ((backend (default-value 'gptel-backend)) + (backend-name + (format "*%s*" (gptel-backend-name backend)))) + (list (read-buffer + "Create or choose gptel buffer: " + backend-name nil ; DEFAULT and REQUIRE-MATCH + (lambda (b) ; PREDICATE + ;; NOTE: buffer check is required (#450) + (and-let* ((buf (get-buffer (or (car-safe b) b)))) + (buffer-local-value 'gptel-mode buf)))) + (condition-case nil + (gptel--get-api-key + (gptel-backend-key backend)) + ((error user-error) + (setq gptel-api-key + (read-passwd + (format "%s API key: " backend-name))))) + (and (use-region-p) + (buffer-substring (region-beginning) + (region-end))) + t))) + (with-current-buffer (get-buffer-create name) + (cond ;Set major mode + ((eq major-mode gptel-default-mode)) + ((eq gptel-default-mode 'text-mode) + (text-mode) + (visual-line-mode 1)) + (t (funcall gptel-default-mode))) + (gptel--sanitize-model :backend (default-value 'gptel-backend) + :model (default-value 'gptel-model) + :shoosh nil) + (unless gptel-mode (gptel-mode 1)) + (goto-char (point-max)) + (skip-chars-backward "\t\r\n") + (if (bobp) (insert (or initial (gptel-prompt-prefix-string)))) + (when interactivep + (display-buffer (current-buffer) gptel-display-buffer-action) + (message "Send your query with %s!" + (substitute-command-keys "\\[gptel-send]"))) + (current-buffer))) + + +;;; Response tweaking commands + +(defun gptel--attach-response-history (history &optional buf) + "Attach HISTORY to the next gptel response in buffer BUF. + +HISTORY is a list of strings typically containing text replaced +by gptel. BUF is the current buffer if not specified. + +This is used to maintain variants of prompts or responses to diff +against if required." + (with-current-buffer (or buf (current-buffer)) + (letrec ((gptel--attach-after + (lambda (b e) + (put-text-property b e 'gptel-history + (append (ensure-list history) + (get-char-property (1- e) 'gptel-history))) + (remove-hook 'gptel-post-response-functions + gptel--attach-after 'local)))) + (add-hook 'gptel-post-response-functions gptel--attach-after + nil 'local)))) + +(defun gptel--ediff (&optional arg bounds-func) + "Ediff response at point against previous gptel responses. + +If prefix ARG is non-nil, select the previous response to ediff +against interactively. + +If specified, use BOUNDS-FUNC to compute the bounds of the +response at point. This can be used to include additional +context for the ediff session." + (interactive "P") + (when (gptel--at-response-history-p) + (pcase-let* ((`(,beg . ,end) (funcall (or bounds-func #'gptel--get-bounds))) + (prev-response + (if arg + (completing-read "Choose response variant to diff against: " + (get-char-property (point) 'gptel-history) + nil t) + (car-safe (get-char-property (point) 'gptel-history)))) + (buffer-mode major-mode) + (bufname (buffer-name)) + (`(,new-buf ,new-beg ,new-end) + (with-current-buffer + (get-buffer-create (concat bufname "-PREVIOUS-*")) + (let ((inhibit-read-only t)) + (erase-buffer) + (delay-mode-hooks (funcall buffer-mode)) + (visual-line-mode) + (insert prev-response) + (goto-char (point-min)) + (list (current-buffer) (point-min) (point-max)))))) + (unless prev-response (user-error "gptel response is additive: no changes to ediff")) + (require 'ediff) + (letrec ((cwc (current-window-configuration)) + (gptel--ediff-restore + (lambda () + (when (window-configuration-p cwc) + (set-window-configuration cwc)) + (kill-buffer (get-buffer (concat bufname "-PREVIOUS-*"))) + (kill-buffer (get-buffer (concat bufname "-CURRENT-*"))) + (remove-hook 'ediff-quit-hook gptel--ediff-restore)))) + (add-hook 'ediff-quit-hook gptel--ediff-restore) + (apply + #'ediff-regions-internal + (get-buffer (ediff-make-cloned-buffer (current-buffer) "-CURRENT-*")) + beg end new-buf new-beg new-end + nil + (list 'ediff-regions-wordwise 'word-wise nil) + ;; (if (transient-arg-value "-w" args) + ;; (list 'ediff-regions-wordwise 'word-wise nil) + ;; (list 'ediff-regions-linewise nil nil)) + ))))) + +(defun gptel--mark-response () + "Mark gptel response at point, if any." + (interactive) + (unless (gptel--in-response-p) (user-error "No gptel response at point")) + (pcase-let ((`(,beg . ,end) (gptel--get-bounds))) + (goto-char beg) (push-mark) (goto-char end) (activate-mark))) + +(defun gptel--previous-variant (&optional arg) + "Switch to previous gptel-response at this point, if it exists." + (interactive "p") + (pcase-let* ((`(,beg . ,end) (gptel--get-bounds)) + (history (get-char-property (point) 'gptel-history)) + (alt-response (car-safe history)) + (offset)) + (unless (and history alt-response) + (user-error "No variant responses available")) + (if (> arg 0) + (setq history (append (cdr history) + (list (buffer-substring-no-properties beg end)))) + (setq + alt-response (car (last history)) + history (cons (buffer-substring-no-properties beg end) + (nbutlast history)))) + (add-text-properties + 0 (length alt-response) + `(gptel response gptel-history ,history) + alt-response) + (setq offset (min (- (point) beg) (1- (length alt-response)))) + (delete-region beg end) + (insert alt-response) + (goto-char (+ beg offset)) + (pulse-momentary-highlight-region beg (+ beg (length alt-response))))) + +(defun gptel--next-variant (&optional arg) + "Switch to next gptel-response at this point, if it exists." + (interactive "p") + (gptel--previous-variant (- arg))) + +(provide 'gptel) +;;; gptel.el ends here + +;; Local Variables: +;; bug-reference-url-format: "https://github.com/karthink/gptel/issues/%s" +;; End: diff --git a/emacs/elpa/gptel-20241112.624/gptel.elc b/emacs/elpa/gptel-20241115.456/gptel.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-complete.el b/emacs/elpa/ledger-mode-20241007.1655/ledger-complete.el @@ -1,396 +0,0 @@ -;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- - -;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) - -;; This file is not part of GNU Emacs. - -;; This 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 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., 51 Franklin Street, Fifth Floor, Boston, -;; MA 02110-1301 USA. - -;;; Commentary: -;; Functions providing payee and account auto complete. - -(require 'cl-lib) -(eval-when-compile - (require 'subr-x)) - -;; In-place completion support - -;;; Code: -(require 'ledger-context) -(require 'ledger-xact) -(require 'ledger-schedule) - -(defcustom ledger-accounts-file nil - "The path to an optional file in which all accounts are used or declared. -This file will then be used as a source for account name -completions instead of the current file. -See ledger's \"account\" directive." - :type '(choice (const :tag "Use current buffer for completion" nil) - file) - :group 'ledger - :safe #'string-or-null-p) - -(defcustom ledger-payees-file nil - "The path to an optional file in which all payees are used or declared. -This file will then be used as a source for payee name -completions instead of the current file. -See ledger's \"payee\" directive." - :type '(choice (const :tag "Use current buffer for completion" nil) - file) - :group 'ledger - :safe #'string-or-null-p) - -(defcustom ledger-accounts-exclude-function nil - "Function to exclude accounts from completion. -Should be a predicate function that accepts one argument, an -element of `ledger-accounts-list-in-buffer'." - :type '(choice (const :tag "Do not exclude any accounts from completion" nil) - function) - :group 'ledger - :package-version '(ledger-mode . "2019-08-14")) - -(defcustom ledger-complete-in-steps nil - "When non-nil, `ledger-complete-at-point' completes account names in steps. -If nil, full account names are offered for completion." - :type 'boolean - :group 'ledger - :package-version '(ledger-mode . "4.0.0")) - -(defun ledger-payees-in-buffer () - "Scan buffer and return list of all payees." - (let ((origin (point)) - payees-list) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward ledger-payee-name-or-directive-regex nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (push (or (match-string-no-properties 1) (match-string-no-properties 2)) - payees-list)))) - ;; to the list - (sort (delete-dups payees-list) #'string-lessp))) - -(defun ledger-payees-list () - "Return a list of all known account names as strings. -Looks in `ledger-payees-file' if set, otherwise the current buffer." - (if ledger-payees-file - (let ((f ledger-payees-file)) - (with-temp-buffer - (insert-file-contents f) - (ledger-payees-in-buffer))) - (ledger-payees-in-buffer))) - -(defun ledger-accounts-in-buffer () - "Return an alist of accounts in the current buffer. -The `car' of each element is the account name and the `cdr' is an -alist where the key is a subdirective such as \"assert\" and the -value (if any) is the associated data. In other words, if you've -declared an account like so: - -account Assets:Checking - assert commodity == \"$\" - default - -Then one of the elements this function returns will be -\(\"Assets:Checking\" - (\"default\") - (\"assert\" . \"commodity == \"$\"\"))" - (save-excursion - (goto-char (point-min)) - (let (account-list - (seen (make-hash-table :test #'equal :size 1))) - ;; First, consider accounts declared with "account" directives, which may or - ;; may not have associated data. The data is on the following lines up to a - ;; line not starting with whitespace. - (while (re-search-forward ledger-account-directive-regex nil t) - (let ((account (match-string-no-properties 1)) - (lines (buffer-substring-no-properties - (point) - (progn (ledger-navigate-next-xact-or-directive) - (point)))) - data) - (dolist (d (split-string lines "\n")) - (setq d (string-trim d)) - (unless (string= d "") - (if (string-match " " d) - (push (cons (substring d 0 (match-beginning 0)) - (substring d (match-end 0) nil)) - data) - (push (cons d nil) data)))) - (push (cons account data) account-list) - (puthash account t seen))) - ;; Next, gather all accounts declared in postings - (unless - ;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil - ;; probably don't want accounts from postings, just those declared - ;; with directives. But the name is a little misleading. Should we - ;; make a ledger-mode-be-pedantic and use that instead? - (bound-and-true-p ledger-flymake-be-pedantic) - (ledger-xact-iterate-transactions - (lambda (_pos _date _state _payee) - (let ((end (save-excursion (ledger-navigate-end-of-xact)))) - (forward-line) - (while (re-search-forward ledger-account-any-status-regex end t) - (let ((account (match-string-no-properties 1))) - (unless (gethash account seen) - (puthash account t seen) - (push (cons account nil) account-list)))))))) - (sort account-list (lambda (a b) (string-lessp (car a) (car b))))))) - -(defun ledger-accounts-list-in-buffer () - "Return a list of all known account names in the current buffer as strings. -Considers both accounts listed in postings and those declared -with \"account\" directives." - (let ((accounts (ledger-accounts-in-buffer))) - (when ledger-accounts-exclude-function - (setq accounts (cl-remove-if ledger-accounts-exclude-function accounts))) - (mapcar #'car accounts))) - -(defun ledger-accounts-list () - "Return a list of all known account names as strings. -Looks in `ledger-accounts-file' if set, otherwise the current buffer." - (if ledger-accounts-file - (let ((f ledger-accounts-file)) - (with-temp-buffer - (insert-file-contents f) - (ledger-accounts-list-in-buffer))) - (ledger-accounts-list-in-buffer))) - -(defun ledger-accounts-tree () - "Return a tree of all accounts in the buffer. - -Each node in the tree is a list (t . CHILDREN), where CHILDREN is -an alist (ACCOUNT-ELEMENT . NODE)." - (let ((account-tree (list t))) - (dolist (account (ledger-accounts-list) account-tree) - (let ((root account-tree) - (account-elements (split-string account ":"))) - (dolist (element account-elements) - (let ((node (assoc element root))) - (unless node - (setq node (cons element (list t))) - (nconc root (list node))) - (setq root (cdr node)))))))) - -(defun ledger-complete-account-next-steps () - "Return a list of next steps for the account prefix at point." - ;; FIXME: This function is called from `ledger-complete-at-point' which - ;; already knows the bounds of the account name to complete. Computing it - ;; again here is wasteful. - (let* ((current (buffer-substring - (save-excursion - (unless (eq 'posting (ledger-thing-at-point)) - (error "Not on a posting line")) - (point)) - (point))) - (elements (and current (split-string current ":"))) - (root (ledger-accounts-tree)) - (prefix nil)) - (while (cdr elements) - (let ((xact (assoc (car elements) root))) - (if xact - (setq prefix (concat prefix (and prefix ":") - (car elements)) - root (cdr xact)) - (setq root nil elements nil))) - (setq elements (cdr elements))) - (setq root (delete (list (car elements) t) root)) - (and root - (sort - (mapcar (function - (lambda (x) - (let ((term (if prefix - (concat prefix ":" (car x)) - (car x)))) - (if (> (length (cdr x)) 1) - (concat term ":") - term)))) - (cdr root)) - 'string-lessp)))) - -(defvar ledger-complete--current-time-for-testing nil - "Internal, used for testing only.") - -(defun ledger-complete-date (month-string day-string date-at-eol-p) - "Complete a date." - (let* ((now (or ledger-complete--current-time-for-testing (current-time))) - (decoded (decode-time now)) - (this-month (nth 4 decoded)) - (this-year (nth 5 decoded)) - (last-month (if (> this-month 1) (1- this-month) 12)) - (last-year (1- this-year)) - (last-month-year (if (> this-month 1) this-year last-year)) - (month (and month-string - (string-to-number month-string))) - (day (string-to-number day-string)) - (dates (list (encode-time 0 0 0 day (or month this-month) this-year) - (if month - (encode-time 0 0 0 day month last-year) - (encode-time 0 0 0 day last-month last-month-year))))) - (let ((collection - (list (concat (ledger-format-date - (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) - (when date-at-eol-p " "))))) - (lambda (string predicate action) - (if (eq action 'metadata) - '(metadata (category . ledger-date)) - (complete-with-action action collection string predicate)))))) - -(defun ledger-complete-effective-date - (tx-year-string tx-month-string tx-day-string - month-string day-string - date-at-eol-p) - "Complete an effective date." - (let* ((tx-year (string-to-number tx-year-string)) - (tx-month (string-to-number tx-month-string)) - (tx-day (string-to-number tx-day-string)) - (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) - (next-month (if (< tx-month 12) (1+ tx-month) 1)) - (next-year (1+ tx-year)) - (next-month-year (if (< tx-month 12) tx-year next-year)) - (month (and month-string - (string-to-number month-string))) - (day (string-to-number day-string)) - (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) - (if month - (encode-time 0 0 0 day month next-year) - (encode-time 0 0 0 day next-month next-month-year))))) - (let ((collection - (list (concat (ledger-format-date - (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) - (when date-at-eol-p " "))))) - (lambda (string predicate action) - (if (eq action 'metadata) - '(metadata (category . ledger-date)) - (complete-with-action action collection string predicate)))))) - -(defun ledger-complete-at-point () - "Do appropriate completion for the thing at point." - (let ((end (point)) - start collection - realign-after - delete-suffix) - (cond (;; Date - (save-excursion - (skip-chars-forward "0-9/-") - (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))) - (setq collection (ledger-complete-date (match-string 1) - (match-string 2) - (= (line-end-position) (match-end 0))) - start (match-beginning 0) - delete-suffix (save-match-data - (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) - (length (match-string 0)))))) - (;; Effective dates - (save-excursion - (skip-chars-forward "0-9/-") - (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) - (line-beginning-position))) - (setq start (line-beginning-position)) - (setq collection (ledger-complete-effective-date - (match-string 2) (match-string 3) (match-string 4) - (match-string 5) (match-string 6) - (= (line-end-position) (match-end 0))))) - (;; Payees - (eq 'transaction - (save-excursion - (prog1 (ledger-thing-at-point) - (setq start (point))))) - (setq collection (cons 'nullary #'ledger-payees-list))) - (;; Accounts - (save-excursion - (back-to-indentation) - (skip-chars-forward "([") ;; for virtual accounts - (setq start (point))) - (setq delete-suffix (save-excursion - (when (search-forward-regexp (rx (or eol (or ?\t (repeat 2 space)))) (line-end-position) t) - (- (match-beginning 0) end))) - realign-after t - collection (cons 'nullary - (if ledger-complete-in-steps - #'ledger-complete-account-next-steps - #'ledger-accounts-list))))) - (when collection - (let ((prefix (buffer-substring-no-properties start end))) - (list start end - (pcase collection - ;; `func-arity' isn't available until Emacs 26, so we have to - ;; manually track the arity of the functions. - (`(nullary . ,f) - ;; a nullary function that returns a completion collection - (completion-table-with-cache - (lambda (_) - (cl-remove-if (apply-partially 'string= prefix) (funcall f))))) - ((pred functionp) - ;; a completion table - collection) - (_ - ;; a static completion collection - collection)) - :exit-function (lambda (&rest _) - (when delete-suffix - (delete-char delete-suffix)) - (when (and realign-after ledger-post-auto-align) - (ledger-post-align-postings (line-beginning-position) (line-end-position))))))))) - -(defun ledger-trim-trailing-whitespace (str) - (replace-regexp-in-string "[ \t]*$" "" str)) - -(defun ledger-fully-complete-xact () - "Completes a transaction if there is another matching payee in the buffer. - -Interactively, if point is after a payee, complete the -transaction with the details from the last transaction to that -payee." - (interactive) - (let* ((name (ledger-trim-trailing-whitespace - (buffer-substring - (save-excursion - (unless (eq (ledger-thing-at-point) 'transaction) - (user-error "Cannot fully complete xact here")) - (point)) - (point)))) - (rest-of-name name) - xacts) - (save-excursion - (when (eq 'transaction (ledger-thing-at-point)) - (delete-region (point) (+ (length name) (point))) - ;; Search backward for a matching payee - (when (re-search-backward - (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" - (regexp-quote name) ".*\\)") - nil t) - (setq rest-of-name (match-string 3)) - ;; Start copying the postings - (forward-line) - (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) - ;; Insert rest-of-name and the postings - (save-excursion - (insert rest-of-name ?\n) - (insert xacts) - (unless (looking-at-p "\n\n") - (insert "\n"))) - (forward-line) - (end-of-line) - ;; Move to amount on first posting line - (when (re-search-backward "\t\\| [ \t]" nil t) - (goto-char (match-end 0))))) - -(add-to-list 'completion-category-defaults '(ledger-date (styles . (substring)))) - -(provide 'ledger-complete) - -;;; ledger-complete.el ends here diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-complete.elc b/emacs/elpa/ledger-mode-20241007.1655/ledger-complete.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-mode-pkg.el b/emacs/elpa/ledger-mode-20241007.1655/ledger-mode-pkg.el @@ -1,7 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "ledger-mode" "20241007.1655" - "Helper code for use with the \"ledger\" command-line tool." - '((emacs "25.1")) - :url "https://github.com/ledger/ledger-mode" - :commit "9be25db0566d495299eaa8595eb4b6dd6b7a1080" - :revdesc "9be25db0566d") diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-mode.el b/emacs/elpa/ledger-mode-20241007.1655/ledger-mode.el @@ -1,472 +0,0 @@ -;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- - -;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) - -;; This file is not part of GNU Emacs. - -;; Package-Version: 20241007.1655 -;; Package-Revision: 9be25db0566d -;; Package-Requires: ((emacs "25.1")) - -;; This 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 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., 51 Franklin Street, Fifth Floor, Boston, -;; MA 02110-1301 USA. - -;;; Commentary: -;; This Emacs library provides a major mode for editing files in the format used -;; by the `ledger' command-line accounting system. - -;; It also provides automated support for some `ledger' workflows, such as -;; reconciling transactions, or running certain reports. - -;;; Code: - -(require 'ledger-regex) -(require 'org) -(require 'ledger-commodities) -(require 'ledger-complete) -(require 'ledger-context) -(require 'ledger-exec) -(require 'ledger-fonts) -(require 'ledger-fontify) -(require 'ledger-init) -(require 'ledger-navigate) -(require 'ledger-occur) -(require 'ledger-post) -(require 'ledger-reconcile) -(require 'ledger-report) -(require 'ledger-sort) -(require 'ledger-state) -(require 'ledger-test) -(require 'ledger-texi) -(require 'ledger-xact) -(require 'ledger-schedule) -(require 'ledger-check) - -(declare-function custom-group-members "cus-edit" (symbol groups-only)) - -;;; Code: - -(defgroup ledger nil - "Interface to the Ledger command-line accounting program." - :group 'data) - -(defconst ledger-version "3.0" - "The version of ledger.el currently loaded.") - -(defconst ledger-mode-version "4.0.0") - -(defun ledger-mode-dump-variable (var) - "Format VAR for dump to buffer." - (if var - (insert (format " %s: %S\n" (symbol-name var) (eval var))))) - -(defun ledger-mode-dump-group (group) - "Dump GROUP customizations to current buffer." - (require 'cus-edit) - (let ((members (custom-group-members group nil))) - (dolist (member members) - (cond ((eq (cadr member) 'custom-group) - (insert (format "Group %s:\n" (symbol-name (car member)))) - (ledger-mode-dump-group (car member))) - ((eq (cadr member) 'custom-variable) - (ledger-mode-dump-variable (car member))))))) - -(defun ledger-mode-dump-configuration () - "Dump all customizations." - (interactive) - (find-file "ledger-mode-dump") - (ledger-mode-dump-group 'ledger)) - -(defun ledger-read-account-with-prompt (prompt) - "Read an account from the minibuffer with PROMPT." - (let* ((context (ledger-context-at-point)) - (account (ledger-context-field-value context 'account))) - (ledger-completing-read-with-default prompt - (when account - (regexp-quote account)) - (ledger-accounts-list)))) - -(defun ledger-read-payee-with-prompt (prompt) - "Read a payee from the minibuffer with PROMPT." - (ledger-completing-read-with-default prompt - (when-let ((payee (ledger-xact-payee))) - (regexp-quote payee)) - (ledger-payees-list))) - -(defun ledger-read-date (prompt) - "Return user-supplied date after `PROMPT', defaults to today. -This uses `org-read-date', which see." - (ledger-format-date (let ((org-read-date-prefer-future nil)) - (org-read-date nil t nil prompt)))) - -(defun ledger-get-minibuffer-prompt (prompt default) - "Return a minibuffer prompt string composing PROMPT and DEFAULT." - (concat prompt - (if default - (concat " (" default "): ") - ": "))) - -(defun ledger-completing-read-with-default (prompt default collection) - "Return a user-supplied string after PROMPT. -Use the given DEFAULT, while providing completions from COLLECTION." - (completing-read (ledger-get-minibuffer-prompt prompt default) - collection nil nil nil 'ledger-minibuffer-history default)) - -(defun ledger-read-string-with-default (prompt default) - "Return user supplied string after PROMPT, or DEFAULT." - (read-string (ledger-get-minibuffer-prompt prompt default) - nil 'ledger-minibuffer-history default)) - -(defun ledger-display-balance-at-point (&optional arg) - "Display the cleared-or-pending balance. -And calculate the target-delta of the account being reconciled. - -With ARG (\\[universal-argument]) ask for the target commodity and convert -the balance into that." - (interactive "P") - (let* ((account (ledger-read-account-with-prompt "Account balance to show")) - (target-commodity (when arg (ledger-read-commodity-with-prompt "Target commodity: "))) - (buffer (find-file-noselect (ledger-master-file))) - (balance (with-temp-buffer - (apply 'ledger-exec-ledger buffer (current-buffer) "cleared" account - (when target-commodity (list "-X" target-commodity))) - (if (> (buffer-size) 0) - (buffer-substring-no-properties (point-min) (1- (point-max))) - (concat account " is empty."))))) - (when balance - (display-message-or-buffer balance)))) - -(defun ledger-display-ledger-stats () - "Display some summary statistics about the current ledger file." - (interactive) - (let* ((buffer (find-file-noselect (ledger-master-file))) - (balance (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "stats") - (buffer-substring-no-properties (point-min) (1- (point-max)))))) - (when balance - (message balance)))) - -(defvar ledger-mode-abbrev-table) - -(defvar ledger-date-string-today (ledger-format-date)) - - - -;;; Editing commands - -(defun ledger-remove-effective-date () - "Remove the effective date from a transaction or posting." - (interactive) - (let ((context (car (ledger-context-at-point)))) - (save-excursion - (save-restriction - (narrow-to-region (line-beginning-position) (line-end-position)) - (beginning-of-line) - (cond ((eq 'xact context) - (re-search-forward ledger-iso-date-regexp) - (when (= (char-after) ?=) - (let ((eq-pos (point))) - (delete-region - eq-pos - (re-search-forward ledger-iso-date-regexp))))) - ((eq 'acct-transaction context) - ;; Match "; [=date]" & delete string - (when (re-search-forward - (concat ledger-comment-regex - "\\[=" ledger-iso-date-regexp "\\]") - nil 'noerr) - (replace-match "")))))))) - -(defun ledger-insert-effective-date (&optional date) - "Insert effective date `DATE' to the transaction or posting. - -If `DATE' is nil, prompt the user a date. - -Replace the current effective date if there's one in the same -line. - -With a prefix argument, remove the effective date." - (interactive) - (if (and (listp current-prefix-arg) - (= 4 (prefix-numeric-value current-prefix-arg))) - (ledger-remove-effective-date) - (let* ((context (car (ledger-context-at-point))) - (date-string (or date (ledger-read-date "Effective date: ")))) - (save-restriction - (narrow-to-region (line-beginning-position) (line-end-position)) - (cond - ((eq 'xact context) - (beginning-of-line) - (re-search-forward ledger-iso-date-regexp) - (when (= (char-after) ?=) - (ledger-remove-effective-date)) - (insert "=" date-string)) - ((eq 'acct-transaction context) - (end-of-line) - (ledger-remove-effective-date) - (insert " ; [=" date-string "]"))))))) - -(defun ledger-mode-remove-extra-lines () - "Get rid of multiple empty lines." - (goto-char (point-min)) - (while (re-search-forward "\n\n\\(\n\\)+" nil t) - (replace-match "\n\n"))) - -(defun ledger-mode-clean-buffer () - "Indent, remove multiple line feeds and sort the buffer." - (interactive) - (let ((start (point-min-marker)) - (end (point-max-marker)) - (distance-in-xact (- (point) (ledger-navigate-beginning-of-xact)))) - (let ((target (buffer-substring (line-beginning-position) (line-end-position)))) - (goto-char start) - (untabify start end) - (ledger-sort-buffer) - (ledger-post-align-postings start end) - (ledger-mode-remove-extra-lines) - (goto-char start) - (search-forward target) - (beginning-of-line) - (forward-char distance-in-xact)))) - -(defun ledger-rename-account (old new &optional toplevel-only) - "Rename account with name OLD to name NEW. - -Affects account names mentioned in postings as well as declared -with the \"account\" directive. - -By default, child accounts of OLD are also renamed to -corresponding child accounts of NEW. With \\[universal-argument] -prefix, child accounts are not renamed. When called from Lisp, -TOPLEVEL-ONLY has the same meaning." - (interactive - (let* ((old-name - (ledger-read-account-with-prompt "Old name: ")) - (new-name - (ledger-read-string-with-default "New name: " old-name))) - (list old-name new-name current-prefix-arg))) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward ledger-account-name-or-directive-regex nil t) - (let ((account (match-string 1))) - (cond - ((string-equal account old) - (replace-match new 'fixedcase 'literal nil 1)) - ((and (not toplevel-only) - (string-prefix-p (concat old ":") account)) - (replace-match - (concat new (substring account (length old))) - 'fixedcase 'literal nil 1)))))) - (when ledger-post-auto-align - (ledger-post-align-postings (point-min) (point-max)))) - - - -;;; Commands for changing dates - -;; These functions are adapted from the implementation of `org-timestamp-change'. - -(defun ledger--in-regexp (regexp) - "Return (BEG . END) if point is inside a match of REGEXP, or nil. - -Only check the current line for occurrences of REGEXP." - (catch :exit - (let ((pos (point)) - (eol (line-end-position))) - (save-excursion - (beginning-of-line) - (while (and (re-search-forward regexp eol t) - (<= (match-beginning 0) pos)) - (let ((end (match-end 0))) - (when (>= end pos) - (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) - -(defsubst ledger--pos-in-match-range (pos n) - "Return non-nil if POS is inside the range of group N in the match data." - (and (match-beginning n) - (<= (match-beginning n) pos) - (>= (match-end n) pos))) - -(defun ledger--at-date-p () - "Return non-nil if point is inside a date. - -Specifically, return `year', `month', or `day', depending on -which part of the date string point is in." - (let ((pos (point)) - (boundaries (ledger--in-regexp ledger-iso-date-regexp))) - (cond ((null boundaries) nil) - ((ledger--pos-in-match-range pos 2) 'year) - ((ledger--pos-in-match-range pos 3) 'month) - ((ledger--pos-in-match-range pos 4) 'day)))) - -(defun ledger--date-change (n) - "Change the date field at point by N (can be negative)." - (let ((date-cat (ledger--at-date-p)) - (origin-pos (point)) - date-separator - date-str time-old time-new) - (unless date-cat (user-error "Not at a date")) - (setq date-str (match-string 0)) - (setq date-separator - (string (aref date-str 4))) - (save-match-data - (setq time-old (decode-time (ledger-parse-iso-date date-str))) - (setq time-new - ;; Do not pass DST or ZONE arguments here; it should be - ;; automatically inferred from the other arguments, since the - ;; appropriate DST value may differ from `time-old'. - (encode-time - 0 ; second - 0 ; minute - 0 ; hour - (+ (if (eq date-cat 'day) n 0) (nth 3 time-old)) - (+ (if (eq date-cat 'month) n 0) (nth 4 time-old)) - (+ (if (eq date-cat 'year) n 0) (nth 5 time-old))))) - (replace-match (format-time-string (concat "%Y" date-separator "%m" date-separator "%d") - time-new) - 'fixedcase - 'literal) - (goto-char origin-pos))) - -(defun ledger-date-up (&optional arg) - "Increment the date field at point by 1. -With prefix ARG, increment by that many instead." - (interactive "p") - (ledger--date-change arg)) - -(defun ledger-date-down (&optional arg) - "Decrement the date field at point by 1. -With prefix ARG, decrement by that many instead." - (interactive "p") - (ledger--date-change (- arg))) - - - -;;; Major mode definition - -(defvar ledger-mode-syntax-table - (let ((table (make-syntax-table text-mode-syntax-table))) - (modify-syntax-entry ?\; "<" table) - (modify-syntax-entry ?\n ">" table) - table) - "Syntax table in use in `ledger-mode' buffers.") - -(defvar ledger-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-a") #'ledger-add-transaction) - (define-key map (kbd "C-c C-b") #'ledger-post-edit-amount) - (define-key map (kbd "C-c C-c") #'ledger-toggle-current) - (define-key map (kbd "C-c C-d") #'ledger-delete-current-transaction) - (define-key map (kbd "C-c C-e") #'ledger-toggle-current-transaction) - (define-key map (kbd "C-c C-f") #'ledger-occur) - (define-key map (kbd "C-c C-k") #'ledger-copy-transaction-at-point) - (define-key map (kbd "C-c C-r") #'ledger-reconcile) - (define-key map (kbd "C-c C-s") #'ledger-sort-region) - (define-key map (kbd "C-c C-t") #'ledger-insert-effective-date) - (define-key map (kbd "C-c C-u") #'ledger-schedule-upcoming) - (define-key map (kbd "C-c C-p") #'ledger-display-balance-at-point) - (define-key map (kbd "C-c C-l") #'ledger-display-ledger-stats) - (define-key map (kbd "C-c C-q") #'ledger-post-align-xact) - - (define-key map (kbd "C-TAB") #'ledger-post-align-xact) - (define-key map (kbd "C-c TAB") #'ledger-fully-complete-xact) - (define-key map (kbd "C-c C-i") #'ledger-fully-complete-xact) - - (define-key map (kbd "C-c C-o C-a") #'ledger-report-redo) - (define-key map (kbd "C-c C-o C-e") #'ledger-report-edit-report) - (define-key map (kbd "C-c C-o C-g") #'ledger-report-goto) - (define-key map (kbd "C-c C-o C-k") #'ledger-report-quit) - (define-key map (kbd "C-c C-o C-r") #'ledger-report) - (define-key map (kbd "C-c C-o C-s") #'ledger-report-save) - - (define-key map (kbd "M-p") #'ledger-navigate-prev-xact-or-directive) - (define-key map (kbd "M-n") #'ledger-navigate-next-xact-or-directive) - (define-key map (kbd "M-q") #'ledger-post-align-dwim) - - (define-key map (kbd "S-<up>") #'ledger-date-up) - (define-key map (kbd "S-<down>") #'ledger-date-down) - - ;; Reset the `text-mode' override of this standard binding - (define-key map (kbd "C-M-i") 'completion-at-point) - map) - "Keymap for `ledger-mode'.") - -(easy-menu-define ledger-mode-menu ledger-mode-map - "Ledger menu" - '("Ledger" - ["Narrow to REGEX" ledger-occur] - ["Show all transactions" ledger-occur-mode ledger-occur-mode] - ["Ledger Statistics" ledger-display-ledger-stats ledger-works] - "---" - ["Show upcoming transactions" ledger-schedule-upcoming] - ["Add Transaction (ledger xact)" ledger-add-transaction ledger-works] - ["Complete Transaction" ledger-fully-complete-xact] - ["Delete Transaction" ledger-delete-current-transaction] - "---" - ["Calc on Amount" ledger-post-edit-amount] - "---" - ["Check Balance" ledger-display-balance-at-point ledger-works] - ["Reconcile Account" ledger-reconcile ledger-works] - "---" - ["Toggle Current Transaction" ledger-toggle-current-transaction] - ["Toggle Current Posting" ledger-toggle-current] - ["Copy Trans at Point" ledger-copy-transaction-at-point] - "---" - ["Clean-up Buffer" ledger-mode-clean-buffer] - ["Check Buffer" ledger-check-buffer ledger-works] - ["Align Region" ledger-post-align-postings mark-active] - ["Align Xact" ledger-post-align-xact] - ["Sort Region" ledger-sort-region mark-active] - ["Sort Buffer" ledger-sort-buffer] - ["Mark Sort Beginning" ledger-sort-insert-start-mark] - ["Mark Sort End" ledger-sort-insert-end-mark] - ["Set effective date" ledger-insert-effective-date] - "---" - ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'ledger))] - "---" - ["Run Report" ledger-report ledger-works] - ["Goto Report" ledger-report-goto ledger-works] - ["Re-run Report" ledger-report-redo ledger-works] - ["Save Report" ledger-report-save ledger-works] - ["Edit Report" ledger-report-edit-report ledger-works] - ["Quit Report" ledger-report-quit ledger-works])) - -;;;###autoload -(define-derived-mode ledger-mode text-mode "Ledger" - "A mode for editing ledger data files." - (ledger-check-version) - (setq font-lock-defaults - '(ledger-font-lock-keywords t nil nil nil)) - (add-hook 'font-lock-extend-region-functions 'ledger-fontify-extend-region) - (add-hook 'completion-at-point-functions #'ledger-complete-at-point nil t) - (add-hook 'after-save-hook 'ledger-report-redo nil t) - - (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) - (add-hook 'before-revert-hook 'ledger-highlight--before-revert nil t) - (add-hook 'after-revert-hook 'ledger-highlight-xact-under-point nil t) - - (ledger-init-load-init-file) - (setq-local comment-start ";") - (setq-local indent-line-function #'ledger-indent-line) - (setq-local indent-region-function 'ledger-post-align-postings) - (setq-local beginning-of-defun-function #'ledger-navigate-beginning-of-xact) - (setq-local end-of-defun-function #'ledger-navigate-end-of-xact)) - -;;;###autoload -(add-to-list 'auto-mode-alist '("\\.ledger\\'" . ledger-mode)) - -(provide 'ledger-mode) - -;;; ledger-mode.el ends here diff --git a/emacs/elpa/ledger-mode-20241007.1655/dir b/emacs/elpa/ledger-mode-20241114.1751/dir diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-check.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-check.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-check.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-check.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-commodities.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-commodities.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-commodities.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-commodities.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241114.1751/ledger-complete.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-complete.el @@ -0,0 +1,406 @@ +;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- + +;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) + +;; This file is not part of GNU Emacs. + +;; This 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 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., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: +;; Functions providing payee and account auto complete. + +(require 'cl-lib) +(eval-when-compile + (require 'subr-x)) + +;; In-place completion support + +;;; Code: +(require 'ledger-context) +(require 'ledger-xact) +(require 'ledger-schedule) + +(defcustom ledger-accounts-file nil + "The path to an optional file in which all accounts are used or declared. +This file will then be used as a source for account name +completions instead of the current file. +See ledger's \"account\" directive." + :type '(choice (const :tag "Use current buffer for completion" nil) + file) + :group 'ledger + :safe #'string-or-null-p) + +(defcustom ledger-payees-file nil + "The path to an optional file in which all payees are used or declared. +This file will then be used as a source for payee name +completions instead of the current file. +See ledger's \"payee\" directive." + :type '(choice (const :tag "Use current buffer for completion" nil) + file) + :group 'ledger + :safe #'string-or-null-p) + +(defcustom ledger-accounts-exclude-function nil + "Function to exclude accounts from completion. +Should be a predicate function that accepts one argument, an +element of `ledger-accounts-list-in-buffer'." + :type '(choice (const :tag "Do not exclude any accounts from completion" nil) + function) + :group 'ledger + :package-version '(ledger-mode . "2019-08-14")) + +(defcustom ledger-complete-in-steps nil + "When non-nil, `ledger-complete-at-point' completes account names in steps. +If nil, full account names are offered for completion." + :type 'boolean + :group 'ledger + :package-version '(ledger-mode . "4.0.0")) + +(defun ledger-payees-in-buffer () + "Scan buffer and return list of all payees." + (let ((origin (point)) + payees-list) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward ledger-payee-name-or-directive-regex nil t) + (unless (and (>= origin (match-beginning 0)) + (< origin (match-end 0))) + (push (or (match-string-no-properties 1) (match-string-no-properties 2)) + payees-list)))) + ;; to the list + (sort (delete-dups payees-list) #'string-lessp))) + +(defun ledger-payees-list () + "Return a list of all known account names as strings. +Looks in `ledger-payees-file' if set, otherwise the current buffer." + (if ledger-payees-file + (let ((f ledger-payees-file)) + (with-temp-buffer + (insert-file-contents f) + (ledger-payees-in-buffer))) + (ledger-payees-in-buffer))) + +(defun ledger-accounts-in-buffer () + "Return an alist of accounts in the current buffer. +The `car' of each element is the account name and the `cdr' is an +alist where the key is a subdirective such as \"assert\" and the +value (if any) is the associated data. In other words, if you've +declared an account like so: + +account Assets:Checking + assert commodity == \"$\" + default + +Then one of the elements this function returns will be +\(\"Assets:Checking\" + (\"default\") + (\"assert\" . \"commodity == \"$\"\"))" + (save-excursion + (goto-char (point-min)) + (let (account-list + (seen (make-hash-table :test #'equal :size 1))) + ;; First, consider accounts declared with "account" directives, which may or + ;; may not have associated data. The data is on the following lines up to a + ;; line not starting with whitespace. + (while (re-search-forward ledger-account-directive-regex nil t) + (let ((account (match-string-no-properties 1)) + (lines (buffer-substring-no-properties + (point) + (progn (ledger-navigate-next-xact-or-directive) + (point)))) + data) + (dolist (d (split-string lines "\n")) + (setq d (string-trim d)) + (unless (string= d "") + (if (string-match " " d) + (push (cons (substring d 0 (match-beginning 0)) + (substring d (match-end 0) nil)) + data) + (push (cons d nil) data)))) + (push (cons account data) account-list) + (puthash account t seen))) + ;; Next, gather all accounts declared in postings + (unless + ;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil + ;; probably don't want accounts from postings, just those declared + ;; with directives. But the name is a little misleading. Should we + ;; make a ledger-mode-be-pedantic and use that instead? + (bound-and-true-p ledger-flymake-be-pedantic) + (ledger-xact-iterate-transactions + (lambda (_pos _date _state _payee) + (let ((end (save-excursion (ledger-navigate-end-of-xact)))) + (while (re-search-forward ledger-account-any-status-regex end t) + (let ((account (match-string-no-properties 1))) + (unless (gethash account seen) + (puthash account t seen) + (push (cons account nil) account-list)))))))) + (sort account-list (lambda (a b) (string-lessp (car a) (car b))))))) + +(defun ledger-accounts-list-in-buffer () + "Return a list of all known account names in the current buffer as strings. +Considers both accounts listed in postings and those declared +with \"account\" directives." + (let ((accounts (ledger-accounts-in-buffer))) + (when ledger-accounts-exclude-function + (setq accounts (cl-remove-if ledger-accounts-exclude-function accounts))) + (mapcar #'car accounts))) + +(defun ledger-accounts-list () + "Return a list of all known account names as strings. +Looks in `ledger-accounts-file' if set, otherwise the current buffer." + (if ledger-accounts-file + (let ((f ledger-accounts-file)) + (with-temp-buffer + (insert-file-contents f) + (ledger-accounts-list-in-buffer))) + (ledger-accounts-list-in-buffer))) + +(defun ledger-accounts-tree () + "Return a tree of all accounts in the buffer. + +Each node in the tree is a list (t . CHILDREN), where CHILDREN is +an alist (ACCOUNT-ELEMENT . NODE)." + (let ((account-tree (list t))) + (dolist (account (ledger-accounts-list) account-tree) + (let ((root account-tree) + (account-elements (split-string account ":"))) + (dolist (element account-elements) + (let ((node (assoc element root))) + (unless node + (setq node (cons element (list t))) + (nconc root (list node))) + (setq root (cdr node)))))))) + +(defun ledger-complete-account-next-steps () + "Return a list of next steps for the account prefix at point." + ;; FIXME: This function is called from `ledger-complete-at-point' which + ;; already knows the bounds of the account name to complete. Computing it + ;; again here is wasteful. + (let* ((current (buffer-substring + (save-excursion + (unless (eq 'posting (ledger-thing-at-point)) + (error "Not on a posting line")) + (point)) + (point))) + (elements (and current (split-string current ":"))) + (root (ledger-accounts-tree)) + (prefix nil)) + (while (cdr elements) + (let ((xact (assoc (car elements) root))) + (if xact + (setq prefix (concat prefix (and prefix ":") + (car elements)) + root (cdr xact)) + (setq root nil elements nil))) + (setq elements (cdr elements))) + (setq root (delete (list (car elements) t) root)) + (and root + (sort + (mapcar (function + (lambda (x) + (let ((term (if prefix + (concat prefix ":" (car x)) + (car x)))) + (if (> (length (cdr x)) 1) + (concat term ":") + term)))) + (cdr root)) + 'string-lessp)))) + +(defvar ledger-complete--current-time-for-testing nil + "Internal, used for testing only.") + +(defun ledger-complete-date (month-string day-string date-at-eol-p) + "Complete a date." + (let* ((now (or ledger-complete--current-time-for-testing (current-time))) + (decoded (decode-time now)) + (this-month (nth 4 decoded)) + (this-year (nth 5 decoded)) + (last-month (if (> this-month 1) (1- this-month) 12)) + (last-year (1- this-year)) + (last-month-year (if (> this-month 1) this-year last-year)) + (month (and month-string + (string-to-number month-string))) + (day (string-to-number day-string)) + (dates (list (encode-time 0 0 0 day (or month this-month) this-year) + (if month + (encode-time 0 0 0 day month last-year) + (encode-time 0 0 0 day last-month last-month-year))))) + (let ((collection + (list (concat (ledger-format-date + (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) + (when date-at-eol-p " "))))) + (lambda (string predicate action) + (if (eq action 'metadata) + '(metadata (category . ledger-date)) + (complete-with-action action collection string predicate)))))) + +(defun ledger-complete-effective-date + (tx-year-string tx-month-string tx-day-string + month-string day-string + date-at-eol-p) + "Complete an effective date." + (let* ((tx-year (string-to-number tx-year-string)) + (tx-month (string-to-number tx-month-string)) + (tx-day (string-to-number tx-day-string)) + (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) + (next-month (if (< tx-month 12) (1+ tx-month) 1)) + (next-year (1+ tx-year)) + (next-month-year (if (< tx-month 12) tx-year next-year)) + (month (and month-string + (string-to-number month-string))) + (day (string-to-number day-string)) + (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) + (if month + (encode-time 0 0 0 day month next-year) + (encode-time 0 0 0 day next-month next-month-year))))) + (let ((collection + (list (concat (ledger-format-date + (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) + (when date-at-eol-p " "))))) + (lambda (string predicate action) + (if (eq action 'metadata) + '(metadata (category . ledger-date)) + (complete-with-action action collection string predicate)))))) + +(defun ledger-complete-at-point () + "Do appropriate completion for the thing at point." + (let ((end (point)) + start collection + realign-after + delete-suffix) + (cond (;; Date + (save-excursion + (skip-chars-forward "0-9/-") + (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))) + (setq collection (ledger-complete-date (match-string 1) + (match-string 2) + (= (line-end-position) (match-end 0))) + start (match-beginning 0) + ;; FIXME: This delete-suffix-post-completion behavior is weird + ;; and doesn't integrate well with different completion styles. + ;; For example, it breaks partial-completion's behavior when in + ;; the middle of the identifier. + ;; + ;; Instead, it should be implemented as an alternative + ;; completion style which is like emacs22 but discards the + ;; suffix. Or perhaps ledger-mode might rebind TAB to some key + ;; that deletes the account at point and then calls completion. + delete-suffix (save-match-data + (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) + (length (match-string 0)))))) + (;; Effective dates + (save-excursion + (skip-chars-forward "0-9/-") + (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) + (line-beginning-position))) + (setq start (line-beginning-position)) + (setq collection (ledger-complete-effective-date + (match-string 2) (match-string 3) (match-string 4) + (match-string 5) (match-string 6) + (= (line-end-position) (match-end 0))))) + (;; Payees + (eq 'transaction + (save-excursion + (prog1 (ledger-thing-at-point) + (setq start (point))))) + (setq collection (cons 'nullary #'ledger-payees-list))) + (;; Accounts + (save-excursion + (back-to-indentation) + (skip-chars-forward "([") ;; for virtual accounts + (setq start (point))) + (setq delete-suffix (save-excursion + (when (search-forward-regexp + (rx (or eol (any "\t])") (repeat 2 space))) + (line-end-position) t) + (- (match-beginning 0) end))) + realign-after t + collection (cons 'nullary + (if ledger-complete-in-steps + #'ledger-complete-account-next-steps + #'ledger-accounts-list))))) + (when collection + (let ((prefix (buffer-substring-no-properties start end))) + (list start end + (pcase collection + ;; `func-arity' isn't available until Emacs 26, so we have to + ;; manually track the arity of the functions. + (`(nullary . ,f) + ;; a nullary function that returns a completion collection + (completion-table-with-cache + (lambda (_) + (cl-remove-if (apply-partially 'string= prefix) (funcall f))))) + ((pred functionp) + ;; a completion table + collection) + (_ + ;; a static completion collection + collection)) + :exit-function (lambda (&rest _) + (when delete-suffix + (delete-char delete-suffix)) + (when (and realign-after ledger-post-auto-align) + (ledger-post-align-postings (line-beginning-position) (line-end-position))))))))) + +(defun ledger-trim-trailing-whitespace (str) + (replace-regexp-in-string "[ \t]*$" "" str)) + +(defun ledger-fully-complete-xact () + "Completes a transaction if there is another matching payee in the buffer. + +Interactively, if point is after a payee, complete the +transaction with the details from the last transaction to that +payee." + (interactive) + (let* ((name (ledger-trim-trailing-whitespace + (buffer-substring + (save-excursion + (unless (eq (ledger-thing-at-point) 'transaction) + (user-error "Cannot fully complete xact here")) + (point)) + (point)))) + (rest-of-name name) + xacts) + (save-excursion + (when (eq 'transaction (ledger-thing-at-point)) + (delete-region (point) (+ (length name) (point))) + ;; Search backward for a matching payee + (when (re-search-backward + (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" + (regexp-quote name) ".*\\)") + nil t) + (setq rest-of-name (match-string 3)) + ;; Start copying the postings + (forward-line) + (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) + ;; Insert rest-of-name and the postings + (save-excursion + (insert rest-of-name ?\n) + (insert xacts) + (unless (looking-at-p "\n\n") + (insert "\n"))) + (forward-line) + (end-of-line) + ;; Move to amount on first posting line + (when (re-search-backward "\t\\| [ \t]" nil t) + (goto-char (match-end 0))))) + +(add-to-list 'completion-category-defaults '(ledger-date (styles . (substring)))) + +(provide 'ledger-complete) + +;;; ledger-complete.el ends here diff --git a/emacs/elpa/ledger-mode-20241114.1751/ledger-complete.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-complete.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-context.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-context.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-context.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-context.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-exec.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-exec.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-exec.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-exec.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-flymake.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-flymake.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-flymake.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-flymake.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-fontify.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-fontify.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-fontify.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-fontify.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-fonts.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-fonts.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-fonts.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-fonts.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-init.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-init.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-init.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-init.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-mode-autoloads.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-mode-autoloads.el diff --git a/emacs/elpa/ledger-mode-20241114.1751/ledger-mode-pkg.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-mode-pkg.el @@ -0,0 +1,7 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "ledger-mode" "20241114.1751" + "Helper code for use with the \"ledger\" command-line tool." + '((emacs "25.1")) + :url "https://github.com/ledger/ledger-mode" + :commit "15b7d29f2539f9e9671ab3c062bd5165e5b80ae8" + :revdesc "15b7d29f2539") diff --git a/emacs/elpa/ledger-mode-20241114.1751/ledger-mode.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-mode.el @@ -0,0 +1,472 @@ +;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- + +;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) + +;; This file is not part of GNU Emacs. + +;; Package-Version: 20241114.1751 +;; Package-Revision: 15b7d29f2539 +;; Package-Requires: ((emacs "25.1")) + +;; This 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 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., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: +;; This Emacs library provides a major mode for editing files in the format used +;; by the `ledger' command-line accounting system. + +;; It also provides automated support for some `ledger' workflows, such as +;; reconciling transactions, or running certain reports. + +;;; Code: + +(require 'ledger-regex) +(require 'org) +(require 'ledger-commodities) +(require 'ledger-complete) +(require 'ledger-context) +(require 'ledger-exec) +(require 'ledger-fonts) +(require 'ledger-fontify) +(require 'ledger-init) +(require 'ledger-navigate) +(require 'ledger-occur) +(require 'ledger-post) +(require 'ledger-reconcile) +(require 'ledger-report) +(require 'ledger-sort) +(require 'ledger-state) +(require 'ledger-test) +(require 'ledger-texi) +(require 'ledger-xact) +(require 'ledger-schedule) +(require 'ledger-check) + +(declare-function custom-group-members "cus-edit" (symbol groups-only)) + +;;; Code: + +(defgroup ledger nil + "Interface to the Ledger command-line accounting program." + :group 'data) + +(defconst ledger-version "3.0" + "The version of ledger.el currently loaded.") + +(defconst ledger-mode-version "4.0.0") + +(defun ledger-mode-dump-variable (var) + "Format VAR for dump to buffer." + (if var + (insert (format " %s: %S\n" (symbol-name var) (eval var))))) + +(defun ledger-mode-dump-group (group) + "Dump GROUP customizations to current buffer." + (require 'cus-edit) + (let ((members (custom-group-members group nil))) + (dolist (member members) + (cond ((eq (cadr member) 'custom-group) + (insert (format "Group %s:\n" (symbol-name (car member)))) + (ledger-mode-dump-group (car member))) + ((eq (cadr member) 'custom-variable) + (ledger-mode-dump-variable (car member))))))) + +(defun ledger-mode-dump-configuration () + "Dump all customizations." + (interactive) + (find-file "ledger-mode-dump") + (ledger-mode-dump-group 'ledger)) + +(defun ledger-read-account-with-prompt (prompt) + "Read an account from the minibuffer with PROMPT." + (let* ((context (ledger-context-at-point)) + (account (ledger-context-field-value context 'account))) + (ledger-completing-read-with-default prompt + (when account + (regexp-quote account)) + (ledger-accounts-list)))) + +(defun ledger-read-payee-with-prompt (prompt) + "Read a payee from the minibuffer with PROMPT." + (ledger-completing-read-with-default prompt + (when-let ((payee (ledger-xact-payee))) + (regexp-quote payee)) + (ledger-payees-list))) + +(defun ledger-read-date (prompt) + "Return user-supplied date after `PROMPT', defaults to today. +This uses `org-read-date', which see." + (ledger-format-date (let ((org-read-date-prefer-future nil)) + (org-read-date nil t nil prompt)))) + +(defun ledger-get-minibuffer-prompt (prompt default) + "Return a minibuffer prompt string composing PROMPT and DEFAULT." + (concat prompt + (if default + (concat " (" default "): ") + ": "))) + +(defun ledger-completing-read-with-default (prompt default collection) + "Return a user-supplied string after PROMPT. +Use the given DEFAULT, while providing completions from COLLECTION." + (completing-read (ledger-get-minibuffer-prompt prompt default) + collection nil nil nil 'ledger-minibuffer-history default)) + +(defun ledger-read-string-with-default (prompt default) + "Return user supplied string after PROMPT, or DEFAULT." + (read-string (ledger-get-minibuffer-prompt prompt default) + nil 'ledger-minibuffer-history default)) + +(defun ledger-display-balance-at-point (&optional arg) + "Display the cleared-or-pending balance. +And calculate the target-delta of the account being reconciled. + +With ARG (\\[universal-argument]) ask for the target commodity and convert +the balance into that." + (interactive "P") + (let* ((account (ledger-read-account-with-prompt "Account balance to show")) + (target-commodity (when arg (ledger-read-commodity-with-prompt "Target commodity: "))) + (buffer (find-file-noselect (ledger-master-file))) + (balance (with-temp-buffer + (apply 'ledger-exec-ledger buffer (current-buffer) "cleared" account + (when target-commodity (list "-X" target-commodity))) + (if (> (buffer-size) 0) + (buffer-substring-no-properties (point-min) (1- (point-max))) + (concat account " is empty."))))) + (when balance + (display-message-or-buffer balance)))) + +(defun ledger-display-ledger-stats () + "Display some summary statistics about the current ledger file." + (interactive) + (let* ((buffer (find-file-noselect (ledger-master-file))) + (balance (with-temp-buffer + (ledger-exec-ledger buffer (current-buffer) "stats") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (when balance + (message balance)))) + +(defvar ledger-mode-abbrev-table) + +(defvar ledger-date-string-today (ledger-format-date)) + + + +;;; Editing commands + +(defun ledger-remove-effective-date () + "Remove the effective date from a transaction or posting." + (interactive) + (let ((context (car (ledger-context-at-point)))) + (save-excursion + (save-restriction + (narrow-to-region (line-beginning-position) (line-end-position)) + (beginning-of-line) + (cond ((eq 'xact context) + (re-search-forward ledger-iso-date-regexp) + (when (= (char-after) ?=) + (let ((eq-pos (point))) + (delete-region + eq-pos + (re-search-forward ledger-iso-date-regexp))))) + ((eq 'acct-transaction context) + ;; Match "; [=date]" & delete string + (when (re-search-forward + (concat ledger-comment-regex + "\\[=" ledger-iso-date-regexp "\\]") + nil 'noerr) + (replace-match "")))))))) + +(defun ledger-insert-effective-date (&optional date) + "Insert effective date `DATE' to the transaction or posting. + +If `DATE' is nil, prompt the user a date. + +Replace the current effective date if there's one in the same +line. + +With a prefix argument, remove the effective date." + (interactive) + (if (and (listp current-prefix-arg) + (= 4 (prefix-numeric-value current-prefix-arg))) + (ledger-remove-effective-date) + (let* ((context (car (ledger-context-at-point))) + (date-string (or date (ledger-read-date "Effective date: ")))) + (save-restriction + (narrow-to-region (line-beginning-position) (line-end-position)) + (cond + ((eq 'xact context) + (beginning-of-line) + (re-search-forward ledger-iso-date-regexp) + (when (= (char-after) ?=) + (ledger-remove-effective-date)) + (insert "=" date-string)) + ((eq 'acct-transaction context) + (end-of-line) + (ledger-remove-effective-date) + (insert " ; [=" date-string "]"))))))) + +(defun ledger-mode-remove-extra-lines () + "Get rid of multiple empty lines." + (goto-char (point-min)) + (while (re-search-forward "\n\n\\(\n\\)+" nil t) + (replace-match "\n\n"))) + +(defun ledger-mode-clean-buffer () + "Indent, remove multiple line feeds and sort the buffer." + (interactive) + (let ((start (point-min-marker)) + (end (point-max-marker)) + (distance-in-xact (- (point) (ledger-navigate-beginning-of-xact)))) + (let ((target (buffer-substring (line-beginning-position) (line-end-position)))) + (goto-char start) + (untabify start end) + (ledger-sort-buffer) + (ledger-post-align-postings start end) + (ledger-mode-remove-extra-lines) + (goto-char start) + (search-forward target) + (beginning-of-line) + (forward-char distance-in-xact)))) + +(defun ledger-rename-account (old new &optional toplevel-only) + "Rename account with name OLD to name NEW. + +Affects account names mentioned in postings as well as declared +with the \"account\" directive. + +By default, child accounts of OLD are also renamed to +corresponding child accounts of NEW. With \\[universal-argument] +prefix, child accounts are not renamed. When called from Lisp, +TOPLEVEL-ONLY has the same meaning." + (interactive + (let* ((old-name + (ledger-read-account-with-prompt "Old name: ")) + (new-name + (ledger-read-string-with-default "New name: " old-name))) + (list old-name new-name current-prefix-arg))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward ledger-account-name-or-directive-regex nil t) + (let ((account (match-string 1))) + (cond + ((string-equal account old) + (replace-match new 'fixedcase 'literal nil 1)) + ((and (not toplevel-only) + (string-prefix-p (concat old ":") account)) + (replace-match + (concat new (substring account (length old))) + 'fixedcase 'literal nil 1)))))) + (when ledger-post-auto-align + (ledger-post-align-postings (point-min) (point-max)))) + + + +;;; Commands for changing dates + +;; These functions are adapted from the implementation of `org-timestamp-change'. + +(defun ledger--in-regexp (regexp) + "Return (BEG . END) if point is inside a match of REGEXP, or nil. + +Only check the current line for occurrences of REGEXP." + (catch :exit + (let ((pos (point)) + (eol (line-end-position))) + (save-excursion + (beginning-of-line) + (while (and (re-search-forward regexp eol t) + (<= (match-beginning 0) pos)) + (let ((end (match-end 0))) + (when (>= end pos) + (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) + +(defsubst ledger--pos-in-match-range (pos n) + "Return non-nil if POS is inside the range of group N in the match data." + (and (match-beginning n) + (<= (match-beginning n) pos) + (>= (match-end n) pos))) + +(defun ledger--at-date-p () + "Return non-nil if point is inside a date. + +Specifically, return `year', `month', or `day', depending on +which part of the date string point is in." + (let ((pos (point)) + (boundaries (ledger--in-regexp ledger-iso-date-regexp))) + (cond ((null boundaries) nil) + ((ledger--pos-in-match-range pos 2) 'year) + ((ledger--pos-in-match-range pos 3) 'month) + ((ledger--pos-in-match-range pos 4) 'day)))) + +(defun ledger--date-change (n) + "Change the date field at point by N (can be negative)." + (let ((date-cat (ledger--at-date-p)) + (origin-pos (point)) + date-separator + date-str time-old time-new) + (unless date-cat (user-error "Not at a date")) + (setq date-str (match-string 0)) + (setq date-separator + (string (aref date-str 4))) + (save-match-data + (setq time-old (decode-time (ledger-parse-iso-date date-str))) + (setq time-new + ;; Do not pass DST or ZONE arguments here; it should be + ;; automatically inferred from the other arguments, since the + ;; appropriate DST value may differ from `time-old'. + (encode-time + 0 ; second + 0 ; minute + 0 ; hour + (+ (if (eq date-cat 'day) n 0) (nth 3 time-old)) + (+ (if (eq date-cat 'month) n 0) (nth 4 time-old)) + (+ (if (eq date-cat 'year) n 0) (nth 5 time-old))))) + (replace-match (format-time-string (concat "%Y" date-separator "%m" date-separator "%d") + time-new) + 'fixedcase + 'literal) + (goto-char origin-pos))) + +(defun ledger-date-up (&optional arg) + "Increment the date field at point by 1. +With prefix ARG, increment by that many instead." + (interactive "p") + (ledger--date-change arg)) + +(defun ledger-date-down (&optional arg) + "Decrement the date field at point by 1. +With prefix ARG, decrement by that many instead." + (interactive "p") + (ledger--date-change (- arg))) + + + +;;; Major mode definition + +(defvar ledger-mode-syntax-table + (let ((table (make-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?\; "<" table) + (modify-syntax-entry ?\n ">" table) + table) + "Syntax table in use in `ledger-mode' buffers.") + +(defvar ledger-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-a") #'ledger-add-transaction) + (define-key map (kbd "C-c C-b") #'ledger-post-edit-amount) + (define-key map (kbd "C-c C-c") #'ledger-toggle-current) + (define-key map (kbd "C-c C-d") #'ledger-delete-current-transaction) + (define-key map (kbd "C-c C-e") #'ledger-toggle-current-transaction) + (define-key map (kbd "C-c C-f") #'ledger-occur) + (define-key map (kbd "C-c C-k") #'ledger-copy-transaction-at-point) + (define-key map (kbd "C-c C-r") #'ledger-reconcile) + (define-key map (kbd "C-c C-s") #'ledger-sort-region) + (define-key map (kbd "C-c C-t") #'ledger-insert-effective-date) + (define-key map (kbd "C-c C-u") #'ledger-schedule-upcoming) + (define-key map (kbd "C-c C-p") #'ledger-display-balance-at-point) + (define-key map (kbd "C-c C-l") #'ledger-display-ledger-stats) + (define-key map (kbd "C-c C-q") #'ledger-post-align-xact) + + (define-key map (kbd "C-TAB") #'ledger-post-align-xact) + (define-key map (kbd "C-c TAB") #'ledger-fully-complete-xact) + (define-key map (kbd "C-c C-i") #'ledger-fully-complete-xact) + + (define-key map (kbd "C-c C-o C-a") #'ledger-report-redo) + (define-key map (kbd "C-c C-o C-e") #'ledger-report-edit-report) + (define-key map (kbd "C-c C-o C-g") #'ledger-report-goto) + (define-key map (kbd "C-c C-o C-k") #'ledger-report-quit) + (define-key map (kbd "C-c C-o C-r") #'ledger-report) + (define-key map (kbd "C-c C-o C-s") #'ledger-report-save) + + (define-key map (kbd "M-p") #'ledger-navigate-prev-xact-or-directive) + (define-key map (kbd "M-n") #'ledger-navigate-next-xact-or-directive) + (define-key map (kbd "M-q") #'ledger-post-align-dwim) + + (define-key map (kbd "S-<up>") #'ledger-date-up) + (define-key map (kbd "S-<down>") #'ledger-date-down) + + ;; Reset the `text-mode' override of this standard binding + (define-key map (kbd "C-M-i") 'completion-at-point) + map) + "Keymap for `ledger-mode'.") + +(easy-menu-define ledger-mode-menu ledger-mode-map + "Ledger menu" + '("Ledger" + ["Narrow to REGEX" ledger-occur] + ["Show all transactions" ledger-occur-mode ledger-occur-mode] + ["Ledger Statistics" ledger-display-ledger-stats ledger-works] + "---" + ["Show upcoming transactions" ledger-schedule-upcoming] + ["Add Transaction (ledger xact)" ledger-add-transaction ledger-works] + ["Complete Transaction" ledger-fully-complete-xact] + ["Delete Transaction" ledger-delete-current-transaction] + "---" + ["Calc on Amount" ledger-post-edit-amount] + "---" + ["Check Balance" ledger-display-balance-at-point ledger-works] + ["Reconcile Account" ledger-reconcile ledger-works] + "---" + ["Toggle Current Transaction" ledger-toggle-current-transaction] + ["Toggle Current Posting" ledger-toggle-current] + ["Copy Trans at Point" ledger-copy-transaction-at-point] + "---" + ["Clean-up Buffer" ledger-mode-clean-buffer] + ["Check Buffer" ledger-check-buffer ledger-works] + ["Align Region" ledger-post-align-postings mark-active] + ["Align Xact" ledger-post-align-xact] + ["Sort Region" ledger-sort-region mark-active] + ["Sort Buffer" ledger-sort-buffer] + ["Mark Sort Beginning" ledger-sort-insert-start-mark] + ["Mark Sort End" ledger-sort-insert-end-mark] + ["Set effective date" ledger-insert-effective-date] + "---" + ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'ledger))] + "---" + ["Run Report" ledger-report ledger-works] + ["Goto Report" ledger-report-goto ledger-works] + ["Re-run Report" ledger-report-redo ledger-works] + ["Save Report" ledger-report-save ledger-works] + ["Edit Report" ledger-report-edit-report ledger-works] + ["Quit Report" ledger-report-quit ledger-works])) + +;;;###autoload +(define-derived-mode ledger-mode text-mode "Ledger" + "A mode for editing ledger data files." + (ledger-check-version) + (setq font-lock-defaults + '(ledger-font-lock-keywords t nil nil nil)) + (add-hook 'font-lock-extend-region-functions 'ledger-fontify-extend-region) + (add-hook 'completion-at-point-functions #'ledger-complete-at-point nil t) + (add-hook 'after-save-hook 'ledger-report-redo nil t) + + (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) + (add-hook 'before-revert-hook 'ledger-highlight--before-revert nil t) + (add-hook 'after-revert-hook 'ledger-highlight-xact-under-point nil t) + + (ledger-init-load-init-file) + (setq-local comment-start ";") + (setq-local indent-line-function #'ledger-indent-line) + (setq-local indent-region-function 'ledger-post-align-postings) + (setq-local beginning-of-defun-function #'ledger-navigate-beginning-of-xact) + (setq-local end-of-defun-function #'ledger-navigate-end-of-xact)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.ledger\\'" . ledger-mode)) + +(provide 'ledger-mode) + +;;; ledger-mode.el ends here diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-mode.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-mode.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-mode.info b/emacs/elpa/ledger-mode-20241114.1751/ledger-mode.info diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-navigate.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-navigate.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-navigate.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-navigate.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-occur.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-occur.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-occur.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-occur.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-post.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-post.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-post.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-post.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-reconcile.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-reconcile.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-reconcile.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-reconcile.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-regex.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-regex.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-regex.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-regex.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-report.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-report.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-report.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-report.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-schedule.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-schedule.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-schedule.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-schedule.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-sort.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-sort.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-sort.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-sort.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-state.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-state.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-state.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-state.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-test.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-test.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-test.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-test.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-texi.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-texi.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-texi.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-texi.elc Binary files differ. diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-xact.el b/emacs/elpa/ledger-mode-20241114.1751/ledger-xact.el diff --git a/emacs/elpa/ledger-mode-20241007.1655/ledger-xact.elc b/emacs/elpa/ledger-mode-20241114.1751/ledger-xact.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/git-commit.elc b/emacs/elpa/magit-20241106.1441/git-commit.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-diff.el b/emacs/elpa/magit-20241106.1441/magit-diff.el @@ -1,3572 +0,0 @@ -;;; magit-diff.el --- Inspect Git diffs -*- lexical-binding:t -*- - -;; Copyright (C) 2008-2024 The Magit Project Contributors - -;; Author: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> -;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; Magit 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. -;; -;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This library implements support for looking at Git diffs and -;; commits. - -;;; Code: - -(require 'magit-core) -(require 'git-commit) - -(eval-when-compile (require 'ansi-color)) -(require 'diff-mode) -(require 'image) -(require 'smerge-mode) - -;; For `magit-diff-popup' -(declare-function magit-stash-show "magit-stash" (stash &optional args files)) -;; For `magit-diff-visit-file' -(declare-function magit-find-file-noselect "magit-files" (rev file)) -(declare-function magit-status-setup-buffer "magit-status" (&optional directory)) -;; For `magit-diff-while-committing' -(declare-function magit-commit-diff-1 "magit-commit" ()) -(declare-function magit-commit-message-buffer "magit-commit" ()) -;; For `magit-insert-revision-gravatar' -(defvar gravatar-size) -;; For `magit-show-commit' and `magit-diff-show-or-scroll' -(declare-function magit-current-blame-chunk "magit-blame" (&optional type noerror)) -(declare-function magit-blame-mode "magit-blame" (&optional arg)) -(defvar magit-blame-mode) -;; For `magit-diff-show-or-scroll' -(declare-function git-rebase-current-line "git-rebase" ()) -;; For `magit-diff-unmerged' -(declare-function magit-merge-in-progress-p "magit-merge" ()) -(declare-function magit--merge-range "magit-merge" (&optional head)) -;; For `magit-diff--dwim' -(declare-function forge--pullreq-range "ext:forge-pullreq" - (pullreq &optional endpoints)) -(declare-function forge--pullreq-ref "ext:forge-pullreq" (pullreq)) -;; For `magit-diff-wash-diff' -(declare-function ansi-color-apply-on-region "ansi-color") -;; For `magit-diff-wash-submodule' -(declare-function magit-log-wash-log "magit-log" (style args)) -;; For keymaps and menus -(declare-function magit-apply "magit-apply" (&rest args)) -(declare-function magit-stage "magit-apply" (&optional indent)) -(declare-function magit-unstage "magit-apply" ()) -(declare-function magit-discard "magit-apply" ()) -(declare-function magit-reverse "magit-apply" (&rest args)) -(declare-function magit-file-rename "magit-files" (file newname)) -(declare-function magit-file-untrack "magit-files" (files &optional force)) -(declare-function magit-commit-add-log "magit-commit" ()) -(declare-function magit-diff-trace-definition "magit-log" ()) -(declare-function magit-patch-save "magit-patch" (files &optional arg)) -(declare-function magit-do-async-shell-command "magit-extras" (file)) -(declare-function magit-add-change-log-entry "magit-extras" - (&optional whoami file-name other-window)) -(declare-function magit-add-change-log-entry-other-window "magit-extras" - (&optional whoami file-name)) -(declare-function magit-diff-edit-hunk-commit "magit-extras" (file)) -(declare-function magit-smerge-keep-current "magit-apply" ()) -(declare-function magit-smerge-keep-all "magit-apply" ()) -(declare-function magit-smerge-keep-upper "magit-apply" ()) -(declare-function magit-smerge-keep-base "magit-apply" ()) -(declare-function magit-smerge-keep-lower "magit-apply" ()) - -(eval-when-compile - (cl-pushnew 'orig-rev eieio--known-slot-names) - (cl-pushnew 'action-type eieio--known-slot-names) - (cl-pushnew 'target eieio--known-slot-names)) - -;;; Options -;;;; Diff Mode - -(defgroup magit-diff nil - "Inspect and manipulate Git diffs." - :link '(info-link "(magit)Diffing") - :group 'magit-commands - :group 'magit-modes) - -(defcustom magit-diff-mode-hook nil - "Hook run after entering Magit-Diff mode." - :group 'magit-diff - :type 'hook) - -(defcustom magit-diff-sections-hook - '(magit-insert-diff - magit-insert-xref-buttons) - "Hook run to insert sections into a `magit-diff-mode' buffer." - :package-version '(magit . "2.3.0") - :group 'magit-diff - :type 'hook) - -(defcustom magit-diff-expansion-threshold 60 - "After how many seconds not to expand anymore diffs. - -Except in status buffers, diffs usually start out fully expanded. -Because that can take a long time, all diffs that haven't been -fontified during a refresh before the threshold defined here are -instead displayed with their bodies collapsed. - -Note that this can cause sections that were previously expanded -to be collapsed. So you should not pick a very low value here. - -The hook function `magit-diff-expansion-threshold' has to be a -member of `magit-section-set-visibility-hook' for this option -to have any effect." - :package-version '(magit . "2.9.0") - :group 'magit-diff - :type 'float) - -(defcustom magit-diff-highlight-hunk-body t - "Whether to highlight bodies of selected hunk sections. -This only has an effect if `magit-diff-highlight' is a -member of `magit-section-highlight-hook', which see." - :package-version '(magit . "2.1.0") - :group 'magit-diff - :type 'boolean) - -(defcustom magit-diff-highlight-hunk-region-functions - '(magit-diff-highlight-hunk-region-dim-outside - magit-diff-highlight-hunk-region-using-overlays) - "The functions used to highlight the hunk-internal region. - -`magit-diff-highlight-hunk-region-dim-outside' overlays the outside -of the hunk internal selection with a face that causes the added and -removed lines to have the same background color as context lines. -This function should not be removed from the value of this option. - -`magit-diff-highlight-hunk-region-using-overlays' and -`magit-diff-highlight-hunk-region-using-underline' emphasize the -region by placing delimiting horizontal lines before and after it. -The underline variant was implemented because Eli said that is -how we should do it. However the overlay variant actually works -better. Also see https://github.com/magit/magit/issues/2758. - -Instead of, or in addition to, using delimiting horizontal lines, -to emphasize the boundaries, you may wish to emphasize the text -itself, using `magit-diff-highlight-hunk-region-using-face'. - -In terminal frames it's not possible to draw lines as the overlay -and underline variants normally do, so there they fall back to -calling the face function instead." - :package-version '(magit . "2.9.0") - :set-after '(magit-diff-show-lines-boundaries) - :group 'magit-diff - :type 'hook - :options '(magit-diff-highlight-hunk-region-dim-outside - magit-diff-highlight-hunk-region-using-underline - magit-diff-highlight-hunk-region-using-overlays - magit-diff-highlight-hunk-region-using-face)) - -(defcustom magit-diff-unmarked-lines-keep-foreground t - "Whether `magit-diff-highlight-hunk-region-dim-outside' preserves foreground. -When this is set to nil, then that function only adjusts the -foreground color but added and removed lines outside the region -keep their distinct foreground colors." - :package-version '(magit . "2.9.0") - :group 'magit-diff - :type 'boolean) - -(defcustom magit-diff-refine-hunk nil - "Whether to show word-granularity differences within diff hunks. - -nil Never show fine differences. -t Show fine differences for the current diff hunk only. -`all' Show fine differences for all displayed diff hunks." - :group 'magit-diff - :safe (lambda (val) (memq val '(nil t all))) - :type '(choice (const :tag "Never" nil) - (const :tag "Current" t) - (const :tag "All" all))) - -(defcustom magit-diff-refine-ignore-whitespace smerge-refine-ignore-whitespace - "Whether to ignore whitespace changes in word-granularity differences." - :package-version '(magit . "3.0.0") - :set-after '(smerge-refine-ignore-whitespace) - :group 'magit-diff - :safe 'booleanp - :type 'boolean) - -(put 'magit-diff-refine-hunk 'permanent-local t) - -(defcustom magit-diff-adjust-tab-width nil - "Whether to adjust the width of tabs in diffs. - -Determining the correct width can be expensive if it requires -opening large and/or many files, so the widths are cached in -the variable `magit-diff--tab-width-cache'. Set that to nil -to invalidate the cache. - -nil Never adjust tab width. Use `tab-width's value from - the Magit buffer itself instead. - -t If the corresponding file-visiting buffer exits, then - use `tab-width's value from that buffer. Doing this is - cheap, so this value is used even if a corresponding - cache entry exists. - -`always' If there is no such buffer, then temporarily visit the - file to determine the value. - -NUMBER Like `always', but don't visit files larger than NUMBER - bytes." - :package-version '(magit . "2.12.0") - :group 'magit-diff - :type '(choice (const :tag "Never" nil) - (const :tag "If file-visiting buffer exists" t) - (integer :tag "If file isn't larger than N bytes") - (const :tag "Always" always))) - -(defcustom magit-diff-paint-whitespace t - "Specify where to highlight whitespace errors. - -nil Never highlight whitespace errors. -t Highlight whitespace errors everywhere. -`uncommitted' Only highlight whitespace errors in diffs - showing uncommitted changes. - -For backward compatibility `status' is treated as a synonym -for `uncommitted'. - -The option `magit-diff-paint-whitespace-lines' controls for -what lines (added/remove/context) errors are highlighted. - -The options `magit-diff-highlight-trailing' and -`magit-diff-highlight-indentation' control what kind of -whitespace errors are highlighted." - :group 'magit-diff - :safe (lambda (val) (memq val '(t nil uncommitted status))) - :type '(choice (const :tag "In all diffs" t) - (const :tag "Only in uncommitted changes" uncommitted) - (const :tag "Never" nil))) - -(defcustom magit-diff-paint-whitespace-lines t - "Specify in what kind of lines to highlight whitespace errors. - -t Highlight only in added lines. -`both' Highlight in added and removed lines. -`all' Highlight in added, removed and context lines." - :package-version '(magit . "3.0.0") - :group 'magit-diff - :safe (lambda (val) (memq val '(t both all))) - :type '(choice (const :tag "in added lines" t) - (const :tag "in added and removed lines" both) - (const :tag "in added, removed and context lines" all))) - -(defcustom magit-diff-highlight-trailing t - "Whether to highlight whitespace at the end of a line in diffs. -Used only when `magit-diff-paint-whitespace' is non-nil." - :group 'magit-diff - :safe 'booleanp - :type 'boolean) - -(defcustom magit-diff-highlight-indentation nil - "Highlight the \"wrong\" indentation style. -Used only when `magit-diff-paint-whitespace' is non-nil. - -The value is an alist of the form ((REGEXP . INDENT)...). The -path to the current repository is matched against each element -in reverse order. Therefore if a REGEXP matches, then earlier -elements are not tried. - -If the used INDENT is `tabs', highlight indentation with tabs. -If INDENT is an integer, highlight indentation with at least -that many spaces. Otherwise, highlight neither." - :group 'magit-diff - :type `(repeat (cons (string :tag "Directory regexp") - (choice (const :tag "Tabs" tabs) - (integer :tag "Spaces" :value ,tab-width) - (const :tag "Neither" nil))))) - -(defcustom magit-diff-hide-trailing-cr-characters - (and (memq system-type '(ms-dos windows-nt)) t) - "Whether to hide ^M characters at the end of a line in diffs." - :package-version '(magit . "2.6.0") - :group 'magit-diff - :type 'boolean) - -(defcustom magit-diff-highlight-keywords t - "Whether to highlight bracketed keywords in commit messages." - :package-version '(magit . "2.12.0") - :group 'magit-diff - :type 'boolean) - -(defcustom magit-diff-extra-stat-arguments nil - "Additional arguments to be used alongside `--stat'. - -A list of zero or more arguments or a function that takes no -argument and returns such a list. These arguments are allowed -here: `--stat-width', `--stat-name-width', `--stat-graph-width' -and `--compact-summary'. See the git-diff(1) manpage." - :package-version '(magit . "3.0.0") - :group 'magit-diff - :type '(radio (function-item magit-diff-use-window-width-as-stat-width) - function - (list string) - (const :tag "None" nil))) - -;;;; File Diff - -(defcustom magit-diff-buffer-file-locked t - "Whether `magit-diff-buffer-file' uses a dedicated buffer." - :package-version '(magit . "2.7.0") - :group 'magit-commands - :group 'magit-diff - :type 'boolean) - -;;;; Revision Mode - -(defgroup magit-revision nil - "Inspect and manipulate Git commits." - :link '(info-link "(magit)Revision Buffer") - :group 'magit-modes) - -(defcustom magit-revision-mode-hook - '(bug-reference-mode - goto-address-mode) - "Hook run after entering Magit-Revision mode." - :group 'magit-revision - :type 'hook - :options '(bug-reference-mode - goto-address-mode)) - -(defcustom magit-revision-sections-hook - '(magit-insert-revision-tag - magit-insert-revision-headers - magit-insert-revision-message - magit-insert-revision-notes - magit-insert-revision-diff - magit-insert-xref-buttons) - "Hook run to insert sections into a `magit-revision-mode' buffer." - :package-version '(magit . "2.3.0") - :group 'magit-revision - :type 'hook) - -(defcustom magit-revision-headers-format "\ -Author: %aN <%aE> -AuthorDate: %ad -Commit: %cN <%cE> -CommitDate: %cd -" - "Format string used to insert headers in revision buffers. - -All headers in revision buffers are inserted by the section -inserter `magit-insert-revision-headers'. Some of the headers -are created by calling `git show --format=FORMAT' where FORMAT -is the format specified here. Other headers are hard coded or -subject to option `magit-revision-insert-related-refs'." - :package-version '(magit . "2.3.0") - :group 'magit-revision - :type 'string) - -(defcustom magit-revision-insert-related-refs t - "Whether to show related branches in revision buffers - -`nil' Don't show any related branches. -`t' Show related local branches. -`all' Show related local and remote branches. -`mixed' Show all containing branches and local merged branches. - -See user option `magit-revision-insert-related-refs-display-alist' -to hide specific sets of related branches." - :package-version '(magit . "2.1.0") - :group 'magit-revision - :type '(choice (const :tag "don't" nil) - (const :tag "local only" t) - (const :tag "all related" all) - (const :tag "all containing, local merged" mixed))) - -(defcustom magit-revision-insert-related-refs-display-alist nil - "How `magit-insert-revision-headers' displays related branch types. - -This is an alist, with recognised keys being the symbols -`parents', `merged', `contained', `follows', and `precedes'; -and the supported values for each key being: - -`nil' Hide these related branches. -`t' Show these related branches. - -Keys which are not present in the alist have an implicit value `t' -\(so the default alist value of nil means all related branch types -will be shown.) - -The types to be shown are additionally subject to user option -`magit-revision-insert-related-refs'." - :package-version '(magit . "3.3.1") - :group 'magit-revision - :type '(alist :key-type (symbol :tag "Type of related branch") - :value-type (boolean :tag "Display")) - :options (mapcar (lambda (sym) - `(,sym (choice (const :tag "Hide" nil) - (const :tag "Show" t)))) - '(parents merged contained follows precedes))) - -(defcustom magit-revision-use-hash-sections 'quicker - "Whether to turn hashes inside the commit message into sections. - -If non-nil, then hashes inside the commit message are turned into -`commit' sections. There is a trade off to be made between -performance and reliability: - -- `slow' calls git for every word to be absolutely sure. -- `quick' skips words less than seven characters long. -- `quicker' additionally skips words that don't contain a number. -- `quickest' uses all words that are at least seven characters - long and which contain at least one number as well as at least - one letter. - -If nil, then no hashes are turned into sections, but you can -still visit the commit at point using \"RET\"." - :package-version '(magit . "2.12.0") - :group 'magit-revision - :type '(choice (const :tag "Use sections, quickest" quickest) - (const :tag "Use sections, quicker" quicker) - (const :tag "Use sections, quick" quick) - (const :tag "Use sections, slow" slow) - (const :tag "Don't use sections" nil))) - -(defcustom magit-revision-show-gravatars nil - "Whether to show gravatar images in revision buffers. - -If nil, then don't insert any gravatar images. If t, then insert -both images. If `author' or `committer', then insert only the -respective image. - -If you have customized the option `magit-revision-header-format' -and want to insert the images then you might also have to specify -where to do so. In that case the value has to be a cons-cell of -two regular expressions. The car specifies where to insert the -author's image. The top half of the image is inserted right -after the matched text, the bottom half on the next line in the -same column. The cdr specifies where to insert the committer's -image, accordingly. Either the car or the cdr may be nil." - :package-version '(magit . "2.3.0") - :group 'magit-revision - :type '(choice - (const :tag "Don't show gravatars" nil) - (const :tag "Show gravatars" t) - (const :tag "Show author gravatar" author) - (const :tag "Show committer gravatar" committer) - (cons :tag "Show gravatars using custom regexps" - (choice (const :tag "No author image" nil) - (regexp :tag "Author regexp" "^Author: ")) - (choice (const :tag "No committer image" nil) - (regexp :tag "Committer regexp" "^Commit: "))))) - -(defcustom magit-revision-fill-summary-line nil - "Whether to fill excessively long summary lines. - -If this is an integer, then the summary line is filled if it is -longer than either the limit specified here or `window-width'. - -You may want to only set this locally in \".dir-locals-2.el\" for -repositories known to contain bad commit messages. - -The body of the message is left alone because (a) most people who -write excessively long summary lines usually don't add a body and -\(b) even people who have the decency to wrap their lines may have -a good reason to include a long line in the body sometimes." - :package-version '(magit . "2.90.0") - :group 'magit-revision - :type '(choice (const :tag "Don't fill" nil) - (integer :tag "Fill if longer than"))) - -(defcustom magit-revision-filter-files-on-follow nil - "Whether to honor file filter if log arguments include --follow. - -When a commit is displayed from a log buffer, the resulting -revision buffer usually shares the log's file arguments, -restricting the diff to those files. However, there's a -complication when the log arguments include --follow: if the log -follows a file across a rename event, keeping the file -restriction would mean showing an empty diff in revision buffers -for commits before the rename event. - -When this option is nil, the revision buffer ignores the log's -filter if the log arguments include --follow. If non-nil, the -log's file filter is always honored." - :package-version '(magit . "3.0.0") - :group 'magit-revision - :type 'boolean) - -;;;; Visit Commands - -(defcustom magit-diff-visit-previous-blob t - "Whether `magit-diff-visit-file' may visit the previous blob. - -When this is t and point is on a removed line in a diff for a -committed change, then `magit-diff-visit-file' visits the blob -from the last revision which still had that line. - -Currently this is only supported for committed changes, for -staged and unstaged changes `magit-diff-visit-file' always -visits the file in the working tree." - :package-version '(magit . "2.9.0") - :group 'magit-diff - :type 'boolean) - -(defcustom magit-diff-visit-avoid-head-blob nil - "Whether `magit-diff-visit-file' avoids visiting a blob from `HEAD'. - -By default `magit-diff-visit-file' always visits the blob that -added the current line, while `magit-diff-visit-worktree-file' -visits the respective file in the working tree. For the `HEAD' -commit, the former command used to visit the worktree file too, -but that made it impossible to visit a blob from `HEAD'. - -When point is on a removed line and that change has not been -committed yet, then `magit-diff-visit-file' now visits the last -blob that still had that line, which is a blob from `HEAD'. -Previously this function used to visit the worktree file not -only for added lines but also for such removed lines. - -If you prefer the old behaviors, then set this to t." - :package-version '(magit . "3.0.0") - :group 'magit-diff - :type 'boolean) - -;;; Faces - -(defface magit-diff-file-heading - `((t ,@(and (>= emacs-major-version 27) '(:extend t)) - :weight bold)) - "Face for diff file headings." - :group 'magit-faces) - -(defface magit-diff-file-heading-highlight - `((t ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-section-highlight)) - "Face for current diff file headings." - :group 'magit-faces) - -(defface magit-diff-file-heading-selection - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-file-heading-highlight - :foreground "salmon4") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-file-heading-highlight - :foreground "LightSalmon3")) - "Face for selected diff file headings." - :group 'magit-faces) - -(defface magit-diff-hunk-heading - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey90" - :foreground "grey20") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey25" - :foreground "grey95")) - "Face for diff hunk headings." - :group 'magit-faces) - -(defface magit-diff-hunk-heading-highlight - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey80" - :foreground "grey20") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey35" - :foreground "grey95")) - "Face for current diff hunk headings." - :group 'magit-faces) - -(defface magit-diff-hunk-heading-selection - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-hunk-heading-highlight - :foreground "salmon4") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-hunk-heading-highlight - :foreground "LightSalmon3")) - "Face for selected diff hunk headings." - :group 'magit-faces) - -(defface magit-diff-hunk-region - `((t :inherit bold - ,@(and (>= emacs-major-version 27) - (list :extend (ignore-errors (face-attribute 'region :extend)))))) - "Face used by `magit-diff-highlight-hunk-region-using-face'. - -This face is overlaid over text that uses other hunk faces, -and those normally set the foreground and background colors. -The `:foreground' and especially the `:background' properties -should be avoided here. Setting the latter would cause the -loss of information. Good properties to set here are `:weight' -and `:slant'." - :group 'magit-faces) - -(defface magit-diff-revision-summary - '((t :inherit magit-diff-hunk-heading)) - "Face for commit message summaries." - :group 'magit-faces) - -(defface magit-diff-revision-summary-highlight - '((t :inherit magit-diff-hunk-heading-highlight)) - "Face for highlighted commit message summaries." - :group 'magit-faces) - -(defface magit-diff-lines-heading - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-hunk-heading-highlight - :background "LightSalmon3") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :inherit magit-diff-hunk-heading-highlight - :foreground "grey80" - :background "salmon4")) - "Face for diff hunk heading when lines are marked." - :group 'magit-faces) - -(defface magit-diff-lines-boundary - `((t ,@(and (>= emacs-major-version 27) '(:extend t)) ; !important - :inherit magit-diff-lines-heading)) - "Face for boundary of marked lines in diff hunk." - :group 'magit-faces) - -(defface magit-diff-conflict-heading - '((t :inherit magit-diff-hunk-heading)) - "Face for conflict markers." - :group 'magit-faces) - -(defface magit-diff-added - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#ddffdd" - :foreground "#22aa22") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#335533" - :foreground "#ddffdd")) - "Face for lines in a diff that have been added." - :group 'magit-faces) - -(defface magit-diff-removed - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#ffdddd" - :foreground "#aa2222") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#553333" - :foreground "#ffdddd")) - "Face for lines in a diff that have been removed." - :group 'magit-faces) - -(defface magit-diff-our - '((t :inherit magit-diff-removed)) - "Face for lines in a diff for our side in a conflict." - :group 'magit-faces) - -(defface magit-diff-base - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#ffffcc" - :foreground "#aaaa11") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#555522" - :foreground "#ffffcc")) - "Face for lines in a diff for the base side in a conflict." - :group 'magit-faces) - -(defface magit-diff-their - '((t :inherit magit-diff-added)) - "Face for lines in a diff for their side in a conflict." - :group 'magit-faces) - -(defface magit-diff-context - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :foreground "grey50") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :foreground "grey70")) - "Face for lines in a diff that are unchanged." - :group 'magit-faces) - -(defface magit-diff-added-highlight - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#cceecc" - :foreground "#22aa22") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#336633" - :foreground "#cceecc")) - "Face for lines in a diff that have been added." - :group 'magit-faces) - -(defface magit-diff-removed-highlight - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#eecccc" - :foreground "#aa2222") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#663333" - :foreground "#eecccc")) - "Face for lines in a diff that have been removed." - :group 'magit-faces) - -(defface magit-diff-our-highlight - '((t :inherit magit-diff-removed-highlight)) - "Face for lines in a diff for our side in a conflict." - :group 'magit-faces) - -(defface magit-diff-base-highlight - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#eeeebb" - :foreground "#aaaa11") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "#666622" - :foreground "#eeeebb")) - "Face for lines in a diff for the base side in a conflict." - :group 'magit-faces) - -(defface magit-diff-their-highlight - '((t :inherit magit-diff-added-highlight)) - "Face for lines in a diff for their side in a conflict." - :group 'magit-faces) - -(defface magit-diff-context-highlight - `((((class color) (background light)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey95" - :foreground "grey50") - (((class color) (background dark)) - ,@(and (>= emacs-major-version 27) '(:extend t)) - :background "grey20" - :foreground "grey70")) - "Face for lines in the current context in a diff." - :group 'magit-faces) - -(defface magit-diff-whitespace-warning - '((t :inherit trailing-whitespace)) - "Face for highlighting whitespace errors added lines." - :group 'magit-faces) - -(defface magit-diffstat-added - '((((class color) (background light)) :foreground "#22aa22") - (((class color) (background dark)) :foreground "#448844")) - "Face for plus sign in diffstat." - :group 'magit-faces) - -(defface magit-diffstat-removed - '((((class color) (background light)) :foreground "#aa2222") - (((class color) (background dark)) :foreground "#aa4444")) - "Face for minus sign in diffstat." - :group 'magit-faces) - -;;; Arguments -;;;; Prefix Classes - -(defclass magit-diff-prefix (transient-prefix) - ((history-key :initform 'magit-diff) - (major-mode :initform 'magit-diff-mode))) - -(defclass magit-diff-refresh-prefix (magit-diff-prefix) - ((history-key :initform 'magit-diff) - (major-mode :initform nil))) - -;;;; Prefix Methods - -(cl-defmethod transient-init-value ((obj magit-diff-prefix)) - (pcase-let ((`(,args ,files) - (magit-diff--get-value 'magit-diff-mode - magit-prefix-use-buffer-arguments))) - (when-let ((not (eq transient-current-command 'magit-dispatch)) - (file (magit-file-relative-name))) - (setq files (list file))) - (oset obj value (if files `(("--" ,@files) ,args) args)))) - -(cl-defmethod transient-init-value ((obj magit-diff-refresh-prefix)) - (oset obj value (if magit-buffer-diff-files - `(("--" ,@magit-buffer-diff-files) - ,magit-buffer-diff-args) - magit-buffer-diff-args))) - -(cl-defmethod transient-set-value ((obj magit-diff-prefix)) - (magit-diff--set-value obj)) - -(cl-defmethod transient-save-value ((obj magit-diff-prefix)) - (magit-diff--set-value obj 'save)) - -;;;; Argument Access - -(defun magit-diff-arguments (&optional mode) - "Return the current diff arguments." - (if (memq transient-current-command '(magit-diff magit-diff-refresh)) - (magit--transient-args-and-files) - (magit-diff--get-value (or mode 'magit-diff-mode)))) - -(defun magit-diff--get-value (mode &optional use-buffer-args) - (unless use-buffer-args - (setq use-buffer-args magit-direct-use-buffer-arguments)) - (let (args files) - (cond - ((and (memq use-buffer-args '(always selected current)) - (eq major-mode mode)) - (setq args magit-buffer-diff-args) - (setq files magit-buffer-diff-files)) - ((when-let (((memq use-buffer-args '(always selected))) - (buffer (magit-get-mode-buffer - mode nil - (eq use-buffer-args 'selected)))) - (setq args (buffer-local-value 'magit-buffer-diff-args buffer)) - (setq files (buffer-local-value 'magit-buffer-diff-files buffer)) - t)) - ((plist-member (symbol-plist mode) 'magit-diff-current-arguments) - (setq args (get mode 'magit-diff-current-arguments))) - ((when-let ((elt (assq (intern (format "magit-diff:%s" mode)) - transient-values))) - (setq args (cdr elt)) - t)) - (t - (setq args (get mode 'magit-diff-default-arguments)))) - (list args files))) - -(defun magit-diff--set-value (obj &optional save) - (pcase-let* ((obj (oref obj prototype)) - (mode (or (oref obj major-mode) major-mode)) - (key (intern (format "magit-diff:%s" mode))) - (`(,args ,files) (magit--transient-args-and-files))) - (put mode 'magit-diff-current-arguments args) - (when save - (setf (alist-get key transient-values) args) - (transient-save-values)) - (transient--history-push obj) - (setq magit-buffer-diff-args args) - (setq magit-buffer-diff-files files) - (magit-refresh))) - -;;; Commands -;;;; Prefix Commands - -;;;###autoload (autoload 'magit-diff "magit-diff" nil t) -(transient-define-prefix magit-diff () - "Show changes between different versions." - :man-page "git-diff" - :class 'magit-diff-prefix - ["Limit arguments" - (magit:--) - (magit-diff:--ignore-submodules) - ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) - ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) - (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] - ["Context arguments" - (magit-diff:-U) - ("-W" "Show surrounding functions" ("-W" "--function-context"))] - ["Tune arguments" - (magit-diff:--diff-algorithm) - (magit-diff:--diff-merges) - (magit-diff:-M) - (magit-diff:-C) - (5 "-R" "Reverse sides" "-R") - (5 magit-diff:--color-moved) - (5 magit-diff:--color-moved-ws) - ("-x" "Disallow external diff drivers" "--no-ext-diff") - ("-s" "Show stats" "--stat") - ("=g" "Show signature" "--show-signature")] - ["Actions" - [("d" "Dwim" magit-diff-dwim) - ("r" "Diff range" magit-diff-range) - ("p" "Diff paths" magit-diff-paths)] - [("u" "Diff unstaged" magit-diff-unstaged) - ("s" "Diff staged" magit-diff-staged) - ("w" "Diff worktree" magit-diff-working-tree)] - [("c" "Show commit" magit-show-commit) - ("t" "Show stash" magit-stash-show)]]) - -;;;###autoload (autoload 'magit-diff-refresh "magit-diff" nil t) -(transient-define-prefix magit-diff-refresh () - "Change the arguments used for the diff(s) in the current buffer." - :man-page "git-diff" - :class 'magit-diff-refresh-prefix - ["Limit arguments" - (magit:--) - (magit-diff:--ignore-submodules) - ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) - ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) - (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] - ["Context arguments" - (magit-diff:-U) - ("-W" "Show surrounding functions" ("-W" "--function-context"))] - ["Tune arguments" - (magit-diff:--diff-algorithm) - (magit-diff:--diff-merges) - (magit-diff:-M) - (magit-diff:-C) - (5 "-R" "Reverse sides" "-R" - :if-derived magit-diff-mode) - (5 magit-diff:--color-moved) - (5 magit-diff:--color-moved-ws) - ("-x" "Disallow external diff drivers" "--no-ext-diff") - ("-s" "Show stats" "--stat" - :if-derived magit-diff-mode) - ("=g" "Show signature" "--show-signature" - :if-derived magit-diff-mode)] - [["Refresh" - ("g" "buffer" magit-diff-refresh) - ("s" "buffer and set defaults" transient-set-and-exit) - ("w" "buffer and save defaults" transient-save-and-exit)] - ["Toggle" - ("t" "hunk refinement" magit-diff-toggle-refine-hunk) - ("F" "file filter" magit-diff-toggle-file-filter) - ("b" "buffer lock" magit-toggle-buffer-lock - :if-mode (magit-diff-mode magit-revision-mode magit-stash-mode))] - [:if-mode magit-diff-mode - :description "Do" - ("r" "switch range type" magit-diff-switch-range-type) - ("f" "flip revisions" magit-diff-flip-revs)]] - (interactive) - (when (derived-mode-p 'magit-merge-preview-mode) - (user-error "Cannot use %s in %s" this-command major-mode)) - (if (not (eq transient-current-command 'magit-diff-refresh)) - (transient-setup 'magit-diff-refresh) - (pcase-let ((`(,args ,files) (magit-diff-arguments))) - (setq magit-buffer-diff-args args) - (setq magit-buffer-diff-files files)) - (magit-refresh))) - -;;;; Infix Commands - -(transient-define-argument magit:-- () - :description "Limit to files" - :class 'transient-files - :key "--" - :argument "--" - :prompt "Limit to file,s: " - :reader #'magit-read-files - :multi-value t) - -(defun magit-read-files (prompt initial-input history &optional list-fn) - (magit-with-toplevel - (magit-completing-read-multiple prompt - (funcall (or list-fn #'magit-list-files)) - nil nil - (or initial-input (magit-file-at-point)) - history))) - -(transient-define-argument magit-diff:-U () - :description "Context lines" - :class 'transient-option - :argument "-U" - :reader #'transient-read-number-N0) - -(transient-define-argument magit-diff:-M () - :description "Detect renames" - :class 'transient-option - :argument "-M" - :allow-empty t - :reader #'transient-read-number-N+) - -(transient-define-argument magit-diff:-C () - :description "Detect copies" - :class 'transient-option - :argument "-C" - :allow-empty t - :reader #'transient-read-number-N+) - -(transient-define-argument magit-diff:--diff-algorithm () - :description "Diff algorithm" - :class 'transient-option - :key "-A" - :argument "--diff-algorithm=" - :reader #'magit-diff-select-algorithm - :always-read t) - -(defun magit-diff-select-algorithm (&rest _ignore) - (magit-read-char-case nil t - (?u "[u]nspecified" nil) - (?d "[d]efault" "default") - (?m "[m]inimal" "minimal") - (?p "[p]atience" "patience") - (?h "[h]istogram" "histogram"))) - -(transient-define-argument magit-diff:--diff-merges () - :description "Diff merges" - :class 'transient-option - :key "-X" - :argument "--diff-merges=" - :reader #'magit-diff-select-merges - :always-read t) - -(defun magit-diff-select-merges (&rest _ignore) - (magit-read-char-case nil t - (?u "[u]nspecified" nil) - (?o "[o]ff" "off") - (?f "[f]irst-parent" "first-parent") - (?c "[c]ombined" "combined") - (?d "[d]ense-combined" "dense-combined"))) - -(transient-define-argument magit-diff:--ignore-submodules () - :description "Ignore submodules" - :class 'transient-option - :key "-i" - :argument "--ignore-submodules=" - :reader #'magit-diff-select-ignore-submodules) - -(defun magit-diff-select-ignore-submodules (&rest _ignored) - (magit-read-char-case "Ignore submodules " t - (?u "[u]ntracked" "untracked") - (?d "[d]irty" "dirty") - (?a "[a]ll" "all"))) - -(transient-define-argument magit-diff:--color-moved () - :description "Color moved lines" - :class 'transient-option - :key "-m" - :argument "--color-moved=" - :reader #'magit-diff-select-color-moved-mode) - -(defun magit-diff-select-color-moved-mode (&rest _ignore) - (magit-read-char-case "Color moved " t - (?d "[d]efault" "default") - (?p "[p]lain" "plain") - (?b "[b]locks" "blocks") - (?z "[z]ebra" "zebra") - (?Z "[Z] dimmed-zebra" "dimmed-zebra"))) - -(transient-define-argument magit-diff:--color-moved-ws () - :description "Whitespace treatment for --color-moved" - :class 'transient-option - :key "=w" - :argument "--color-moved-ws=" - :reader #'magit-diff-select-color-moved-ws-mode) - -(defun magit-diff-select-color-moved-ws-mode (&rest _ignore) - (magit-read-char-case "Ignore whitespace " t - (?i "[i]ndentation" "allow-indentation-change") - (?e "[e]nd of line" "ignore-space-at-eol") - (?s "[s]pace change" "ignore-space-change") - (?a "[a]ll space" "ignore-all-space") - (?n "[n]o" "no"))) - -;;;; Setup Commands - -;;;###autoload -(defun magit-diff-dwim (&optional args files) - "Show changes for the thing at point." - (interactive (magit-diff-arguments)) - (let ((default-directory default-directory) - (section (magit-current-section))) - (cond - ((magit-section-match 'module section) - (setq default-directory - (expand-file-name - (file-name-as-directory (oref section value)))) - (magit-diff-range (oref section range))) - (t - (when (magit-section-match 'module-commit section) - (setq args nil) - (setq files nil) - (setq default-directory - (expand-file-name - (file-name-as-directory (magit-section-parent-value section))))) - (pcase (magit-diff--dwim) - ('unmerged (magit-diff-unmerged args files)) - ('unstaged (magit-diff-unstaged args files)) - ('staged - (let ((file (magit-file-at-point))) - (if (and file (equal (cddr (car (magit-file-status file))) '(?D ?U))) - ;; File was deleted by us and modified by them. Show the latter. - (magit-diff-unmerged args (list file)) - (magit-diff-staged nil args files)))) - (`(stash . ,value) (magit-stash-show value args)) - (`(commit . ,value) - (magit-diff-range (format "%s^..%s" value value) args files)) - ((and range (pred stringp)) - (magit-diff-range range args files)) - (_ (call-interactively #'magit-diff-range))))))) - -(defun magit-diff--dwim () - "Return information for performing DWIM diff. - -The information can be in three forms: -1. TYPE - A symbol describing a type of diff where no additional information - is needed to generate the diff. Currently, this includes `staged', - `unstaged' and `unmerged'. -2. (TYPE . VALUE) - Like #1 but the diff requires additional information, which is - given by VALUE. Currently, this includes `commit' and `stash', - where VALUE is the given commit or stash, respectively. -3. RANGE - A string indicating a diff range. - -If no DWIM context is found, nil is returned." - (cond - ((and-let* ((commits (magit-region-values '(commit branch) t))) - (progn - (deactivate-mark) - (concat (car (last commits)) ".." (car commits))))) - (magit-buffer-refname - (cons 'commit magit-buffer-refname)) - ((derived-mode-p 'magit-stash-mode) - (cons 'commit - (magit-section-case - (commit (oref it value)) - (file (thread-first it - (oref parent) - (oref value))) - (hunk (thread-first it - (oref parent) - (oref parent) - (oref value)))))) - ((derived-mode-p 'magit-revision-mode) - (cons 'commit magit-buffer-revision)) - ((derived-mode-p 'magit-diff-mode) - magit-buffer-range) - (t - (magit-section-case - ([* unstaged] 'unstaged) - ([* staged] 'staged) - (unmerged 'unmerged) - (unpushed (magit-diff--range-to-endpoints (oref it value))) - (unpulled (magit-diff--range-to-endpoints (oref it value))) - (branch (let ((current (magit-get-current-branch)) - (atpoint (oref it value))) - (if (equal atpoint current) - (if-let ((upstream (magit-get-upstream-branch))) - (format "%s...%s" upstream current) - (if (magit-anything-modified-p) - current - (cons 'commit current))) - (format "%s...%s" - (or current "HEAD") - atpoint)))) - (commit (cons 'commit (oref it value))) - ([file commit] (cons 'commit (oref (oref it parent) value))) - ([hunk file commit] - (cons 'commit (oref (oref (oref it parent) parent) value))) - (stash (cons 'stash (oref it value))) - (pullreq (forge--pullreq-range (oref it value) t)))))) - -(defun magit-diff--range-to-endpoints (range) - (cond ((string-match "\\.\\.\\." range) (replace-match ".." nil nil range)) - ((string-match "\\.\\." range) (replace-match "..." nil nil range)) - (t range))) - -(defun magit-diff--region-range (&optional interactive mbase) - (and-let* ((commits (magit-region-values '(commit branch) t)) - (revA (car (last commits))) - (revB (car commits))) - (progn - (when interactive - (deactivate-mark)) - (if mbase - (let ((base (magit-git-string "merge-base" revA revB))) - (cond - ((string= (magit-rev-parse revA) base) - (format "%s..%s" revA revB)) - ((string= (magit-rev-parse revB) base) - (format "%s..%s" revB revA)) - (interactive - (let ((main (magit-completing-read "View changes along" - (list revA revB) - nil t nil nil revB))) - (format "%s...%s" - (if (string= main revB) revA revB) main))) - (t "%s...%s" revA revB))) - (format "%s..%s" revA revB))))) - -(defun magit-diff-read-range-or-commit (prompt &optional secondary-default mbase) - "Read range or revision with special diff range treatment. -If MBASE is non-nil, prompt for which rev to place at the end of -a \"revA...revB\" range. Otherwise, always construct -\"revA..revB\" range." - (or (magit-diff--region-range t mbase) - (magit-read-range prompt - (or (pcase (magit-diff--dwim) - (`(commit . ,value) - (format "%s^..%s" value value)) - ((and range (pred stringp)) - range)) - secondary-default - (magit-get-current-branch))))) - -;;;###autoload -(defun magit-diff-range (rev-or-range &optional args files) - "Show differences between two commits. - -REV-OR-RANGE should be a range or a single revision. If it is a -revision, then show changes in the working tree relative to that -revision. If it is a range, but one side is omitted, then show -changes relative to `HEAD'. - -If the region is active, use the revisions on the first and last -line of the region as the two sides of the range. With a prefix -argument, instead of diffing the revisions, choose a revision to -view changes along, starting at the common ancestor of both -revisions (i.e., use a \"...\" range)." - (interactive (cons (magit-diff-read-range-or-commit "Diff for range" - nil current-prefix-arg) - (magit-diff-arguments))) - (magit-diff-setup-buffer rev-or-range nil args files 'committed)) - -;;;###autoload -(defun magit-diff-working-tree (&optional rev args files) - "Show changes between the current working tree and the `HEAD' commit. -With a prefix argument show changes between the working tree and -a commit read from the minibuffer." - (interactive - (cons (and current-prefix-arg - (magit-read-branch-or-commit "Diff working tree and commit")) - (magit-diff-arguments))) - (magit-diff-setup-buffer (or rev "HEAD") nil args files 'committed)) - -;;;###autoload -(defun magit-diff-staged (&optional rev args files) - "Show changes between the index and the `HEAD' commit. -With a prefix argument show changes between the index and -a commit read from the minibuffer." - (interactive - (cons (and current-prefix-arg - (magit-read-branch-or-commit "Diff index and commit")) - (magit-diff-arguments))) - (magit-diff-setup-buffer rev "--cached" args files 'staged)) - -;;;###autoload -(defun magit-diff-unstaged (&optional args files) - "Show changes between the working tree and the index." - (interactive (magit-diff-arguments)) - (magit-diff-setup-buffer nil nil args files 'unstaged)) - -;;;###autoload -(defun magit-diff-unmerged (&optional args files) - "Show changes that are being merged." - (interactive (magit-diff-arguments)) - (unless (magit-merge-in-progress-p) - (user-error "No merge is in progress")) - (magit-diff-setup-buffer (magit--merge-range) nil args files 'committed)) - -;;;###autoload -(defun magit-diff-while-committing () - "While committing, show the changes that are about to be committed. -While amending, invoking the command again toggles between -showing just the new changes or all the changes that will -be committed." - (interactive) - (unless (magit-commit-message-buffer) - (user-error "No commit in progress")) - (magit-commit-diff-1)) - -;;;###autoload -(defun magit-diff-buffer-file () - "Show diff for the blob or file visited in the current buffer. - -When the buffer visits a blob, then show the respective commit. -When the buffer visits a file, then show the differences between -`HEAD' and the working tree. In both cases limit the diff to -the file or blob." - (interactive) - (require 'magit) - (if-let ((file (magit-file-relative-name))) - (if magit-buffer-refname - (magit-show-commit magit-buffer-refname - (car (magit-show-commit--arguments)) - (list file)) - (save-buffer) - (let ((line (line-number-at-pos)) - (col (current-column))) - (with-current-buffer - (magit-diff-setup-buffer (or (magit-get-current-branch) "HEAD") - nil - (car (magit-diff-arguments)) - (list file) - 'unstaged - magit-diff-buffer-file-locked) - (magit-diff--goto-position file line col)))) - (user-error "Buffer isn't visiting a file"))) - -;;;###autoload -(defun magit-diff-paths (a b) - "Show changes between any two files on disk." - (interactive (list (read-file-name "First file: " nil nil t) - (read-file-name "Second file: " nil nil t))) - (magit-diff-setup-buffer nil "--no-index" nil - (list (magit-convert-filename-for-git - (expand-file-name a)) - (magit-convert-filename-for-git - (expand-file-name b))) - 'undefined)) - -(defun magit-show-commit--arguments () - (pcase-let ((`(,args ,diff-files) - (magit-diff-arguments 'magit-revision-mode))) - (list args (if (derived-mode-p 'magit-log-mode) - (and (or magit-revision-filter-files-on-follow - (not (member "--follow" magit-buffer-log-args))) - magit-buffer-log-files) - diff-files)))) - -;;;###autoload -(defun magit-show-commit (rev &optional args files module) - "Visit the revision at point in another buffer. -If there is no revision at point or with a prefix argument prompt -for a revision." - (interactive - (pcase-let* ((mcommit (magit-section-value-if 'module-commit)) - (atpoint (or mcommit - (magit-thing-at-point 'git-revision t) - (magit-branch-or-commit-at-point))) - (`(,args ,files) (magit-show-commit--arguments))) - (list (or (and (not current-prefix-arg) atpoint) - (magit-read-branch-or-commit "Show commit" atpoint)) - args - files - (and mcommit - (magit-section-parent-value (magit-current-section)))))) - (require 'magit) - (let* ((file (magit-file-relative-name)) - (ln (and file (line-number-at-pos)))) - (magit-with-toplevel - (when module - (setq default-directory - (expand-file-name (file-name-as-directory module)))) - (unless (magit-commit-p rev) - (user-error "%s is not a commit" rev)) - (when file - (save-buffer)) - (let ((buf (magit-revision-setup-buffer rev args files))) - (when file - (let ((line (magit-diff-visit--offset file (list "-R" rev) ln)) - (col (current-column))) - (with-current-buffer buf - (magit-diff--goto-position file line col)))))))) - -(defun magit-diff--locate-hunk (file line &optional parent) - (and-let* ((diff (cl-find-if (lambda (section) - (and (cl-typep section 'magit-file-section) - (equal (oref section value) file))) - (oref (or parent magit-root-section) children)))) - (let ((hunks (oref diff children))) - (cl-block nil - (while-let ((hunk (pop hunks))) - (when-let ((range (oref hunk to-range))) - (pcase-let* ((`(,beg ,len) range) - (end (+ beg len))) - (cond ((> beg line) (cl-return (list diff nil))) - ((<= beg line end) (cl-return (list hunk t))) - ((null hunks) (cl-return (list hunk nil))))))))))) - -(defun magit-diff--goto-position (file line column &optional parent) - (when-let ((pos (magit-diff--locate-hunk file line parent))) - (pcase-let ((`(,section ,exact) pos)) - (cond ((cl-typep section 'magit-file-section) - (goto-char (oref section start))) - (exact - (goto-char (oref section content)) - (let ((pos (car (oref section to-range)))) - (while (or (< pos line) - (= (char-after) ?-)) - (unless (= (char-after) ?-) - (cl-incf pos)) - (forward-line))) - (forward-char (1+ column))) - (t - (goto-char (oref section start)) - (setq section (oref section parent)))) - (while section - (when (oref section hidden) - (magit-section-show section)) - (setq section (oref section parent)))) - (magit-section-update-highlight) - t)) - -;;;; Setting Commands - -(defun magit-diff-switch-range-type () - "Convert diff range type. -Change \"revA..revB\" to \"revA...revB\", or vice versa." - (interactive) - (if (and magit-buffer-range - (derived-mode-p 'magit-diff-mode) - (string-match magit-range-re magit-buffer-range)) - (setq magit-buffer-range - (replace-match (if (string= (match-string 2 magit-buffer-range) "..") - "..." - "..") - t t magit-buffer-range 2)) - (user-error "No range to change")) - (magit-refresh)) - -(defun magit-diff-flip-revs () - "Swap revisions in diff range. -Change \"revA..revB\" to \"revB..revA\"." - (interactive) - (if (and magit-buffer-range - (derived-mode-p 'magit-diff-mode) - (string-match magit-range-re magit-buffer-range)) - (progn - (setq magit-buffer-range - (concat (match-string 3 magit-buffer-range) - (match-string 2 magit-buffer-range) - (match-string 1 magit-buffer-range))) - (magit-refresh)) - (user-error "No range to swap"))) - -(defun magit-diff-toggle-file-filter () - "Toggle the file restriction of the current buffer's diffs. -If the current buffer's mode is derived from `magit-log-mode', -toggle the file restriction in the repository's revision buffer -instead." - (interactive) - (cl-flet ((toggle () - (if (or magit-buffer-diff-files - magit-buffer-diff-files-suspended) - (cl-rotatef magit-buffer-diff-files - magit-buffer-diff-files-suspended) - (setq magit-buffer-diff-files - (transient-infix-read 'magit:--))) - (magit-refresh))) - (cond - ((derived-mode-p 'magit-log-mode - 'magit-cherry-mode - 'magit-reflog-mode) - (if-let ((buffer (magit-get-mode-buffer 'magit-revision-mode))) - (with-current-buffer buffer (toggle)) - (message "No revision buffer"))) - ((local-variable-p 'magit-buffer-diff-files) - (toggle)) - (t - (user-error "Cannot toggle file filter in this buffer"))))) - -(defun magit-diff-less-context (&optional count) - "Decrease the context for diff hunks by COUNT lines." - (interactive "p") - (magit-diff-set-context (lambda (cur) (max 0 (- (or cur 0) count))))) - -(defun magit-diff-more-context (&optional count) - "Increase the context for diff hunks by COUNT lines." - (interactive "p") - (magit-diff-set-context (lambda (cur) (+ (or cur 0) count)))) - -(defun magit-diff-default-context () - "Reset context for diff hunks to the default height." - (interactive) - (magit-diff-set-context #'ignore)) - -(defun magit-diff-set-context (fn) - (when (derived-mode-p 'magit-merge-preview-mode) - (user-error "Cannot use %s in %s" this-command major-mode)) - (let* ((def (if-let ((context (magit-get "diff.context"))) - (string-to-number context) - 3)) - (val magit-buffer-diff-args) - (arg (--first (string-match "^-U\\([0-9]+\\)?$" it) val)) - (num (if-let ((str (and arg (match-string 1 arg)))) - (string-to-number str) - def)) - (val (delete arg val)) - (num (funcall fn num)) - (arg (and num (not (= num def)) (format "-U%d" num))) - (val (if arg (cons arg val) val))) - (setq magit-buffer-diff-args val)) - (magit-refresh)) - -(defun magit-diff-context-p () - (if-let ((arg (--first (string-match "^-U\\([0-9]+\\)$" it) - magit-buffer-diff-args))) - (not (equal arg "-U0")) - t)) - -(defun magit-diff-ignore-any-space-p () - (--any-p (member it magit-buffer-diff-args) - '("--ignore-cr-at-eol" - "--ignore-space-at-eol" - "--ignore-space-change" "-b" - "--ignore-all-space" "-w" - "--ignore-blank-space"))) - -(defun magit-diff-toggle-refine-hunk (&optional style) - "Turn diff-hunk refining on or off. - -If hunk refining is currently on, then hunk refining is turned off. -If hunk refining is off, then hunk refining is turned on, in -`selected' mode (only the currently selected hunk is refined). - -With a prefix argument, the \"third choice\" is used instead: -If hunk refining is currently on, then refining is kept on, but -the refining mode (`selected' or `all') is switched. -If hunk refining is off, then hunk refining is turned on, in -`all' mode (all hunks refined). - -Customize variable `magit-diff-refine-hunk' to change the default mode." - (interactive "P") - (setq-local magit-diff-refine-hunk - (if style - (if (eq magit-diff-refine-hunk 'all) t 'all) - (not magit-diff-refine-hunk))) - (magit-diff-update-hunk-refinement)) - -;;;; Visit Commands -;;;;; Dwim Variants - -(defun magit-diff-visit-file (file &optional other-window) - "From a diff visit the appropriate version of FILE. - -Display the buffer in the selected window. With a prefix -argument OTHER-WINDOW display the buffer in another window -instead. - -Visit the worktree version of the appropriate file. The location -of point inside the diff determines which file is being visited. -The visited version depends on what changes the diff is about. - -1. If the diff shows uncommitted changes (i.e., stage or unstaged - changes), then visit the file in the working tree (i.e., the - same \"real\" file that `find-file' would visit). In all - other cases visit a \"blob\" (i.e., the version of a file as - stored in some commit). - -2. If point is on a removed line, then visit the blob for the - first parent of the commit that removed that line, i.e., the - last commit where that line still exists. - -3. If point is on an added or context line, then visit the blob - that adds that line, or if the diff shows from more than a - single commit, then visit the blob from the last of these - commits. - -In the file-visiting buffer also go to the line that corresponds -to the line that point is on in the diff. - -Note that this command only works if point is inside a diff. -In other cases `magit-find-file' (which see) has to be used." - (interactive (list (magit-diff--file-at-point t t) current-prefix-arg)) - (magit-diff-visit-file--internal file nil - (if other-window - #'switch-to-buffer-other-window - #'pop-to-buffer-same-window))) - -(defun magit-diff-visit-file-other-window (file) - "From a diff visit the appropriate version of FILE in another window. -Like `magit-diff-visit-file' but use -`switch-to-buffer-other-window'." - (interactive (list (magit-diff--file-at-point t t))) - (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-window)) - -(defun magit-diff-visit-file-other-frame (file) - "From a diff visit the appropriate version of FILE in another frame. -Like `magit-diff-visit-file' but use -`switch-to-buffer-other-frame'." - (interactive (list (magit-diff--file-at-point t t))) - (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-frame)) - -;;;;; Worktree Variants - -(defun magit-diff-visit-worktree-file (file &optional other-window) - "From a diff visit the worktree version of FILE. - -Display the buffer in the selected window. With a prefix -argument OTHER-WINDOW display the buffer in another window -instead. - -Visit the worktree version of the appropriate file. The location -of point inside the diff determines which file is being visited. - -Unlike `magit-diff-visit-file' always visits the \"real\" file in -the working tree, i.e the \"current version\" of the file. - -In the file-visiting buffer also go to the line that corresponds -to the line that point is on in the diff. Lines that were added -or removed in the working tree, the index and other commits in -between are automatically accounted for." - (interactive (list (magit-file-at-point t t) current-prefix-arg)) - (magit-diff-visit-file--internal file t - (if other-window - #'switch-to-buffer-other-window - #'pop-to-buffer-same-window))) - -(defun magit-diff-visit-worktree-file-other-window (file) - "From a diff visit the worktree version of FILE in another window. -Like `magit-diff-visit-worktree-file' but use -`switch-to-buffer-other-window'." - (interactive (list (magit-file-at-point t t))) - (magit-diff-visit-file--internal file t #'switch-to-buffer-other-window)) - -(defun magit-diff-visit-worktree-file-other-frame (file) - "From a diff visit the worktree version of FILE in another frame. -Like `magit-diff-visit-worktree-file' but use -`switch-to-buffer-other-frame'." - (interactive (list (magit-file-at-point t t))) - (magit-diff-visit-file--internal file t #'switch-to-buffer-other-frame)) - -;;;;; Internal - -(defun magit-diff-visit-file--internal (file force-worktree fn) - "From a diff visit the appropriate version of FILE. -If FORCE-WORKTREE is non-nil, then visit the worktree version of -the file, even if the diff is about a committed change. Use FN -to display the buffer in some window." - (if (file-accessible-directory-p file) - (magit-diff-visit-directory file force-worktree) - (pcase-let ((`(,buf ,pos) - (magit-diff-visit-file--noselect file force-worktree))) - (funcall fn buf) - (magit-diff-visit-file--setup buf pos) - buf))) - -(defun magit-diff-visit-directory (directory &optional other-window) - "Visit DIRECTORY in some window. -Display the buffer in the selected window unless OTHER-WINDOW is -non-nil. If DIRECTORY is the top-level directory of the current -repository, then visit the containing directory using Dired and -in the Dired buffer put point on DIRECTORY. Otherwise display -the Magit-Status buffer for DIRECTORY." - (if (equal (magit-toplevel directory) - (magit-toplevel)) - (dired-jump other-window (concat directory "/.")) - (let ((display-buffer-overriding-action - (if other-window - '(nil (inhibit-same-window . t)) - '(display-buffer-same-window)))) - (magit-status-setup-buffer directory)))) - -(defun magit-diff-visit-file--setup (buf pos) - (if-let ((win (get-buffer-window buf 'visible))) - (with-selected-window win - (when pos - (unless (<= (point-min) pos (point-max)) - (widen)) - (goto-char pos)) - (when (and buffer-file-name - (magit-anything-unmerged-p buffer-file-name)) - (smerge-start-session)) - (run-hooks 'magit-diff-visit-file-hook)) - (error "File buffer is not visible"))) - -(defun magit-diff-visit-file--noselect (&optional file goto-worktree) - (unless file - (setq file (magit-diff--file-at-point t t))) - (let* ((hunk (magit-diff-visit--hunk)) - (goto-from (and hunk - (magit-diff-visit--goto-from-p hunk goto-worktree))) - (line (and hunk (magit-diff-hunk-line hunk goto-from))) - (col (and hunk (magit-diff-hunk-column hunk goto-from))) - (spec (magit-diff--dwim)) - (rev (if goto-from - (magit-diff-visit--range-from spec) - (magit-diff-visit--range-to spec))) - (buf (if (or goto-worktree - (equal magit-buffer-typearg "--no-index") - (and (not (stringp rev)) - (or magit-diff-visit-avoid-head-blob - (not goto-from)))) - (or (get-file-buffer file) - (find-file-noselect file)) - (magit-find-file-noselect (if (stringp rev) rev "HEAD") - file)))) - (if line - (with-current-buffer buf - (cond ((eq rev 'staged) - (setq line (magit-diff-visit--offset file nil line))) - ((and goto-worktree - (stringp rev)) - (setq line (magit-diff-visit--offset file rev line)))) - (list buf (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- line)) - (move-to-column col) - (point)))) - (list buf nil)))) - -(defun magit-diff--file-at-point (&optional expand assert) - ;; This is a variation of magit-file-at-point. - (if-let* ((file-section (magit-section-case - (file it) - (hunk (oref it parent)))) - (file (or (and (magit-section-match 'hunk) - (magit-diff-visit--goto-from-p - (magit-current-section) nil) - (oref file-section source)) - (oref file-section value)))) - (cond ((equal magit-buffer-typearg "--no-index") - (concat "/" file)) - (expand (expand-file-name file (magit-toplevel))) - (file)) - (when assert - (user-error "No file at point")))) - -(defun magit-diff-visit--hunk () - (and-let* ((scope (magit-diff-scope)) - (section (magit-current-section))) - (progn - (cl-case scope - ((file files) - (setq section (car (oref section children)))) - (list - (setq section (car (oref section children))) - (when section - (setq section (car (oref section children)))))) - (and - ;; Unmerged files appear in the list of staged changes - ;; but unlike in the list of unstaged changes no diffs - ;; are shown here. In that case `section' is nil. - section - ;; Currently the `hunk' type is also abused for file - ;; mode changes, which we are not interested in here. - (not (equal (oref section value) '(chmod))) - section)))) - -(defun magit-diff-visit--goto-from-p (section in-worktree) - (and magit-diff-visit-previous-blob - (not in-worktree) - (not (oref section combined)) - (not (< (magit-point) (oref section content))) - (= (char-after (line-beginning-position)) ?-))) - -(defvar magit-diff-visit-jump-to-change t) - -(defun magit-diff-hunk-line (section goto-from) - (save-excursion - (goto-char (line-beginning-position)) - (with-slots (content combined from-ranges from-range to-range) section - (when (or from-range to-range) - (when (and magit-diff-visit-jump-to-change (< (point) content)) - (goto-char content) - (re-search-forward "^[-+]")) - (+ (car (if goto-from from-range to-range)) - (let ((prefix (if combined (length from-ranges) 1)) - (target (point)) - (offset 0)) - (goto-char content) - (while (< (point) target) - (unless (string-search - (if goto-from "+" "-") - (buffer-substring (point) (+ (point) prefix))) - (cl-incf offset)) - (forward-line)) - offset)))))) - -(defun magit-diff-hunk-column (section goto-from) - (if (or (< (magit-point) - (oref section content)) - (and (not goto-from) - (= (char-after (line-beginning-position)) ?-))) - 0 - (max 0 (- (+ (current-column) 2) - (length (oref section value)))))) - -(defun magit-diff-visit--range-from (spec) - (cond ((consp spec) - (concat (cdr spec) "^")) - ((stringp spec) - (car (magit-split-range spec))) - (t - spec))) - -(defun magit-diff-visit--range-to (spec) - (if (symbolp spec) - spec - (let ((rev (if (consp spec) - (cdr spec) - (cdr (magit-split-range spec))))) - (if (and magit-diff-visit-avoid-head-blob - (magit-rev-head-p rev)) - 'unstaged - rev)))) - -(defun magit-diff-visit--offset (file rev line) - (let ((offset 0)) - (with-temp-buffer - (save-excursion - (magit-with-toplevel - (magit-git-insert "diff" rev "--" file))) - (catch 'found - (while (re-search-forward - "^@@ -\\([0-9]+\\),\\([0-9]+\\) \\+\\([0-9]+\\),\\([0-9]+\\) @@.*\n" - nil t) - (let ((from-beg (string-to-number (match-string 1))) - (from-len (string-to-number (match-string 2))) - ( to-len (string-to-number (match-string 4)))) - (if (<= from-beg line) - (if (< (+ from-beg from-len) line) - (cl-incf offset (- to-len from-len)) - (let ((rest (- line from-beg))) - (while (> rest 0) - (pcase (char-after) - (?\s (cl-decf rest)) - (?- (cl-decf offset) (cl-decf rest)) - (?+ (cl-incf offset))) - (forward-line)))) - (throw 'found nil)))))) - (+ line offset))) - -;;;; Scroll Commands - -(defun magit-diff-show-or-scroll-up () - "Update the commit or diff buffer for the thing at point. - -Either show the commit or stash at point in the appropriate -buffer, or if that buffer is already being displayed in the -current frame and contains information about that commit or -stash, then instead scroll the buffer up. If there is no -commit or stash at point, then prompt for a commit." - (interactive) - (magit-diff-show-or-scroll #'scroll-up)) - -(defun magit-diff-show-or-scroll-down () - "Update the commit or diff buffer for the thing at point. - -Either show the commit or stash at point in the appropriate -buffer, or if that buffer is already being displayed in the -current frame and contains information about that commit or -stash, then instead scroll the buffer down. If there is no -commit or stash at point, then prompt for a commit." - (interactive) - (magit-diff-show-or-scroll #'scroll-down)) - -(defun magit-diff-show-or-scroll (fn) - (let (rev cmd buf win) - (cond - ((and (bound-and-true-p magit-blame-mode) - (fboundp 'magit-current-blame-chunk)) - (setq rev (oref (magit-current-blame-chunk) orig-rev)) - (setq cmd #'magit-show-commit) - (setq buf (magit-get-mode-buffer 'magit-revision-mode))) - ((derived-mode-p 'git-rebase-mode) - (with-slots (action-type target) - (git-rebase-current-line) - (if (not (eq action-type 'commit)) - (user-error "No commit on this line") - (setq rev target) - (setq cmd #'magit-show-commit) - (setq buf (magit-get-mode-buffer 'magit-revision-mode))))) - (t - (magit-section-case - (branch - (setq rev (magit-ref-maybe-qualify (oref it value))) - (setq cmd #'magit-show-commit) - (setq buf (magit-get-mode-buffer 'magit-revision-mode))) - (commit - (setq rev (oref it value)) - (setq cmd #'magit-show-commit) - (setq buf (magit-get-mode-buffer 'magit-revision-mode))) - (tag - (setq rev (magit-rev-hash (oref it value))) - (setq cmd #'magit-show-commit) - (setq buf (magit-get-mode-buffer 'magit-revision-mode))) - (stash - (setq rev (oref it value)) - (setq cmd #'magit-stash-show) - (setq buf (magit-get-mode-buffer 'magit-stash-mode)))))) - (if rev - (if (and buf - (setq win (get-buffer-window buf)) - (with-current-buffer buf - (and (equal rev magit-buffer-revision) - (equal (magit-rev-parse rev) - magit-buffer-revision-hash)))) - (with-selected-window win - (condition-case nil - (funcall fn) - (error - (goto-char (pcase fn - ('scroll-up (point-min)) - ('scroll-down (point-max))))))) - (let ((magit-display-buffer-noselect t)) - (if (eq cmd #'magit-show-commit) - (apply #'magit-show-commit rev (magit-show-commit--arguments)) - (funcall cmd rev)))) - (call-interactively #'magit-show-commit)))) - -;;;; Section Commands - -(defun magit-section-cycle-diffs () - "Cycle visibility of diff-related sections in the current buffer." - (interactive) - (when-let ((sections - (cond ((derived-mode-p 'magit-status-mode) - (--mapcat - (when it - (when (oref it hidden) - (magit-section-show it)) - (oref it children)) - (list (magit-get-section '((staged) (status))) - (magit-get-section '((unstaged) (status)))))) - ((derived-mode-p 'magit-diff-mode) - (seq-filter #'magit-file-section-p - (oref magit-root-section children)))))) - (if (--any-p (oref it hidden) sections) - (dolist (s sections) - (magit-section-show s) - (magit-section-hide-children s)) - (let ((children (--mapcat (oref it children) sections))) - (cond ((and (--any-p (oref it hidden) children) - (--any-p (oref it children) children)) - (mapc #'magit-section-show-headings sections)) - ((seq-some #'magit-section-hidden-body children) - (mapc #'magit-section-show-children sections)) - (t - (mapc #'magit-section-hide sections))))))) - -;;; Diff Mode - -(defvar-keymap magit-diff-mode-map - :doc "Keymap for `magit-diff-mode'." - :parent magit-mode-map - "C-c C-d" #'magit-diff-while-committing - "C-c C-b" #'magit-go-backward - "C-c C-f" #'magit-go-forward - "SPC" #'scroll-up - "DEL" #'scroll-down - "j" #'magit-jump-to-diffstat-or-diff - "<remap> <write-file>" #'magit-patch-save) - -(define-derived-mode magit-diff-mode magit-mode "Magit Diff" - "Mode for looking at a Git diff. - -This mode is documented in info node `(magit)Diff Buffer'. - -\\<magit-mode-map>\ -Type \\[magit-refresh] to refresh the current buffer. -Type \\[magit-section-toggle] to expand or hide the section at point. -Type \\[magit-visit-thing] to visit the hunk or file at point. - -Staging and applying changes is documented in info node -`(magit)Staging and Unstaging' and info node `(magit)Applying'. - -\\<magit-hunk-section-map>Type \ -\\[magit-apply] to apply the change at point, \ -\\[magit-stage] to stage, -\\[magit-unstage] to unstage, \ -\\[magit-discard] to discard, or \ -\\[magit-reverse] to reverse it. - -\\{magit-diff-mode-map}" - :interactive nil - :group 'magit-diff - (magit-hack-dir-local-variables) - (setq magit--imenu-item-types 'file)) - -(put 'magit-diff-mode 'magit-diff-default-arguments - '("--stat" "--no-ext-diff")) - -(defun magit-diff-setup-buffer ( range typearg args files - &optional type locked) - (require 'magit) - (magit-setup-buffer #'magit-diff-mode locked - (magit-buffer-range range) - (magit-buffer-typearg typearg) - (magit-buffer-diff-type type) - (magit-buffer-diff-args args) - (magit-buffer-diff-files files) - (magit-buffer-diff-files-suspended nil))) - -(defun magit-diff-refresh-buffer () - "Refresh the current `magit-diff-mode' buffer." - (magit-set-header-line-format - (if (equal magit-buffer-typearg "--no-index") - (apply #'format "Differences between %s and %s" magit-buffer-diff-files) - (concat (if magit-buffer-range - (if (string-match-p "\\(\\.\\.\\|\\^-\\)" - magit-buffer-range) - (format "Changes in %s" magit-buffer-range) - (let ((msg "Changes from %s to %s") - (end (if (equal magit-buffer-typearg "--cached") - "index" - "working tree"))) - (if (member "-R" magit-buffer-diff-args) - (format msg end magit-buffer-range) - (format msg magit-buffer-range end)))) - (cond ((equal magit-buffer-typearg "--cached") - "Staged changes") - ((and (magit-repository-local-get 'this-commit-command) - (not (magit-anything-staged-p))) - "Uncommitting changes") - (t "Unstaged changes"))) - (pcase (length magit-buffer-diff-files) - (0) - (1 (concat " in file " (car magit-buffer-diff-files))) - (_ (concat " in files " - (string-join magit-buffer-diff-files ", "))))))) - (setq magit-buffer-range-hashed - (and magit-buffer-range (magit-hash-range magit-buffer-range))) - (magit-insert-section (diffbuf) - (magit-run-section-hook 'magit-diff-sections-hook))) - -(cl-defmethod magit-buffer-value (&context (major-mode magit-diff-mode)) - (nconc (cond (magit-buffer-range - (delq nil (list magit-buffer-range magit-buffer-typearg))) - ((equal magit-buffer-typearg "--cached") - (list 'staged)) - (t - (list 'unstaged magit-buffer-typearg))) - (and magit-buffer-diff-files (cons "--" magit-buffer-diff-files)))) - -(cl-defmethod magit-menu-common-value ((_section magit-diff-section)) - (magit-diff-scope)) - -(define-obsolete-variable-alias 'magit-diff-section-base-map - 'magit-diff-section-map "Magit-Section 4.0.0") - -(defvar-keymap magit-diff-section-map - :doc "Keymap for diff sections. -The classes `magit-file-section' and `magit-hunk-section' derive -from the abstract `magit-diff-section' class. Accordingly this -keymap is the parent of their keymaps." - "C-j" #'magit-diff-visit-worktree-file - "C-<return>" #'magit-diff-visit-worktree-file - "C-x 4 <return>" #'magit-diff-visit-file-other-window - "C-x 5 <return>" #'magit-diff-visit-file-other-frame - "&" #'magit-do-async-shell-command - "C" #'magit-commit-add-log - "C-x a" #'magit-add-change-log-entry - "C-x 4 a" #'magit-add-change-log-entry-other-window - "C-c C-t" #'magit-diff-trace-definition - "C-c C-e" #'magit-diff-edit-hunk-commit - "<remap> <magit-file-rename>" #'magit-file-rename - "<remap> <magit-file-untrack>" #'magit-file-untrack - "<remap> <magit-visit-thing>" #'magit-diff-visit-file - "<remap> <magit-revert-no-commit>" #'magit-reverse - "<remap> <magit-delete-thing>" #'magit-discard - "<remap> <magit-unstage-file>" #'magit-unstage - "<remap> <magit-stage-file>" #'magit-stage - "<remap> <magit-cherry-apply>" #'magit-apply - "<8>" (magit-menu-item "Rename file" #'magit-file-rename - '(:enable (eq (magit-diff-scope) 'file))) - "<7>" (magit-menu-item "Untrack %x" #'magit-file-untrack) - "<6>" (magit-menu-item "Visit file" #'magit-diff-visit-file - '(:enable (memq (magit-diff-scope) '(file files)))) - "<5>" (magit-menu-item "Reverse %x" #'magit-reverse - '(:enable (not (memq (magit-diff-type) - '(untracked unstaged))))) - "<4>" (magit-menu-item "Discard %x" #'magit-discard - '(:enable (not (memq (magit-diff-type) - '(committed undefined))))) - "<3>" (magit-menu-item "Unstage %x" #'magit-unstage - '(:enable (eq (magit-diff-type) 'staged))) - "<2>" (magit-menu-item "Stage %x" #'magit-stage - '(:enable (eq (magit-diff-type) 'unstaged))) - "<1>" (magit-menu-item "Apply %x" #'magit-apply - '(:enable (not (memq (magit-diff-type) - '(unstaged staged)))))) - -(defvar-keymap magit-file-section-map - ;; Even though this derived map doesn't add any bindings by default, - ;; it is quite possible that some users would want to add their own. - :doc "Keymap for `file' sections." - :parent magit-diff-section-base-map) - -(defvar-keymap magit-hunk-section-smerge-map - :doc "Keymap bound to `smerge-command-prefix' in `magit-hunk-section-map'." - "RET" #'magit-smerge-keep-current - "a" #'magit-smerge-keep-all - "u" #'magit-smerge-keep-upper - "b" #'magit-smerge-keep-base - "l" #'magit-smerge-keep-lower) - -(defvar-keymap magit-hunk-section-map - :doc "Keymap for `hunk' sections." - :parent magit-diff-section-base-map - (key-description smerge-command-prefix) magit-hunk-section-smerge-map) - -(defconst magit-diff-conflict-headline-re - (concat "^" (regexp-opt - ;; Defined in merge-tree.c in this order. - '("merged" - "added in remote" - "added in both" - "added in local" - "removed in both" - "changed in both" - "removed in local" - "removed in remote")))) - -(defconst magit-diff-headline-re - (concat "^\\(@@@?\\|diff\\|Submodule\\|" - "\\* Unmerged path\\|" - (substring magit-diff-conflict-headline-re 1) - "\\)")) - -(defconst magit-diff-statline-re - (concat "^ ?" - "\\(.*\\)" ; file - "\\( +| +\\)" ; separator - "\\([0-9]+\\|Bin\\(?: +[0-9]+ -> [0-9]+ bytes\\)?$\\) ?" - "\\(\\+*\\)" ; add - "\\(-*\\)$")) ; del - -(defvar magit-diff--reset-non-color-moved - (list - "-c" "color.diff.context=normal" - "-c" "color.diff.plain=normal" ; historical synonym for context - "-c" "color.diff.meta=normal" - "-c" "color.diff.frag=normal" - "-c" "color.diff.func=normal" - "-c" "color.diff.old=normal" - "-c" "color.diff.new=normal" - "-c" "color.diff.commit=normal" - "-c" "color.diff.whitespace=normal" - ;; "git-range-diff" does not support "--color-moved", so we don't - ;; need to reset contextDimmed, oldDimmed, newDimmed, contextBold, - ;; oldBold, and newBold. - )) - -(defun magit-insert-diff () - "Insert the diff into this `magit-diff-mode' buffer." - (magit--insert-diff t - "diff" magit-buffer-range "-p" "--no-prefix" - (and (member "--stat" magit-buffer-diff-args) "--numstat") - magit-buffer-typearg - magit-buffer-diff-args "--" - magit-buffer-diff-files)) - -(defun magit--insert-diff (keep-error &rest args) - (declare (indent 1)) - (pcase-let ((`(,cmd . ,args) - (flatten-tree args)) - (magit-git-global-arguments - (remove "--literal-pathspecs" magit-git-global-arguments))) - ;; As of Git 2.19.0, we need to generate diffs with - ;; --ita-visible-in-index so that `magit-stage' can work with - ;; intent-to-add files (see #4026). - (when (and (not (equal cmd "merge-tree")) - (magit-git-version>= "2.19.0")) - (push "--ita-visible-in-index" args)) - (setq args (magit-diff--maybe-add-stat-arguments args)) - (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) - (push "--color=always" args) - (setq magit-git-global-arguments - (append magit-diff--reset-non-color-moved - magit-git-global-arguments))) - (magit--git-wash #'magit-diff-wash-diffs - (if (member "--no-index" args) 'wash-anyway keep-error) - cmd args))) - -(defun magit-diff--maybe-add-stat-arguments (args) - (if (member "--stat" args) - (append (if (functionp magit-diff-extra-stat-arguments) - (funcall magit-diff-extra-stat-arguments) - magit-diff-extra-stat-arguments) - args) - args)) - -(defun magit-diff-use-window-width-as-stat-width () - "Use the `window-width' as the value of `--stat-width'." - (and-let* ((window (get-buffer-window (current-buffer) 'visible))) - (list (format "--stat-width=%d" (window-width window))))) - -(defun magit-diff-wash-diffs (args &optional limit) - (run-hooks 'magit-diff-wash-diffs-hook) - (when (member "--show-signature" args) - (magit-diff-wash-signature magit-buffer-revision-hash)) - (when (member "--stat" args) - (magit-diff-wash-diffstat)) - (when (re-search-forward magit-diff-headline-re limit t) - (goto-char (line-beginning-position)) - (magit-wash-sequence (apply-partially #'magit-diff-wash-diff args)) - (insert ?\n))) - -(defun magit-jump-to-diffstat-or-diff () - "Jump to the diffstat or diff. -When point is on a file inside the diffstat section, then jump -to the respective diff section, otherwise jump to the diffstat -section or a child thereof." - (interactive) - (if-let ((section (magit-get-section - (append (magit-section-case - ([file diffstat] `((file . ,(oref it value)))) - (file `((file . ,(oref it value)) (diffstat))) - (t '((diffstat)))) - (magit-section-ident magit-root-section))))) - (magit-section-goto section) - (user-error "No diffstat in this buffer"))) - -(defun magit-diff-wash-signature (object) - (cond - ((looking-at "^No signature") - (delete-line)) - ((looking-at "^gpg: ") - (let (title end) - (save-excursion - (while (looking-at "^gpg: ") - (cond - ((looking-at "^gpg: Good signature from") - (setq title (propertize - (buffer-substring (point) (line-end-position)) - 'face 'magit-signature-good))) - ((looking-at "^gpg: Can't check signature") - (setq title (propertize - (buffer-substring (point) (line-end-position)) - 'face '(italic bold))))) - (forward-line)) - (setq end (point-marker))) - (magit-insert-section (signature object title) - (when title - (magit-insert-heading title)) - (goto-char end) - (set-marker end nil) - (insert "\n")))))) - -(defun magit-diff-wash-diffstat () - (let (heading (beg (point))) - (when (re-search-forward "^ ?\\([0-9]+ +files? change[^\n]*\n\\)" nil t) - (setq heading (match-string 1)) - (magit-delete-match) - (goto-char beg) - (magit-insert-section (diffstat) - (insert (propertize heading 'font-lock-face 'magit-diff-file-heading)) - (magit-insert-heading) - (let (files) - (while (looking-at "^[-0-9]+\t[-0-9]+\t\\(.+\\)$") - (push (magit-decode-git-path - (let ((f (match-string 1))) - (cond - ((string-match "{.* => \\(.*\\)}" f) - (replace-match (match-string 1 f) nil t f)) - ((string-match " => " f) - (substring f (match-end 0))) - (t f)))) - files) - (magit-delete-line)) - (setq files (nreverse files)) - (while (looking-at magit-diff-statline-re) - (magit-bind-match-strings (file sep cnt add del) nil - (magit-delete-line) - (when (string-match " +$" file) - (setq sep (concat (match-string 0 file) sep)) - (setq file (substring file 0 (match-beginning 0)))) - (let ((le (length file)) ld) - (setq file (magit-decode-git-path file)) - (setq ld (length file)) - (when (> le ld) - (setq sep (concat (make-string (- le ld) ?\s) sep)))) - (magit-insert-section (file (pop files)) - (insert (propertize file 'font-lock-face 'magit-filename) - sep cnt " ") - (when add - (insert (propertize add 'font-lock-face - 'magit-diffstat-added))) - (when del - (insert (propertize del 'font-lock-face - 'magit-diffstat-removed))) - (insert "\n"))))) - (if (looking-at "^$") (forward-line) (insert "\n")))))) - -(defun magit-diff-wash-diff (args) - (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) - (require 'ansi-color) - (ansi-color-apply-on-region (point-min) (point-max))) - (cond - ((looking-at "^Submodule") - (magit-diff-wash-submodule)) - ((looking-at "^\\* Unmerged path \\(.*\\)") - (let ((file (magit-decode-git-path (match-string 1)))) - (magit-delete-line) - (unless (and (derived-mode-p 'magit-status-mode) - (not (member "--cached" args))) - (magit-insert-section (file file) - (insert (propertize - (format "unmerged %s%s" file - (pcase (cddr (car (magit-file-status file))) - ('(?D ?D) " (both deleted)") - ('(?D ?U) " (deleted by us)") - ('(?U ?D) " (deleted by them)") - ('(?A ?A) " (both added)") - ('(?A ?U) " (added by us)") - ('(?U ?A) " (added by them)") - ('(?U ?U) ""))) - 'font-lock-face 'magit-diff-file-heading)) - (insert ?\n)))) - t) - ((looking-at magit-diff-conflict-headline-re) - (let ((long-status (match-string 0)) - (status "BUG") - file orig base) - (if (equal long-status "merged") - (progn (setq status long-status) - (setq long-status nil)) - (setq status (pcase-exhaustive long-status - ("added in remote" "new file") - ("added in both" "new file") - ("added in local" "new file") - ("removed in both" "removed") - ("changed in both" "changed") - ("removed in local" "removed") - ("removed in remote" "removed")))) - (magit-delete-line) - (while (looking-at - "^ \\([^ ]+\\) +[0-9]\\{6\\} \\([a-z0-9]\\{40,\\}\\) \\(.+\\)$") - (magit-bind-match-strings (side _blob name) nil - (pcase side - ("result" (setq file name)) - ("our" (setq orig name)) - ("their" (setq file name)) - ("base" (setq base name)))) - (magit-delete-line)) - (when orig (setq orig (magit-decode-git-path orig))) - (when file (setq file (magit-decode-git-path file))) - (magit-diff-insert-file-section - (or file base) orig status nil nil nil nil long-status))) - ;; The files on this line may be ambiguous due to whitespace. - ;; That's okay. We can get their names from subsequent headers. - ((looking-at "^diff --\ -\\(?:\\(?1:git\\) \\(?:\\(?2:.+?\\) \\2\\)?\ -\\|\\(?:cc\\|combined\\) \\(?3:.+\\)\\)") - (let ((status (cond ((equal (match-string 1) "git") "modified") - ((derived-mode-p 'magit-revision-mode) "resolved") - (t "unmerged"))) - (orig nil) - (file (or (match-string 2) (match-string 3))) - (header (list (buffer-substring-no-properties - (line-beginning-position) (1+ (line-end-position))))) - (modes nil) - (rename nil) - (binary nil)) - (magit-delete-line) - (while (not (or (eobp) (looking-at magit-diff-headline-re))) - (cond - ((looking-at "old mode \\(?:[^\n]+\\)\nnew mode \\(?:[^\n]+\\)\n") - (setq modes (match-string 0))) - ((looking-at "deleted file .+\n") - (setq status "deleted")) - ((looking-at "new file .+\n") - (setq status "new file")) - ((looking-at "rename from \\(.+\\)\nrename to \\(.+\\)\n") - (setq rename (match-string 0)) - (setq orig (match-string 1)) - (setq file (match-string 2)) - (setq status "renamed")) - ((looking-at "copy from \\(.+\\)\ncopy to \\(.+\\)\n") - (setq orig (match-string 1)) - (setq file (match-string 2)) - (setq status "new file")) - ((looking-at "similarity index .+\n")) - ((looking-at "dissimilarity index .+\n")) - ((looking-at "index .+\n")) - ((looking-at "--- \\(.+?\\)\t?\n") - (unless (equal (match-string 1) "/dev/null") - (setq orig (match-string 1)))) - ((looking-at "\\+\\+\\+ \\(.+?\\)\t?\n") - (unless (equal (match-string 1) "/dev/null") - (setq file (match-string 1)))) - ((looking-at "Binary files .+ and .+ differ\n") - (setq binary t)) - ((looking-at "Binary files differ\n") - (setq binary t)) - ;; TODO Use all combined diff extended headers. - ((looking-at "mode .+\n")) - ((error "BUG: Unknown extended header: %S" - (buffer-substring (point) (line-end-position))))) - ;; These headers are treated as some sort of special hunk. - (unless (or (string-prefix-p "old mode" (match-string 0)) - (string-prefix-p "rename" (match-string 0))) - (push (match-string 0) header)) - (magit-delete-match)) - (when orig - (setq orig (magit-decode-git-path orig))) - (setq file (magit-decode-git-path file)) - (setq header (nreverse header)) - ;; KLUDGE `git-log' ignores `--no-prefix' when `-L' is used. - (when (and (derived-mode-p 'magit-log-mode) - (seq-some (lambda (arg) (string-prefix-p "-L" arg)) - magit-buffer-log-args)) - (when orig - (setq orig (substring orig 2))) - (setq file (substring file 2)) - (setq header (list (save-excursion - (string-match "diff [^ ]+" (car header)) - (format "%s %s %s\n" - (match-string 0 (car header)) - (or orig file) - (or file orig))) - (format "--- %s\n" (or orig "/dev/null")) - (format "+++ %s\n" (or file "/dev/null"))))) - (setq header (string-join header)) - (magit-diff-insert-file-section - file orig status modes rename header binary nil))))) - -(defun magit-diff-insert-file-section - (file orig status modes rename header binary long-status) - (magit-insert-section - ( file file - (or (equal status "deleted") (derived-mode-p 'magit-status-mode)) - :source (and (not (equal orig file)) orig) - :header header - :binary binary) - (insert (propertize (format "%-10s %s" status - (if (or (not orig) (equal orig file)) - file - (format "%s -> %s" orig file))) - 'font-lock-face 'magit-diff-file-heading)) - (cond ((and binary long-status) - (insert (format " (%s, binary)" long-status))) - ((or binary long-status) - (insert (format " (%s)" (if binary "binary" long-status))))) - (magit-insert-heading) - (when modes - (magit-insert-section (hunk '(chmod)) - (insert modes) - (magit-insert-heading))) - (when rename - (magit-insert-section (hunk '(rename)) - (insert rename) - (magit-insert-heading))) - (magit-wash-sequence #'magit-diff-wash-hunk))) - -(defun magit-diff-wash-submodule () - ;; See `show_submodule_summary' in submodule.c and "this" commit. - (when (looking-at "^Submodule \\([^ ]+\\)") - (let ((module (match-string 1)) - untracked modified) - (when (looking-at "^Submodule [^ ]+ contains untracked content$") - (magit-delete-line) - (setq untracked t)) - (when (looking-at "^Submodule [^ ]+ contains modified content$") - (magit-delete-line) - (setq modified t)) - (cond - ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ :]+\\)\\( (rewind)\\)?:$") - (equal (match-string 1) module)) - (magit-bind-match-strings (_module range rewind) nil - (magit-delete-line) - (while (looking-at "^ \\([<>]\\) \\(.*\\)$") - (magit-delete-line)) - (when rewind - (setq range (replace-regexp-in-string "[^.]\\(\\.\\.\\)[^.]" - "..." range t t 1))) - (magit-insert-section (module module t) - (magit-insert-heading - (propertize (concat "modified " module) - 'font-lock-face 'magit-diff-file-heading) - " (" - (cond (rewind "rewind") - ((string-search "..." range) "non-ff") - (t "new commits")) - (and (or modified untracked) - (concat ", " - (and modified "modified") - (and modified untracked " and ") - (and untracked "untracked") - " content")) - ")") - (magit-insert-section-body - (let ((default-directory - (file-name-as-directory - (expand-file-name module (magit-toplevel))))) - (magit-git-wash (apply-partially #'magit-log-wash-log 'module) - "log" "--oneline" "--left-right" range) - (delete-char -1)))))) - ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ ]+\\) (\\([^)]+\\))$") - (equal (match-string 1) module)) - (magit-bind-match-strings (_module _range msg) nil - (magit-delete-line) - (magit-insert-section (module module) - (magit-insert-heading - (propertize (concat "submodule " module) - 'font-lock-face 'magit-diff-file-heading) - " (" msg ")")))) - (t - (magit-insert-section (module module) - (magit-insert-heading - (propertize (concat "modified " module) - 'font-lock-face 'magit-diff-file-heading) - " (" - (and modified "modified") - (and modified untracked " and ") - (and untracked "untracked") - " content)"))))))) - -(defun magit-diff-wash-hunk () - (when (looking-at "^@\\{2,\\} \\(.+?\\) @\\{2,\\}\\(?: \\(.*\\)\\)?") - (let* ((heading (match-string 0)) - (ranges (mapcar - (lambda (str) - (let ((range - (mapcar #'string-to-number - (split-string (substring str 1) ",")))) - ;; A single line is +1 rather than +1,1. - (if (length= range 1) - (nconc range (list 1)) - range))) - (split-string (match-string 1)))) - (about (match-string 2)) - (combined (length= ranges 3)) - (value (cons about ranges))) - (magit-delete-line) - (magit-insert-section - ( hunk value nil - :washer #'magit-diff-paint-hunk - :combined combined - :from-range (if combined (butlast ranges) (car ranges)) - :to-range (car (last ranges)) - :about about) - (insert (propertize (concat heading "\n") - 'font-lock-face 'magit-diff-hunk-heading)) - (magit-insert-heading) - (while (not (or (eobp) (looking-at "^[^-+\s\\]"))) - (forward-line)))) - t)) - -(defun magit-diff-expansion-threshold (section) - "Keep new diff sections collapsed if washing takes too long." - (and (magit-file-section-p section) - (> (float-time (time-since magit-refresh-start-time)) - magit-diff-expansion-threshold) - 'hide)) - -(add-hook 'magit-section-set-visibility-hook #'magit-diff-expansion-threshold) - -;;; Revision Mode - -(define-derived-mode magit-revision-mode magit-diff-mode "Magit Rev" - "Mode for looking at a Git commit. - -This mode is documented in info node `(magit)Revision Buffer'. - -\\<magit-mode-map>\ -Type \\[magit-refresh] to refresh the current buffer. -Type \\[magit-section-toggle] to expand or hide the section at point. -Type \\[magit-visit-thing] to visit the hunk or file at point. - -Staging and applying changes is documented in info node -`(magit)Staging and Unstaging' and info node `(magit)Applying'. - -\\<magit-hunk-section-map>Type \ -\\[magit-apply] to apply the change at point, \ -\\[magit-stage] to stage, -\\[magit-unstage] to unstage, \ -\\[magit-discard] to discard, or \ -\\[magit-reverse] to reverse it. - -\\{magit-revision-mode-map}" - :interactive nil - :group 'magit-revision - (magit-hack-dir-local-variables)) - -(put 'magit-revision-mode 'magit-diff-default-arguments - '("--stat" "--no-ext-diff")) - -(defun magit-revision-setup-buffer (rev args files) - (magit-setup-buffer #'magit-revision-mode nil - (magit-buffer-revision rev) - (magit-buffer-range (format "%s^..%s" rev rev)) - (magit-buffer-diff-type 'committed) - (magit-buffer-diff-args args) - (magit-buffer-diff-files files) - (magit-buffer-diff-files-suspended nil))) - -(defun magit-revision-refresh-buffer () - (setq magit-buffer-revision-hash (magit-rev-hash magit-buffer-revision)) - (magit-set-header-line-format - (concat (magit-object-type magit-buffer-revision-hash) - " " magit-buffer-revision - (pcase (length magit-buffer-diff-files) - (0) - (1 (concat " limited to file " (car magit-buffer-diff-files))) - (_ (concat " limited to files " - (string-join magit-buffer-diff-files ", ")))))) - (magit-insert-section (commitbuf) - (magit-run-section-hook 'magit-revision-sections-hook))) - -(cl-defmethod magit-buffer-value (&context (major-mode magit-revision-mode)) - (cons magit-buffer-revision magit-buffer-diff-files)) - -(defun magit-insert-revision-diff () - "Insert the diff into this `magit-revision-mode' buffer." - (magit--insert-diff t - "show" "-p" "--format=" "--no-prefix" - (and (member "--stat" magit-buffer-diff-args) "--numstat") - magit-buffer-diff-args - (magit--rev-dereference magit-buffer-revision) - "--" magit-buffer-diff-files)) - -(defun magit-insert-revision-tag () - "Insert tag message and headers into a revision buffer. -This function only inserts anything when `magit-show-commit' is -called with a tag as argument, when that is called with a commit -or a ref which is not a branch, then it inserts nothing." - (when (equal (magit-object-type magit-buffer-revision) "tag") - (magit-insert-section (taginfo) - (let ((beg (point))) - ;; "git verify-tag -v" would output what we need, but the gpg - ;; output is send to stderr and we have no control over the - ;; order in which stdout and stderr are inserted, which would - ;; make parsing hard. We are forced to use "git cat-file tag" - ;; instead, which inserts the signature instead of verifying - ;; it. We remove that later and then insert the verification - ;; output using "git verify-tag" (without the "-v"). - (magit-git-insert "cat-file" "tag" magit-buffer-revision) - (goto-char beg) - (forward-line 3) - (delete-region beg (point))) - (looking-at "^tagger \\([^<]+\\) <\\([^>]+\\)") - (let ((heading (format "Tagger: %s <%s>" - (match-string 1) - (match-string 2)))) - (magit-delete-line) - (insert (propertize heading 'font-lock-face - 'magit-section-secondary-heading))) - (magit-insert-heading) - (forward-line) - (magit-insert-section - ( message nil nil - :heading-highlight-face 'magit-diff-revision-summary-highlight) - (let ((beg (point))) - (forward-line) - (magit--add-face-text-property - beg (point) 'magit-diff-revision-summary)) - (magit-insert-heading) - (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max))) - (insert ?\n)) - (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) - (progn - (let ((beg (match-beginning 0))) - (re-search-forward "-----END PGP SIGNATURE-----\n") - (delete-region beg (point))) - (save-excursion - (magit-process-git t "verify-tag" magit-buffer-revision)) - (magit-diff-wash-signature magit-buffer-revision)) - (goto-char (point-max))) - (insert ?\n)))) - -(defvar-keymap magit-commit-message-section-map - :doc "Keymap for `commit-message' sections." - "<remap> <magit-visit-thing>" #'magit-show-commit - "<1>" (magit-menu-item "Visit %t" #'magit-show-commit - '(:enable (magit-thing-at-point 'git-revision t)))) - -(defun magit-insert-revision-message () - "Insert the commit message into a revision buffer." - (magit-insert-section - ( commit-message nil nil - :heading-highlight-face 'magit-diff-revision-summary-highlight) - (if-let* ((rev magit-buffer-revision) - (msg (with-temp-buffer - (save-excursion (magit-rev-insert-format "%B" rev)) - (magit-revision--wash-message)))) - (progn - (save-excursion (insert msg)) - (magit-revision--wash-message-hashes) - (save-excursion - (magit--add-face-text-property (point) - (progn (forward-line) (point)) - 'magit-diff-revision-summary) - (magit-insert-heading)) - (goto-char (point-max))) - (insert "(no message)\n")))) - -(defun magit-insert-revision-notes () - "Insert commit notes into a revision buffer." - (let ((default (or (magit-get "core.notesRef") "refs/notes/commits"))) - (dolist (ref (magit-list-active-notes-refs)) - (when-let* ((rev magit-buffer-revision) - (msg (with-temp-buffer - (save-excursion - (magit-git-insert "-c" (concat "core.notesRef=" ref) - "notes" "show" rev)) - (magit-revision--wash-message)))) - (magit-insert-section - ( notes ref (not (equal ref default)) - :heading-highlight-face 'magit-diff-hunk-heading-highlight) - (save-excursion (insert msg)) - (magit-revision--wash-message-hashes) - (save-excursion - (end-of-line) - (insert (format " (%s)" - (propertize (if (string-prefix-p "refs/notes/" ref) - (substring ref 11) - ref) - 'font-lock-face 'magit-refname)))) - (magit--add-face-text-property (point) - (progn (forward-line) (point)) - 'magit-diff-revision-summary) - (magit-insert-heading) - (goto-char (point-max)) - (insert ?\n)))))) - -(defun magit-revision--wash-message () - (let ((major-mode 'git-commit-mode)) - (hack-dir-local-variables) - (hack-local-variables-apply)) - (unless (memq git-commit-major-mode '(nil text-mode)) - (funcall git-commit-major-mode) - (font-lock-ensure)) - (when (> (point-max) (point-min)) - (save-excursion - (while (search-forward "\r\n" nil t) ; Remove trailing CRs. - (delete-region (match-beginning 0) (1+ (match-beginning 0))))) - (when magit-revision-fill-summary-line - (let ((fill-column (min magit-revision-fill-summary-line - (window-width (get-buffer-window nil t))))) - (fill-region (point) (line-end-position)))) - (when magit-diff-highlight-keywords - (save-excursion - (while (re-search-forward "\\[[^[]*\\]" nil t) - (put-text-property (match-beginning 0) - (match-end 0) - 'font-lock-face 'magit-keyword)))) - (run-hook-wrapped 'magit-wash-message-hook - (lambda (fn) (save-excursion (funcall fn)))) - (buffer-string))) - -(defun magit-revision--wash-message-hashes () - (when magit-revision-use-hash-sections - (save-excursion - ;; Start after beg to prevent a (commit text) section from - ;; starting at the same point as the (commit-message) - ;; section. - (while (not (eobp)) - (re-search-forward "\\_<" nil 'move) - (let ((beg (point))) - (re-search-forward "\\_>" nil t) - (when (> (point) beg) - (let ((text (buffer-substring-no-properties beg (point)))) - (when (pcase magit-revision-use-hash-sections - ('quickest ; false negatives and positives - (and (>= (length text) 7) - (string-match-p "[0-9]" text) - (string-match-p "[a-z]" text))) - ('quicker ; false negatives (number-less hashes) - (and (>= (length text) 7) - (string-match-p "[0-9]" text) - (magit-commit-p text))) - ('quick ; false negatives (short hashes) - (and (>= (length text) 7) - (magit-commit-p text))) - ('slow - (magit-commit-p text))) - (put-text-property beg (point) - 'font-lock-face 'magit-hash) - (let ((end (point))) - (goto-char beg) - (magit-insert-section (commit text) - (goto-char end))))))))))) - -(defun magit-insert-revision-headers () - "Insert headers about the commit into a revision buffer." - (magit-insert-section (headers) - (when-let ((string (magit-rev-format "%D" magit-buffer-revision - "--decorate=full"))) - (insert (magit-format-ref-labels string) ?\s)) - (insert (propertize - (magit-rev-parse (magit--rev-dereference magit-buffer-revision)) - 'font-lock-face 'magit-hash)) - (magit-insert-heading) - (let ((beg (point))) - (magit-rev-insert-format magit-revision-headers-format - magit-buffer-revision) - (magit-insert-revision-gravatars magit-buffer-revision beg)) - (when magit-revision-insert-related-refs - (when (magit-revision-insert-related-refs-display-p 'parents) - (dolist (parent (magit-commit-parents magit-buffer-revision)) - (magit-insert-section (commit parent) - (let ((line (magit-rev-format "%h %s" parent))) - (string-match "^\\([^ ]+\\) \\(.*\\)" line) - (magit-bind-match-strings (hash msg) line - (insert "Parent: ") - (insert (propertize hash 'font-lock-face 'magit-hash)) - (insert " " msg "\n")))))) - (when (magit-revision-insert-related-refs-display-p 'merged) - (magit--insert-related-refs - magit-buffer-revision "--merged" "Merged" - (eq magit-revision-insert-related-refs 'all))) - (when (magit-revision-insert-related-refs-display-p 'contained) - (magit--insert-related-refs - magit-buffer-revision "--contains" "Contained" - (memq magit-revision-insert-related-refs '(all mixed)))) - (when-let (((magit-revision-insert-related-refs-display-p 'follows)) - (follows (magit-get-current-tag magit-buffer-revision t))) - (let ((tag (car follows)) - (cnt (cadr follows))) - (magit-insert-section (tag tag) - (insert - (format "Follows: %s (%s)\n" - (propertize tag 'font-lock-face 'magit-tag) - (propertize (number-to-string cnt) - 'font-lock-face 'magit-branch-local)))))) - (when-let (((magit-revision-insert-related-refs-display-p 'precedes)) - (precedes (magit-get-next-tag magit-buffer-revision t))) - (let ((tag (car precedes)) - (cnt (cadr precedes))) - (magit-insert-section (tag tag) - (insert (format "Precedes: %s (%s)\n" - (propertize tag 'font-lock-face 'magit-tag) - (propertize (number-to-string cnt) - 'font-lock-face 'magit-tag)))))) - (insert ?\n)))) - -(defun magit-revision-insert-related-refs-display-p (sym) - "Whether to display related branches of type SYM. -Refer to user option `magit-revision-insert-related-refs-display-alist'." - (if-let ((elt (assq sym magit-revision-insert-related-refs-display-alist))) - (cdr elt) - t)) - -(defun magit--insert-related-refs (rev arg title remote) - (when-let ((refs (magit-list-related-branches arg rev (and remote "-a")))) - (insert title ":" (make-string (- 10 (length title)) ?\s)) - (dolist (branch refs) - (if (<= (+ (current-column) 1 (length branch)) - (window-width)) - (insert ?\s) - (insert ?\n (make-string 12 ?\s))) - (magit-insert-section (branch branch) - (insert (propertize branch 'font-lock-face - (if (string-prefix-p "remotes/" branch) - 'magit-branch-remote - 'magit-branch-local))))) - (insert ?\n))) - -(defun magit-insert-revision-gravatars (rev beg) - (when (and magit-revision-show-gravatars - (window-system)) - (require 'gravatar) - (pcase-let ((`(,author . ,committer) - (pcase magit-revision-show-gravatars - ('t '("^Author: " . "^Commit: ")) - ('author '("^Author: " . nil)) - ('committer '(nil . "^Commit: ")) - (_ magit-revision-show-gravatars)))) - (when-let ((email (and author (magit-rev-format "%aE" rev)))) - (magit-insert-revision-gravatar beg rev email author)) - (when-let ((email (and committer (magit-rev-format "%cE" rev)))) - (magit-insert-revision-gravatar beg rev email committer))))) - -(defun magit-insert-revision-gravatar (beg rev email regexp) - (save-excursion - (goto-char beg) - (when-let (((re-search-forward regexp nil t)) - (window (get-buffer-window))) - (let* ((column (length (match-string 0))) - (font-obj (query-font (font-at (point) window))) - (size (* 2 (+ (aref font-obj 4) - (aref font-obj 5)))) - (align-to (+ column - (ceiling (/ size (aref font-obj 7) 1.0)) - 1)) - (gravatar-size (- size 2))) - (ignore-errors ; service may be unreachable - (gravatar-retrieve email #'magit-insert-revision-gravatar-cb - (list gravatar-size rev - (point-marker) - align-to column))))))) - -(defun magit-insert-revision-gravatar-cb (image size rev marker align-to column) - (unless (eq image 'error) - (when-let ((buffer (marker-buffer marker))) - (with-current-buffer buffer - (save-excursion - (goto-char marker) - ;; The buffer might display another revision by now or - ;; it might have been refreshed, in which case another - ;; process might already have inserted the image. - (when (and (equal rev magit-buffer-revision) - (not (eq (car-safe - (car-safe - (get-text-property (point) 'display))) - 'image))) - (setf (image-property image :ascent) 'center) - (setf (image-property image :relief) 1) - (setf (image-property image :scale) 1) - (setf (image-property image :height) size) - (let ((top (list image '(slice 0.0 0.0 1.0 0.5))) - (bot (list image '(slice 0.0 0.5 1.0 1.0))) - (align `((space :align-to ,align-to)))) - (let ((inhibit-read-only t)) - (insert (propertize " " 'display top)) - (insert (propertize " " 'display align)) - (forward-line) - (forward-char column) - (insert (propertize " " 'display bot)) - (insert (propertize " " 'display align)))))))))) - -;;; Merge-Preview Mode - -(define-derived-mode magit-merge-preview-mode magit-diff-mode "Magit Merge" - "Mode for previewing a merge." - :interactive nil - :group 'magit-diff - (magit-hack-dir-local-variables)) - -(put 'magit-merge-preview-mode 'magit-diff-default-arguments - '("--no-ext-diff")) - -(defun magit-merge-preview-setup-buffer (rev) - (magit-setup-buffer #'magit-merge-preview-mode nil - (magit-buffer-revision rev) - (magit-buffer-range (format "%s^..%s" rev rev)))) - -(defun magit-merge-preview-refresh-buffer () - (let* ((branch (magit-get-current-branch)) - (head (or branch (magit-rev-verify "HEAD")))) - (magit-set-header-line-format (format "Preview merge of %s into %s" - magit-buffer-revision - (or branch "HEAD"))) - (magit-insert-section (diffbuf) - (magit--insert-diff t - "merge-tree" (magit-git-string "merge-base" head magit-buffer-revision) - head magit-buffer-revision)))) - -(cl-defmethod magit-buffer-value (&context (major-mode magit-merge-preview-mode)) - magit-buffer-revision) - -;;; Hunk Section - -(defun magit-hunk-set-window-start (section) - "When SECTION is a `hunk', ensure that its beginning is visible. -It the SECTION has a different type, then do nothing." - (when (magit-hunk-section-p section) - (magit-section-set-window-start section))) - -(add-hook 'magit-section-movement-hook #'magit-hunk-set-window-start) - -(cl-defmethod magit-section-get-relative-position ((_section magit-hunk-section)) - (nconc (cl-call-next-method) - (and (region-active-p) - (progn - (goto-char (line-beginning-position)) - (when (looking-at "^[-+]") (forward-line)) - (while (looking-at "^[ @]") (forward-line)) - (let ((beg (magit-point))) - (list (cond - ((looking-at "^[-+]") - (forward-line) - (while (looking-at "^[-+]") (forward-line)) - (while (looking-at "^ ") (forward-line)) - (forward-line -1) - (regexp-quote (buffer-substring-no-properties - beg (line-end-position)))) - (t t)))))))) - -(cl-defmethod magit-section-goto-successor ((section magit-hunk-section) - line char &optional arg) - (or (magit-section-goto-successor--same section line char) - (and-let* ((parent (magit-get-section - (magit-section-ident - (oref section parent))))) - (let* ((children (oref parent children)) - (siblings (magit-section-siblings section 'prev)) - (previous (nth (length siblings) children))) - (if (not arg) - (when-let ((sibling (or previous (car (last children))))) - (magit-section-goto sibling) - t) - (when previous - (magit-section-goto previous)) - (if (and (stringp arg) - (re-search-forward arg (oref parent end) t)) - (goto-char (match-beginning 0)) - (goto-char (oref (car (last children)) end)) - (forward-line -1) - (while (looking-at "^ ") (forward-line -1)) - (while (looking-at "^[-+]") (forward-line -1)) - (forward-line))))) - (magit-section-goto-successor--related section))) - -;;; Diff Sections - -(defvar-keymap magit-unstaged-section-map - :doc "Keymap for the `unstaged' section." - "<remap> <magit-visit-thing>" #'magit-diff-unstaged - "<remap> <magit-stage-file>" #'magit-stage - "<remap> <magit-delete-thing>" #'magit-discard - "<3>" (magit-menu-item "Discard all" #'magit-discard) - "<2>" (magit-menu-item "Stage all" #'magit-stage) - "<1>" (magit-menu-item "Visit diff" #'magit-diff-unstaged)) - -(magit-define-section-jumper magit-jump-to-unstaged - "Unstaged changes" unstaged nil magit-insert-unstaged-changes) - -(defun magit-insert-unstaged-changes () - "Insert section showing unstaged changes." - (magit-insert-section (unstaged) - (magit-insert-heading t "Unstaged changes") - (magit--insert-diff nil - "diff" magit-buffer-diff-args "--no-prefix" - "--" magit-buffer-diff-files))) - -(defvar-keymap magit-staged-section-map - :doc "Keymap for the `staged' section." - "<remap> <magit-revert-no-commit>" #'magit-reverse - "<remap> <magit-delete-thing>" #'magit-discard - "<remap> <magit-unstage-file>" #'magit-unstage - "<remap> <magit-visit-thing>" #'magit-diff-staged - "<4>" (magit-menu-item "Reverse all" #'magit-reverse) - "<3>" (magit-menu-item "Discard all" #'magit-discard) - "<2>" (magit-menu-item "Unstage all" #'magit-unstage) - "<1>" (magit-menu-item "Visit diff" #'magit-diff-staged)) - -(magit-define-section-jumper magit-jump-to-staged - "Staged changes" staged nil magit-insert-staged-changes) - -(defun magit-insert-staged-changes () - "Insert section showing staged changes." - ;; Avoid listing all files as deleted when visiting a bare repo. - (unless (magit-bare-repo-p) - (magit-insert-section (staged) - (magit-insert-heading t "Staged changes") - (magit--insert-diff nil - "diff" "--cached" magit-buffer-diff-args "--no-prefix" - "--" magit-buffer-diff-files)))) - -;;; Diff Type - -(defvar magit--diff-use-recorded-type-p t) - -(defun magit-diff-type (&optional section) - "Return the diff type of SECTION. - -The returned type is one of the symbols `staged', `unstaged', -`committed', or `undefined'. This type serves a similar purpose -as the general type common to all sections (which is stored in -the `type' slot of the corresponding `magit-section' struct) but -takes additional information into account. When the SECTION -isn't related to diffs and the buffer containing it also isn't -a diff-only buffer, then return nil. - -Currently the type can also be one of `tracked' and `untracked' -but these values are not handled explicitly everywhere they -should be and a possible fix could be to just return nil here. - -The section has to be a `diff' or `hunk' section, or a section -whose children are of type `diff'. If optional SECTION is nil, -return the diff type for the current section. In buffers whose -major mode is `magit-diff-mode' SECTION is ignored and the type -is determined using other means. In `magit-revision-mode' -buffers the type is always `committed'. - -Do not confuse this with `magit-diff-scope' (which see)." - (when-let ((section (or section (magit-current-section)))) - (cond ((derived-mode-p 'magit-revision-mode 'magit-stash-mode) 'committed) - ((derived-mode-p 'magit-diff-mode) - (let ((range magit-buffer-range) - (const magit-buffer-typearg)) - (cond ((and magit--diff-use-recorded-type-p - magit-buffer-diff-type)) - ((equal const "--no-index") 'undefined) - ((or (not range) - (equal range "HEAD") - (magit-rev-eq range "HEAD")) - (if (equal const "--cached") - 'staged - 'unstaged)) - ((equal const "--cached") - (if (magit-rev-head-p range) - 'staged - 'undefined)) ; i.e., committed and staged - (t 'committed)))) - ((derived-mode-p 'magit-status-mode) - (let ((stype (oref section type))) - (if (memq stype '(staged unstaged tracked untracked)) - stype - (pcase stype - ((or 'file 'module) - (let* ((parent (oref section parent)) - (type (oref parent type))) - (if (memq type '(file module)) - (magit-diff-type parent) - type))) - ('hunk (thread-first section - (oref parent) - (oref parent) - (oref type))))))) - ((derived-mode-p 'magit-log-mode) - (if (or (and (magit-section-match 'commit section) - (oref section children)) - (magit-section-match [* file commit] section)) - 'committed - 'undefined)) - (t 'undefined)))) - -(cl-defun magit-diff-scope (&optional (section nil ssection) strict) - "Return the diff scope of SECTION or the selected section(s). - -A diff's \"scope\" describes what part of a diff is selected, it is -a symbol, one of `region', `hunk', `hunks', `file', `files', or -`list'. Do not confuse this with the diff \"type\", as returned by -`magit-diff-type'. - -If optional SECTION is non-nil, then return the scope of that, -ignoring the sections selected by the region. Otherwise return -the scope of the current section, or if the region is active and -selects a valid group of diff related sections, the type of these -sections, i.e., `hunks' or `files'. If SECTION, or if that is nil -the current section, is a `hunk' section; and the region region -starts and ends inside the body of a that section, then the type -is `region'. If the region is empty after a mouse click, then -`hunk' is returned instead of `region'. - -If optional STRICT is non-nil, then return nil if the diff type of -the section at point is `untracked' or the section at point is not -actually a `diff' but a `diffstat' section." - (let ((siblings (and (not ssection) (magit-region-sections nil t)))) - (setq section (or section (car siblings) (magit-current-section))) - (when (and section - (or (not strict) - (and (not (eq (magit-diff-type section) 'untracked)) - (not (eq (and-let* ((parent (oref section parent))) - (oref parent type)) - 'diffstat))))) - (pcase (list (oref section type) - (and siblings t) - (magit-diff-use-hunk-region-p) - ssection) - (`(hunk nil t ,_) - (if (magit-section-internal-region-p section) 'region 'hunk)) - ('(hunk t t nil) 'hunks) - (`(hunk ,_ ,_ ,_) 'hunk) - ('(file t t nil) 'files) - (`(file ,_ ,_ ,_) 'file) - ('(module t t nil) 'files) - (`(module ,_ ,_ ,_) 'file) - (`(,(or 'staged 'unstaged 'untracked) nil ,_ ,_) 'list))))) - -(defun magit-diff-use-hunk-region-p () - (and (region-active-p) - ;; TODO implement this from first principals - ;; currently it's trial-and-error - (not (and (or (eq this-command #'mouse-drag-region) - (eq last-command #'mouse-drag-region) - ;; When another window was previously - ;; selected then the last-command is - ;; some byte-code function. - (byte-code-function-p last-command)) - (eq (region-end) (region-beginning)))))) - -;;; Diff Highlight - -(add-hook 'magit-section-unhighlight-hook #'magit-diff-unhighlight) -(add-hook 'magit-section-highlight-hook #'magit-diff-highlight) - -(defun magit-diff-unhighlight (section selection) - "Remove the highlighting of the diff-related SECTION." - (when (magit-hunk-section-p section) - (magit-diff-paint-hunk section selection nil) - t)) - -(defun magit-diff-highlight (section selection) - "Highlight the diff-related SECTION. -If SECTION is not a diff-related section, then do nothing and -return nil. If SELECTION is non-nil, then it is a list of sections -selected by the region, including SECTION. All of these sections -are highlighted." - (if (and (magit-section-match 'commit section) - (oref section children)) - (progn (if selection - (dolist (section selection) - (magit-diff-highlight-list section selection)) - (magit-diff-highlight-list section)) - t) - (when-let ((scope (magit-diff-scope section t))) - (cond ((eq scope 'region) - (magit-diff-paint-hunk section selection t)) - (selection - (dolist (section selection) - (magit-diff-highlight-recursive section selection))) - (t - (magit-diff-highlight-recursive section))) - t))) - -(defun magit-diff-highlight-recursive (section &optional selection) - (pcase (magit-diff-scope section) - ('list (magit-diff-highlight-list section selection)) - ('file (magit-diff-highlight-file section selection)) - ('hunk (magit-diff-highlight-heading section selection) - (magit-diff-paint-hunk section selection t)) - (_ (magit-section-highlight section nil)))) - -(defun magit-diff-highlight-list (section &optional selection) - (let ((beg (oref section start)) - (cnt (oref section content)) - (end (oref section end))) - (when (or (eq this-command #'mouse-drag-region) - (not selection)) - (unless (and (region-active-p) - (<= (region-beginning) beg)) - (magit-section-make-overlay beg cnt 'magit-section-highlight)) - (if (oref section hidden) - (oset section washer #'ignore) - (dolist (child (oref section children)) - (when (or (eq this-command #'mouse-drag-region) - (not (and (region-active-p) - (<= (region-beginning) - (oref child start))))) - (magit-diff-highlight-recursive child selection))))) - (when magit-diff-highlight-hunk-body - (magit-section-make-overlay (1- end) end 'magit-section-highlight)))) - -(defun magit-diff-highlight-file (section &optional selection) - (magit-diff-highlight-heading section selection) - (when (or (not (oref section hidden)) - (cl-typep section 'magit-module-section)) - (dolist (child (oref section children)) - (magit-diff-highlight-recursive child selection)))) - -(defun magit-diff-highlight-heading (section &optional selection) - (magit-section-make-overlay - (oref section start) - (or (oref section content) - (oref section end)) - (pcase (list (oref section type) - (and (member section selection) - (not (eq this-command #'mouse-drag-region)))) - ('(file t) 'magit-diff-file-heading-selection) - ('(file nil) 'magit-diff-file-heading-highlight) - ('(module t) 'magit-diff-file-heading-selection) - ('(module nil) 'magit-diff-file-heading-highlight) - ('(hunk t) 'magit-diff-hunk-heading-selection) - ('(hunk nil) 'magit-diff-hunk-heading-highlight)))) - -;;; Hunk Paint - -(cl-defun magit-diff-paint-hunk - (section &optional selection - (highlight (magit-section-selected-p section selection))) - (let (paint) - (unless magit-diff-highlight-hunk-body - (setq highlight nil)) - (cond (highlight - (unless (oref section hidden) - (add-to-list 'magit-section-highlighted-sections section) - (cond ((memq section magit-section-unhighlight-sections) - (setq magit-section-unhighlight-sections - (delq section magit-section-unhighlight-sections))) - (magit-diff-highlight-hunk-body - (setq paint t))))) - (t - (cond ((and (oref section hidden) - (memq section magit-section-unhighlight-sections)) - (add-to-list 'magit-section-highlighted-sections section) - (setq magit-section-unhighlight-sections - (delq section magit-section-unhighlight-sections))) - (t - (setq paint t))))) - (when paint - (save-excursion - (goto-char (oref section start)) - (let ((end (oref section end)) - (merging (looking-at "@@@")) - (diff-type (magit-diff-type)) - (stage nil) - (tab-width (magit-diff-tab-width - (magit-section-parent-value section)))) - (forward-line) - (while (< (point) end) - (when (and magit-diff-hide-trailing-cr-characters - (char-equal ?\r (char-before (line-end-position)))) - (put-text-property (1- (line-end-position)) (line-end-position) - 'invisible t)) - (put-text-property - (point) (1+ (line-end-position)) 'font-lock-face - (cond - ((looking-at "^\\+\\+?\\([<=|>]\\)\\{7\\}") - (setq stage (pcase (list (match-string 1) highlight) - ('("<" nil) 'magit-diff-our) - ('("<" t) 'magit-diff-our-highlight) - ('("|" nil) 'magit-diff-base) - ('("|" t) 'magit-diff-base-highlight) - ('("=" nil) 'magit-diff-their) - ('("=" t) 'magit-diff-their-highlight) - ('(">" nil) nil))) - 'magit-diff-conflict-heading) - ((looking-at (if merging "^\\(\\+\\| \\+\\)" "^\\+")) - (magit-diff-paint-tab merging tab-width) - (magit-diff-paint-whitespace merging 'added diff-type) - (or stage - (if highlight 'magit-diff-added-highlight 'magit-diff-added))) - ((looking-at (if merging "^\\(-\\| -\\)" "^-")) - (magit-diff-paint-tab merging tab-width) - (magit-diff-paint-whitespace merging 'removed diff-type) - (if highlight 'magit-diff-removed-highlight 'magit-diff-removed)) - (t - (magit-diff-paint-tab merging tab-width) - (magit-diff-paint-whitespace merging 'context diff-type) - (if highlight 'magit-diff-context-highlight 'magit-diff-context)))) - (forward-line)))))) - (magit-diff-update-hunk-refinement section)) - -(defvar magit-diff--tab-width-cache nil) - -(defun magit-diff-tab-width (file) - (setq file (expand-file-name file)) - (cl-flet ((cache (value) - (let ((elt (assoc file magit-diff--tab-width-cache))) - (if elt - (setcdr elt value) - (setq magit-diff--tab-width-cache - (cons (cons file value) - magit-diff--tab-width-cache)))) - value)) - (cond - ((not magit-diff-adjust-tab-width) - tab-width) - ((and-let* ((buffer (find-buffer-visiting file))) - (cache (buffer-local-value 'tab-width buffer)))) - ((and-let* ((elt (assoc file magit-diff--tab-width-cache))) - (or (cdr elt) - tab-width))) - ((or (eq magit-diff-adjust-tab-width 'always) - (and (numberp magit-diff-adjust-tab-width) - (>= magit-diff-adjust-tab-width - (nth 7 (file-attributes file))))) - (cache (buffer-local-value 'tab-width (find-file-noselect file)))) - (t - (cache nil) - tab-width)))) - -(defun magit-diff-paint-tab (merging width) - (save-excursion - (forward-char (if merging 2 1)) - (while (= (char-after) ?\t) - (put-text-property (point) (1+ (point)) - 'display (list (list 'space :width width))) - (forward-char)))) - -(defun magit-diff-paint-whitespace (merging line-type diff-type) - (when (and magit-diff-paint-whitespace - (or (not (memq magit-diff-paint-whitespace '(uncommitted status))) - (memq diff-type '(staged unstaged))) - (cl-case line-type - (added t) - (removed (memq magit-diff-paint-whitespace-lines '(all both))) - (context (memq magit-diff-paint-whitespace-lines '(all))))) - (let ((prefix (if merging "^[-\\+\s]\\{2\\}" "^[-\\+\s]")) - (indent - (if (local-variable-p 'magit-diff-highlight-indentation) - magit-diff-highlight-indentation - (setq-local - magit-diff-highlight-indentation - (cdr (--first (string-match-p (car it) default-directory) - (nreverse - (default-value - 'magit-diff-highlight-indentation)))))))) - (when (and magit-diff-highlight-trailing - (looking-at (concat prefix ".*?\\([ \t]+\\)?$"))) - (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) - (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) - (overlay-put ov 'priority 2) - (overlay-put ov 'evaporate t))) - (when (or (and (eq indent 'tabs) - (looking-at (concat prefix "\\( *\t[ \t]*\\)"))) - (and (integerp indent) - (looking-at (format "%s\\([ \t]* \\{%s,\\}[ \t]*\\)" - prefix indent)))) - (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) - (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) - (overlay-put ov 'priority 2) - (overlay-put ov 'evaporate t)))))) - -(defun magit-diff-update-hunk-refinement (&optional section) - (if section - (unless (oref section hidden) - (pcase (list magit-diff-refine-hunk - (oref section refined) - (eq section (magit-current-section))) - ((or `(all nil ,_) '(t nil t)) - (oset section refined t) - (save-excursion - (goto-char (oref section start)) - ;; `diff-refine-hunk' does not handle combined diffs. - (unless (looking-at "@@@") - (let ((smerge-refine-ignore-whitespace - magit-diff-refine-ignore-whitespace) - ;; Avoid fsyncing many small temp files - (write-region-inhibit-fsync t)) - (diff-refine-hunk))))) - ((or `(nil t ,_) '(t t nil)) - (oset section refined nil) - (remove-overlays (oref section start) - (oref section end) - 'diff-mode 'fine)))) - (cl-labels ((recurse (section) - (if (magit-section-match 'hunk section) - (magit-diff-update-hunk-refinement section) - (dolist (child (oref section children)) - (recurse child))))) - (recurse magit-root-section)))) - - -;;; Hunk Region - -(defun magit-diff-hunk-region-beginning () - (save-excursion (goto-char (region-beginning)) - (line-beginning-position))) - -(defun magit-diff-hunk-region-end () - (save-excursion (goto-char (region-end)) - (line-end-position))) - -(defun magit-diff-update-hunk-region (section) - "Highlight the hunk-internal region if any." - (when (and (eq (oref section type) 'hunk) - (eq (magit-diff-scope section t) 'region)) - (magit-diff--make-hunk-overlay - (oref section start) - (1- (oref section content)) - 'font-lock-face 'magit-diff-lines-heading - 'display (magit-diff-hunk-region-header section) - 'after-string (magit-diff--hunk-after-string 'magit-diff-lines-heading)) - (run-hook-with-args 'magit-diff-highlight-hunk-region-functions section) - t)) - -(defun magit-diff-highlight-hunk-region-dim-outside (section) - "Dim the parts of the hunk that are outside the hunk-internal region. -This is done by using the same foreground and background color -for added and removed lines as for context lines." - (let ((face (if magit-diff-highlight-hunk-body - 'magit-diff-context-highlight - 'magit-diff-context))) - (when magit-diff-unmarked-lines-keep-foreground - (setq face `(,@(and (>= emacs-major-version 27) '(:extend t)) - :background ,(face-attribute face :background)))) - (magit-diff--make-hunk-overlay (oref section content) - (magit-diff-hunk-region-beginning) - 'font-lock-face face - 'priority 2) - (magit-diff--make-hunk-overlay (1+ (magit-diff-hunk-region-end)) - (oref section end) - 'font-lock-face face - 'priority 2))) - -(defun magit-diff-highlight-hunk-region-using-face (_section) - "Highlight the hunk-internal region by making it bold. -Or rather highlight using the face `magit-diff-hunk-region', though -changing only the `:weight' and/or `:slant' is recommended for that -face." - (magit-diff--make-hunk-overlay (magit-diff-hunk-region-beginning) - (1+ (magit-diff-hunk-region-end)) - 'font-lock-face 'magit-diff-hunk-region)) - -(defun magit-diff-highlight-hunk-region-using-overlays (section) - "Emphasize the hunk-internal region using delimiting horizontal lines. -This is implemented as single-pixel newlines places inside overlays." - (if (window-system) - (let ((beg (magit-diff-hunk-region-beginning)) - (end (magit-diff-hunk-region-end)) - (str (propertize - (concat (propertize "\s" 'display '(space :height (1))) - (propertize "\n" 'line-height t)) - 'font-lock-face 'magit-diff-lines-boundary))) - (magit-diff--make-hunk-overlay beg (1+ beg) 'before-string str) - (magit-diff--make-hunk-overlay end (1+ end) 'after-string str)) - (magit-diff-highlight-hunk-region-using-face section))) - -(defun magit-diff-highlight-hunk-region-using-underline (section) - "Emphasize the hunk-internal region using delimiting horizontal lines. -This is implemented by overlining and underlining the first and -last (visual) lines of the region." - (if (window-system) - (let* ((beg (magit-diff-hunk-region-beginning)) - (end (magit-diff-hunk-region-end)) - (beg-eol (save-excursion (goto-char beg) - (end-of-visual-line) - (point))) - (end-bol (save-excursion (goto-char end) - (beginning-of-visual-line) - (point))) - (color (face-background 'magit-diff-lines-boundary nil t))) - (cl-flet ((ln (b e &rest face) - (magit-diff--make-hunk-overlay - b e 'font-lock-face face 'after-string - (magit-diff--hunk-after-string face)))) - (if (= beg end-bol) - (ln beg beg-eol :overline color :underline color) - (ln beg beg-eol :overline color) - (ln end-bol end :underline color)))) - (magit-diff-highlight-hunk-region-using-face section))) - -(defun magit-diff--make-hunk-overlay (start end &rest args) - (let ((ov (make-overlay start end nil t))) - (overlay-put ov 'evaporate t) - (while args (overlay-put ov (pop args) (pop args))) - (push ov magit-section--region-overlays) - ov)) - -(defun magit-diff--hunk-after-string (face) - (propertize "\s" - 'font-lock-face face - 'display (list 'space :align-to - `(+ (0 . right) - ,(min (window-hscroll) - (- (line-end-position) - (line-beginning-position))))) - ;; This prevents the cursor from being rendered at the - ;; edge of the window. - 'cursor t)) - -;;; Utilities - -(defun magit-diff-inside-hunk-body-p () - "Return non-nil if point is inside the body of a hunk." - (and (magit-section-match 'hunk) - (and-let* ((content (oref (magit-current-section) content))) - (> (magit-point) content)))) - -(defun magit-diff--combined-p (section) - (cl-assert (cl-typep section 'magit-file-section)) - (string-match-p "\\`diff --\\(combined\\|cc\\)" (oref section value))) - -;;; Diff Extract - -(defun magit-diff-file-header (section &optional no-rename) - (when (magit-hunk-section-p section) - (setq section (oref section parent))) - (and (magit-file-section-p section) - (let ((header (oref section header))) - (if no-rename - (replace-regexp-in-string - "^--- \\(.+\\)" (oref section value) header t t 1) - header)))) - -(defun magit-diff-hunk-region-header (section) - (let ((patch (magit-diff-hunk-region-patch section))) - (string-match "\n" patch) - (substring patch 0 (1- (match-end 0))))) - -(defun magit-diff-hunk-region-patch (section &optional args) - (let ((op (if (member "--reverse" args) "+" "-")) - (sbeg (oref section start)) - (rbeg (magit-diff-hunk-region-beginning)) - (rend (region-end)) - (send (oref section end)) - (patch nil)) - (save-excursion - (goto-char sbeg) - (while (< (point) send) - (looking-at "\\(.\\)\\([^\n]*\n\\)") - (cond ((or (string-match-p "[@ ]" (match-string-no-properties 1)) - (and (>= (point) rbeg) - (<= (point) rend))) - (push (match-string-no-properties 0) patch)) - ((equal op (match-string-no-properties 1)) - (push (concat " " (match-string-no-properties 2)) patch))) - (forward-line))) - (let ((buffer-list-update-hook nil)) ; #3759 - (with-temp-buffer - (insert (string-join (reverse patch))) - (diff-fixup-modifs (point-min) (point-max)) - (setq patch (buffer-string)))) - patch)) - -;;; _ -(provide 'magit-diff) -;;; magit-diff.el ends here diff --git a/emacs/elpa/magit-20241106.1441/magit-diff.elc b/emacs/elpa/magit-20241106.1441/magit-diff.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-git.el b/emacs/elpa/magit-20241106.1441/magit-git.el @@ -1,2896 +0,0 @@ -;;; magit-git.el --- Git functionality -*- lexical-binding:t -*- - -;; Copyright (C) 2008-2024 The Magit Project Contributors - -;; Author: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> -;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; Magit 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. -;; -;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This library implements wrappers for various Git plumbing commands. - -;;; Code: - -(require 'magit-base) - -(require 'format-spec) - -;; From `magit-branch'. -(defvar magit-branch-prefer-remote-upstream) -(defvar magit-published-branches) - -;; From `magit-margin'. -(declare-function magit-maybe-make-margin-overlay "magit-margin" ()) - -;; From `magit-mode'. -(declare-function magit-get-mode-buffer "magit-mode" - (mode &optional value frame)) -(declare-function magit-refresh "magit-mode" ()) -(defvar magit-buffer-diff-type) -(defvar magit-buffer-diff-args) -(defvar magit-buffer-file-name) -(defvar magit-buffer-log-args) -(defvar magit-buffer-log-files) -(defvar magit-buffer-refname) -(defvar magit-buffer-revision) - -;; From `magit-process'. -(declare-function magit-call-git "magit-process" (&rest args)) -(declare-function magit-git "magit-process" (&rest args)) -(declare-function magit-process-buffer "magit-process" (&optional nodisplay)) -(declare-function magit-process-file "magit-process" - (process &optional infile buffer display &rest args)) -(declare-function magit-process-finish-section "magit-process" - (section exit-code)) -(declare-function magit-process-git "magit-process" (destination &rest args)) -(declare-function magit-process-insert-section "magit-process" - (pwd program args &optional errcode errlog face)) -(defvar magit-this-error) -(defvar magit-process-error-message-regexps) - -(eval-when-compile - (cl-pushnew 'orig-rev eieio--known-slot-names) - (cl-pushnew 'number eieio--known-slot-names)) - -;;; Options - -;; For now this is shared between `magit-process' and `magit-git'. -(defgroup magit-process nil - "Git and other external processes used by Magit." - :group 'magit) - -(defvar magit-git-environment - (list (format "INSIDE_EMACS=%s,magit" emacs-version)) - "Prepended to `process-environment' while running git.") - -(defcustom magit-git-output-coding-system - (and (eq system-type 'windows-nt) 'utf-8) - "Coding system for receiving output from Git. - -If non-nil, the Git config value `i18n.logOutputEncoding' should -be set via `magit-git-global-arguments' to value consistent with -this." - :package-version '(magit . "2.9.0") - :group 'magit-process - :type '(choice (coding-system :tag "Coding system to decode Git output") - (const :tag "Use system default" nil))) - -(defvar magit-git-w32-path-hack nil - "Alist of (EXE . (PATHENTRY)). -This specifies what additional PATH setting needs to be added to -the environment in order to run the non-wrapper git executables -successfully.") - -(defcustom magit-git-executable - (or (and (eq system-type 'windows-nt) - ;; Avoid the wrappers "cmd/git.exe" and "cmd/git.cmd", - ;; which are much slower than using "bin/git.exe" directly. - (and-let* ((exec (executable-find "git"))) - (ignore-errors - ;; Git for Windows 2.x provides cygpath so we can - ;; ask it for native paths. - (let* ((core-exe - (car - (process-lines - exec "-c" - "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" - "X" "git"))) - (hack-entry (assoc core-exe magit-git-w32-path-hack)) - ;; Running the libexec/git-core executable - ;; requires some extra PATH entries. - (path-hack - (list (concat "PATH=" - (car (process-lines - exec "-c" - "alias.P=!cygpath -wp \"$PATH\"" - "P")))))) - ;; The defcustom STANDARD expression can be - ;; evaluated many times, so make sure it is - ;; idempotent. - (if hack-entry - (setcdr hack-entry path-hack) - (push (cons core-exe path-hack) magit-git-w32-path-hack)) - core-exe)))) - (and (eq system-type 'darwin) - (executable-find "git")) - "git") - "The Git executable used by Magit on the local host. -On remote machines `magit-remote-git-executable' is used instead." - :package-version '(magit . "3.2.0") - :group 'magit-process - :type 'string) - -(defcustom magit-remote-git-executable "git" - "The Git executable used by Magit on remote machines. -On the local host `magit-git-executable' is used instead. -Consider customizing `tramp-remote-path' instead of this -option." - :package-version '(magit . "3.2.0") - :group 'magit-process - :type 'string) - -(defcustom magit-git-global-arguments - `("--no-pager" "--literal-pathspecs" - "-c" "core.preloadindex=true" - "-c" "log.showSignature=false" - "-c" "color.ui=false" - "-c" "color.diff=false" - ,@(and (eq system-type 'windows-nt) - (list "-c" "i18n.logOutputEncoding=UTF-8"))) - "Global Git arguments. - -The arguments set here are used every time the git executable is -run as a subprocess. They are placed right after the executable -itself and before the git command - as in `git HERE... COMMAND -REST'. See the manpage `git(1)' for valid arguments. - -Be careful what you add here, especially if you are using Tramp -to connect to servers with ancient Git versions. Never remove -anything that is part of the default value, unless you really -know what you are doing. And think very hard before adding -something; it will be used every time Magit runs Git for any -purpose." - :package-version '(magit . "2.9.0") - :group 'magit-commands - :group 'magit-process - :type '(repeat string)) - -(defcustom magit-prefer-remote-upstream nil - "Whether to favor remote branches when reading the upstream branch. - -This controls whether commands that read a branch from the user -and then set it as the upstream branch, offer a local or a remote -branch as default completion candidate, when they have the choice. - -This affects all commands that use `magit-read-upstream-branch' -or `magit-read-starting-point', which includes most commands -that change the upstream and many that create new branches." - :package-version '(magit . "2.4.2") - :group 'magit-commands - :type 'boolean) - -(defcustom magit-list-refs-namespaces - '("refs/heads" - "refs/remotes" - "refs/tags" - "refs/pullreqs") - "List of ref namespaces considered when reading a ref. - -This controls the order of refs returned by `magit-list-refs', -which is called by functions like `magit-list-branch-names' to -generate the collection of refs." - :package-version '(magit . "3.1.0") - :group 'magit-commands - :type '(repeat string)) - -(defcustom magit-list-refs-sortby nil - "How to sort the ref collection in the prompt. - -This affects commands that read a ref. More specifically, it -controls the order of refs returned by `magit-list-refs', which -is called by functions like `magit-list-branch-names' to generate -the collection of refs. By default, refs are sorted according to -their full refname (i.e., \"refs/...\"). - -Any value accepted by the `--sort' flag of \"git for-each-ref\" can -be used. For example, \"-creatordate\" places refs with more -recent committer or tagger dates earlier in the list. A list of -strings can also be given in order to pass multiple sort keys to -\"git for-each-ref\". - -Note that, depending on the completion framework you use, this -may not be sufficient to change the order in which the refs are -displayed. It only controls the order of the collection passed -to `magit-completing-read' or, for commands that support reading -multiple strings, `read-from-minibuffer'. The completion -framework ultimately determines how the collection is displayed." - :package-version '(magit . "2.11.0") - :group 'magit-miscellaneous - :type '(choice string (repeat string))) - -;;; Git - -(defvar magit-git-debug nil - "Whether to enable additional reporting of git errors. - -Magit basically calls git for one of these two reasons: for -side-effects or to do something with its standard output. - -When git is run for side-effects then its output, including error -messages, go into the process buffer which is shown when using \ -\\<magit-status-mode-map>\\[magit-process-buffer]. - -When git's output is consumed in some way, then it would be too -expensive to also insert it into this buffer, but when this -option is non-nil and git returns with a non-zero exit status, -then at least its standard error is inserted into this buffer. - -This is only intended for debugging purposes. Do not enable this -permanently, that would negatively affect performance. Also note -that just because git exits with a non-zero exit status and prints -an error message that usually doesn't mean that it is an error as -far as Magit is concerned, which is another reason we usually hide -these error messages. Whether some error message is relevant in -the context of some unexpected behavior has to be judged on a case -by case basis. - -The command `magit-toggle-git-debug' changes the value of this -variable. - -Also see `magit-process-extreme-logging'.") - -(defun magit-toggle-git-debug () - "Toggle whether additional git errors are reported. -See info node `(magit)Debugging Tools' for more information." - (interactive) - (setq magit-git-debug (not magit-git-debug)) - (message "Additional reporting of Git errors %s" - (if magit-git-debug "enabled" "disabled"))) - -(defvar magit--refresh-cache nil) - -(defmacro magit--with-refresh-cache (key &rest body) - (declare (indent 1) (debug (form body))) - (let ((k (cl-gensym)) - (hit (cl-gensym))) - `(if magit--refresh-cache - (let ((,k ,key)) - (if-let ((,hit (assoc ,k (cdr magit--refresh-cache)))) - (progn (cl-incf (caar magit--refresh-cache)) - (cdr ,hit)) - (cl-incf (cdar magit--refresh-cache)) - (let ((value ,(macroexp-progn body))) - (push (cons ,k value) - (cdr magit--refresh-cache)) - value))) - ,@body))) - -(defvar magit-with-editor-envvar "GIT_EDITOR" - "The environment variable exported by `magit-with-editor'. -Set this to \"GIT_SEQUENCE_EDITOR\" if you do not want to use -Emacs to edit commit messages but would like to do so to edit -rebase sequences.") - -(defmacro magit-with-editor (&rest body) - "Like `with-editor*' but let-bind some more variables. -Also respect the value of `magit-with-editor-envvar'." - (declare (indent 0) (debug (body))) - `(let ((magit-process-popup-time -1) - ;; The user may have customized `shell-file-name' to - ;; something which results in `w32-shell-dos-semantics' nil - ;; (which changes the quoting style used by - ;; `shell-quote-argument'), but Git for Windows expects shell - ;; quoting in the dos style. - (shell-file-name (if (and (eq system-type 'windows-nt) - ;; If we have Cygwin mount points, - ;; the git flavor is cygwin, so dos - ;; shell quoting is probably wrong. - (not magit-cygwin-mount-points)) - "cmdproxy" - shell-file-name))) - (with-editor* magit-with-editor-envvar - ,@body))) - -(defmacro magit--with-temp-process-buffer (&rest body) - "Like `with-temp-buffer', but always propagate `process-environment'. -When that var is buffer-local in the calling buffer, it is not -propagated by `with-temp-buffer', so we explicitly ensure that -happens, so that processes will be invoked consistently. BODY is -as for that macro." - (declare (indent 0) (debug (body))) - (let ((p (cl-gensym))) - `(let ((,p process-environment)) - (with-temp-buffer - (setq-local process-environment ,p) - ,@body)))) - -(defsubst magit-git-executable () - "Return value of `magit-git-executable' or `magit-remote-git-executable'. -The variable is chosen depending on whether `default-directory' -is remote." - (if (file-remote-p default-directory) - magit-remote-git-executable - magit-git-executable)) - -(defun magit-process-git-arguments (args) - "Prepare ARGS for a function that invokes Git. - -Magit has many specialized functions for running Git; they all -pass arguments through this function before handing them to Git, -to do the following. - -* Flatten ARGS, removing nil arguments. -* Prepend `magit-git-global-arguments' to ARGS. -* On w32 systems, encode to `w32-ansi-code-page'." - (setq args (append magit-git-global-arguments (flatten-tree args))) - (if (and (eq system-type 'windows-nt) (boundp 'w32-ansi-code-page)) - ;; On w32, the process arguments *must* be encoded in the - ;; current code-page (see #3250). - (mapcar (lambda (arg) - (encode-coding-string - arg (intern (format "cp%d" w32-ansi-code-page)))) - args) - args)) - -(defun magit-git-exit-code (&rest args) - "Execute Git with ARGS, returning its exit code." - (magit-process-git nil args)) - -(defun magit-git-success (&rest args) - "Execute Git with ARGS, returning t if its exit code is 0." - (= (magit-git-exit-code args) 0)) - -(defun magit-git-failure (&rest args) - "Execute Git with ARGS, returning t if its exit code is 1." - (= (magit-git-exit-code args) 1)) - -(defun magit-git-string-p (&rest args) - "Execute Git with ARGS, returning the first line of its output. -If the exit code isn't zero or if there is no output, then return -nil. Neither of these results is considered an error; if that is -what you want, then use `magit-git-string-ng' instead. - -This is an experimental replacement for `magit-git-string', and -still subject to major changes." - (magit--with-refresh-cache (cons default-directory args) - (magit--with-temp-process-buffer - (and (zerop (magit-process-git t args)) - (not (bobp)) - (progn - (goto-char (point-min)) - (buffer-substring-no-properties (point) (line-end-position))))))) - -(defun magit-git-string-ng (&rest args) - "Execute Git with ARGS, returning the first line of its output. -If the exit code isn't zero or if there is no output, then that -is considered an error, but instead of actually signaling an -error, return nil. Additionally the output is put in the process -buffer (creating it if necessary) and the error message is shown -in the status buffer (provided it exists). - -This is an experimental replacement for `magit-git-string', and -still subject to major changes. Also see `magit-git-string-p'." - (magit--with-refresh-cache - (list default-directory 'magit-git-string-ng args) - (magit--with-temp-process-buffer - (let* ((args (magit-process-git-arguments args)) - (status (magit-process-git t args))) - (if (zerop status) - (and (not (bobp)) - (progn - (goto-char (point-min)) - (buffer-substring-no-properties - (point) (line-end-position)))) - (let ((buf (current-buffer))) - (with-current-buffer (magit-process-buffer t) - (magit-process-insert-section default-directory - magit-git-executable args - status buf - 'magit-section-secondary-heading))) - (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) - (let ((msg (magit--locate-error-message))) - (with-current-buffer status-buf - (setq magit-this-error msg)))) - nil))))) - -(defun magit-git-str (&rest args) - "Execute Git with ARGS, returning the first line of its output. -If there is no output, return nil. If the output begins with a -newline, return an empty string. Like `magit-git-string' but -ignore `magit-git-debug'." - (setq args (flatten-tree args)) - (magit--with-refresh-cache (cons default-directory args) - (magit--with-temp-process-buffer - (magit-process-git (list t nil) args) - (unless (bobp) - (goto-char (point-min)) - (buffer-substring-no-properties (point) (line-end-position)))))) - -(defun magit-git-output (&rest args) - "Execute Git with ARGS, returning its output." - (setq args (flatten-tree args)) - (magit--with-refresh-cache (cons default-directory args) - (magit--with-temp-process-buffer - (magit-process-git (list t nil) args) - (buffer-substring-no-properties (point-min) (point-max))))) - -(define-error 'magit-invalid-git-boolean "Not a Git boolean") - -(defun magit-git-true (&rest args) - "Execute Git with ARGS, returning t if it prints \"true\". -If it prints \"false\", then return nil. For any other output -signal `magit-invalid-git-boolean'." - (pcase (magit-git-output args) - ((or "true" "true\n") t) - ((or "false" "false\n") nil) - (output (signal 'magit-invalid-git-boolean (list output))))) - -(defun magit-git-false (&rest args) - "Execute Git with ARGS, returning t if it prints \"false\". -If it prints \"true\", then return nil. For any other output -signal `magit-invalid-git-boolean'." - (pcase (magit-git-output args) - ((or "true" "true\n") nil) - ((or "false" "false\n") t) - (output (signal 'magit-invalid-git-boolean (list output))))) - -(defun magit-git-config-p (variable &optional default) - "Return the boolean value of the Git variable VARIABLE. -VARIABLE has to be specified as a string. Return DEFAULT (which -defaults to nil) if VARIABLE is unset. If VARIABLE's value isn't -a boolean, then raise an error." - (let ((args (list "config" "--bool" "--default" (if default "true" "false") - variable))) - (magit--with-refresh-cache (cons default-directory args) - (magit--with-temp-process-buffer - (let ((status (magit-process-git t args)) - (output (buffer-substring (point-min) (1- (point-max))))) - (if (zerop status) - (equal output "true") - (signal 'magit-invalid-git-boolean (list output)))))))) - -(defun magit-git-insert (&rest args) - "Execute Git with ARGS, insert stdout at point and return exit code. -If `magit-git-debug' in non-nil and the exit code is non-zero, then -insert the run command and stderr into the process buffer." - (apply #'magit--git-insert nil args)) - -(defun magit--git-insert (return-error &rest args) - (setq args (flatten-tree args)) - (if (or return-error magit-git-debug) - (let (log) - (unwind-protect - (let (exit errmsg) - (setq log (make-temp-file "magit-stderr")) - (delete-file log) - (setq exit (magit-process-git (list t log) args)) - (when (or (> exit 0) (eq magit-git-debug 'all)) - (when (file-exists-p log) - (with-temp-buffer - (insert-file-contents log) - (goto-char (point-max)) - (setq errmsg - (if (functionp magit-git-debug) - (funcall magit-git-debug (buffer-string)) - (magit--locate-error-message)))) - (when magit-git-debug - (let ((magit-git-debug nil)) - (with-current-buffer (magit-process-buffer t) - (magit-process-finish-section - (magit-process-insert-section - default-directory magit-git-executable - (magit-process-git-arguments args) - exit log 'magit-section-secondary-heading) - exit))))) - (cond ((not magit-git-debug)) - (errmsg (message "%s" errmsg)) - ((zerop exit)) - ((message "Git returned with exit-code %s" exit)))) - (or errmsg exit)) - (ignore-errors (delete-file log)))) - (magit-process-git (list t nil) args))) - -(defun magit--locate-error-message () - (goto-char (point-max)) - (and (run-hook-wrapped 'magit-process-error-message-regexps - (lambda (re) (re-search-backward re nil t))) - (match-string-no-properties 1))) - -(defun magit-git-string (&rest args) - "Execute Git with ARGS, returning the first line of its output. -If there is no output, return nil. If the output begins with a -newline, return an empty string." - (setq args (flatten-tree args)) - (magit--with-refresh-cache (cons default-directory args) - (magit--with-temp-process-buffer - (apply #'magit-git-insert args) - (unless (bobp) - (goto-char (point-min)) - (buffer-substring-no-properties (point) (line-end-position)))))) - -(defun magit-git-lines (&rest args) - "Execute Git with ARGS, returning its output as a list of lines. -Empty lines anywhere in the output are omitted. - -If Git exits with a non-zero exit status, then report show a -message and add a section in the respective process buffer." - (magit--with-temp-process-buffer - (apply #'magit-git-insert args) - (split-string (buffer-string) "\n" t))) - -(defun magit-git-items (&rest args) - "Execute Git with ARGS, returning its null-separated output as a list. -Empty items anywhere in the output are omitted. - -If Git exits with a non-zero exit status, then report show a -message and add a section in the respective process buffer." - (magit--with-temp-process-buffer - (apply #'magit-git-insert args) - (split-string (buffer-string) "\0" t))) - -(defvar magit--git-wash-keep-error nil) ; experimental - -(defun magit-git-wash (washer &rest args) - "Execute Git with ARGS, inserting washed output at point. -Actually first insert the raw output at point. If there is no -output, call `magit-cancel-section'. Otherwise temporarily narrow -the buffer to the inserted text, move to its beginning, and then -call function WASHER with ARGS as its sole argument." - (declare (indent 1)) - (apply #'magit--git-wash washer magit--git-wash-keep-error args)) - -(defun magit--git-wash (washer keep-error &rest args) - (declare (indent 2)) - (setq args (flatten-tree args)) - (let ((beg (point)) - (exit (magit--git-insert keep-error args))) - (when (stringp exit) - (goto-char beg) - (insert (propertize exit 'face 'error)) - (unless (bolp) - (insert "\n"))) - (if (= (point) beg) - (magit-cancel-section) - (unless (bolp) - (insert "\n")) - (when (or (equal exit 0) - (eq keep-error 'wash-anyway)) - (save-restriction - (narrow-to-region beg (point)) - (goto-char beg) - (funcall washer args)) - (when (or (= (point) beg) - (= (point) (1+ beg))) - (magit-cancel-section)) - (magit-maybe-make-margin-overlay))) - exit)) - -(defun magit-git-executable-find (command) - "Search for COMMAND in Git's exec path, falling back to `exec-path'. -Like `executable-find', return the absolute file name of the -executable." - (or (locate-file command - (list (concat - (file-remote-p default-directory) - (or (magit-git-string "--exec-path") - (error "`git --exec-path' failed")))) - exec-suffixes - #'file-executable-p) - (compat-call executable-find command t))) - -;;; Git Version - -(defconst magit--git-version-regexp - "\\`git version \\([0-9]+\\(\\.[0-9]+\\)\\{1,2\\}\\)") - -(defvar magit--host-git-version-cache nil) - -(defun magit-git-version>= (n) - "Return t if `magit-git-version's value is greater than or equal to N." - (magit--version>= (magit-git-version) n)) - -(defun magit-git-version< (n) - "Return t if `magit-git-version's value is smaller than N." - (version< (magit-git-version) n)) - -(defun magit-git-version () - "Return the Git version used for `default-directory'. -Raise an error if Git cannot be found, if it exits with a -non-zero status, or the output does not have the expected -format." - (magit--with-refresh-cache default-directory - (let ((host (file-remote-p default-directory))) - (or (cdr (assoc host magit--host-git-version-cache)) - (magit--with-temp-process-buffer - ;; Unset global arguments for ancient Git versions. - (let* ((magit-git-global-arguments nil) - (status (magit-process-git t "version")) - (output (buffer-string))) - (cond - ((not (zerop status)) - (display-warning - 'magit - (format "%S\n\nRunning \"%s --version\" failed with output:\n\n%s" - (if host - (format "Magit cannot find Git on host %S.\n -Check the value of `magit-remote-git-executable' using -`magit-debug-git-executable' and consult the info node -`(tramp)Remote programs'." host) - "Magit cannot find Git.\n -Check the values of `magit-git-executable' and `exec-path' -using `magit-debug-git-executable'.") - (magit-git-executable) - output))) - ((save-match-data - (and (string-match magit--git-version-regexp output) - (let ((version (match-string 1 output))) - (push (cons host version) - magit--host-git-version-cache) - version)))) - ((error "Unexpected \"%s --version\" output: %S" - (magit-git-executable) - output))))))))) - -(defun magit-git-version-assert (&optional minimal who) - "Assert that the used Git version is greater than or equal to MINIMAL. -If optional MINIMAL is nil, compare with `magit--minimal-git' -instead. Optional WHO if non-nil specifies what functionality -needs at least MINIMAL, otherwise it defaults to \"Magit\"." - (when (magit-git-version< (or minimal magit--minimal-git)) - (let* ((host (file-remote-p default-directory)) - (msg (format-spec - (cond (host "\ -%w requires Git %m or greater, but on %h the version is %v. - -If multiple Git versions are installed on the host, then the -problem might be that TRAMP uses the wrong executable. - -Check the value of `magit-remote-git-executable' and consult -the info node `(tramp)Remote programs'.\n") - (t "\ -%w requires Git %m or greater, but you are using %v. - -If you have multiple Git versions installed, then check the -values of `magit-remote-git-executable' and `exec-path'.\n")) - `((?w . ,(or who "Magit")) - (?m . ,(or minimal magit--minimal-git)) - (?v . ,(magit-git-version)) - (?h . ,host))))) - (display-warning 'magit msg :error)))) - -(defun magit--safe-git-version () - "Return the Git version used for `default-directory' or an error message." - (magit--with-temp-process-buffer - (let* ((magit-git-global-arguments nil) - (status (magit-process-git t "version")) - (output (buffer-string))) - (cond ((not (zerop status)) output) - ((save-match-data - (and (string-match magit--git-version-regexp output) - (match-string 1 output)))) - (t output))))) - -(defun magit-debug-git-executable () - "Display a buffer with information about `magit-git-executable'. -Also include information about `magit-remote-git-executable'. -See info node `(magit)Debugging Tools' for more information." - (interactive) - (with-current-buffer (get-buffer-create "*magit-git-debug*") - (pop-to-buffer (current-buffer)) - (erase-buffer) - (insert (format "magit-remote-git-executable: %S\n" - magit-remote-git-executable)) - (insert (concat - (format "magit-git-executable: %S" magit-git-executable) - (and (not (file-name-absolute-p magit-git-executable)) - (format " [%S]" (executable-find magit-git-executable))) - (format " (%s)\n" (magit--safe-git-version)))) - (insert (format "exec-path: %S\n" exec-path)) - (when-let ((diff (cl-set-difference - (seq-filter #'file-exists-p (remq nil (parse-colon-path - (getenv "PATH")))) - (seq-filter #'file-exists-p (remq nil exec-path)) - :test #'file-equal-p))) - (insert (format " entries in PATH, but not in exec-path: %S\n" diff))) - (dolist (execdir exec-path) - (insert (format " %s (%s)\n" execdir (car (file-attributes execdir)))) - (when (file-directory-p execdir) - (dolist (exec (directory-files - execdir t (concat - "\\`git" (regexp-opt exec-suffixes) "\\'"))) - (insert (format " %s (%s)\n" exec - (magit--safe-git-version)))))))) - -;;; Variables - -(defun magit-config-get-from-cached-list (key) - (gethash - ;; `git config --list' downcases first and last components of the key. - (let* ((key (replace-regexp-in-string "\\`[^.]+" #'downcase key t t)) - (key (replace-regexp-in-string "[^.]+\\'" #'downcase key t t))) - key) - (magit--with-refresh-cache (cons (magit-toplevel) 'config) - (let ((configs (make-hash-table :test #'equal))) - (dolist (conf (magit-git-items "config" "--list" "-z")) - (let* ((nl-pos (cl-position ?\n conf)) - (key (substring conf 0 nl-pos)) - (val (if nl-pos (substring conf (1+ nl-pos)) ""))) - (puthash key (nconc (gethash key configs) (list val)) configs))) - configs)))) - -(defun magit-get (&rest keys) - "Return the value of the Git variable specified by KEYS." - (car (last (apply #'magit-get-all keys)))) - -(defun magit-get-all (&rest keys) - "Return all values of the Git variable specified by KEYS." - (let ((magit-git-debug nil) - (arg (and (or (null (car keys)) - (string-prefix-p "--" (car keys))) - (pop keys))) - (key (string-join keys "."))) - (if (and magit--refresh-cache (not arg)) - (magit-config-get-from-cached-list key) - (magit-git-items "config" arg "-z" "--get-all" "--include" key)))) - -(defun magit-get-boolean (&rest keys) - "Return the boolean value of the Git variable specified by KEYS. -Also see `magit-git-config-p'." - (let ((arg (and (or (null (car keys)) - (string-prefix-p "--" (car keys))) - (pop keys))) - (key (string-join keys "."))) - (equal (if magit--refresh-cache - (car (last (magit-config-get-from-cached-list key))) - (magit-git-str "config" arg "--bool" "--include" key)) - "true"))) - -(defun magit-set (value &rest keys) - "Set the value of the Git variable specified by KEYS to VALUE." - (let ((arg (and (or (null (car keys)) - (string-prefix-p "--" (car keys))) - (pop keys))) - (key (string-join keys "."))) - (if value - (magit-git-success "config" arg key value) - (magit-git-success "config" arg "--unset" key)) - value)) - -(gv-define-setter magit-get (val &rest keys) - `(magit-set ,val ,@keys)) - -(defun magit-set-all (values &rest keys) - "Set all values of the Git variable specified by KEYS to VALUES." - (let ((arg (and (or (null (car keys)) - (string-prefix-p "--" (car keys))) - (pop keys))) - (var (string-join keys "."))) - (when (magit-get var) - (magit-call-git "config" arg "--unset-all" var)) - (dolist (v values) - (magit-call-git "config" arg "--add" var v)))) - -;;; Files - -(defun magit--safe-default-directory (&optional file) - (catch 'unsafe-default-dir - (let ((dir (file-name-as-directory - (expand-file-name (or file default-directory)))) - (previous nil)) - (while (not (file-accessible-directory-p dir)) - (setq dir (file-name-directory (directory-file-name dir))) - (when (equal dir previous) - (throw 'unsafe-default-dir nil)) - (setq previous dir)) - dir))) - -(defmacro magit--with-safe-default-directory (file &rest body) - (declare (indent 1) (debug (form body))) - `(when-let ((default-directory (magit--safe-default-directory ,file))) - ,@body)) - -(defun magit-git-dir (&optional path) - "Like (expand-file-name PATH (magit-gitdir)) or just (magit-gitdir)." - (declare (obsolete 'magit-gitdir "Magit 4.0.0")) - (and-let* ((dir (magit-gitdir))) - (if path - (expand-file-name (convert-standard-filename path) dir) - dir))) - -(defun magit-gitdir (&optional directory) - "Return the absolute and resolved path of the .git directory. - -If the `GIT_DIR' environment variable is defined, return that. -Otherwise return the .git directory for DIRECTORY, or if that is -nil, then for `default-directory' instead. If the directory is -not located inside a Git repository, then return nil." - (let ((default-directory (or directory default-directory))) - (magit--with-refresh-cache (list default-directory 'magit-gitdir) - (magit--with-safe-default-directory nil - (and-let* - ((dir (magit-rev-parse-safe "--git-dir")) - (dir (file-name-as-directory (magit-expand-git-file-name dir)))) - (if (file-remote-p dir) - dir - (concat (file-remote-p default-directory) dir))))))) - -(defvar magit--separated-gitdirs nil) - -(defun magit--record-separated-gitdir () - (let ((topdir (magit-toplevel)) - (gitdir (magit-gitdir))) - ;; Kludge: git-annex converts submodule gitdirs to symlinks. See #3599. - (when (file-symlink-p (directory-file-name gitdir)) - (setq gitdir (file-truename gitdir))) - ;; We want to delete the entry for `topdir' here, rather than within - ;; (unless ...), in case a `--separate-git-dir' repository was switched to - ;; the standard structure (i.e., "topdir/.git/"). - (setq magit--separated-gitdirs (cl-delete topdir - magit--separated-gitdirs - :key #'car :test #'equal)) - (unless (equal (file-name-as-directory (expand-file-name ".git" topdir)) - gitdir) - (push (cons topdir gitdir) magit--separated-gitdirs)))) - -(defun magit-toplevel (&optional directory) - "Return the absolute path to the toplevel of the current repository. - -From within the working tree or control directory of a repository -return the absolute path to the toplevel directory of the working -tree. As a special case, from within a bare repository return -the control directory instead. When called outside a repository -then return nil. - -When optional DIRECTORY is non-nil then return the toplevel for -that directory instead of the one for `default-directory'. - -Try to respect the option `find-file-visit-truename', i.e., when -the value of that option is nil, then avoid needlessly returning -the truename. When a symlink to a sub-directory of the working -tree is involved, or when called from within a sub-directory of -the gitdir or from the toplevel of a gitdir, which itself is not -located within the working tree, then it is not possible to avoid -returning the truename." - (or - (magit--with-refresh-cache - (cons (or directory default-directory) 'magit-toplevel) - (magit--with-safe-default-directory directory - (if-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) - (let (updir) - (setq topdir (magit-expand-git-file-name topdir)) - (cond - ((and - ;; Always honor these settings. - (not find-file-visit-truename) - (not (getenv "GIT_WORK_TREE")) - ;; `--show-cdup' is the relative path to the toplevel - ;; from `(file-truename default-directory)'. Here we - ;; pretend it is relative to `default-directory', and - ;; go to that directory. Then we check whether - ;; `--show-toplevel' still returns the same value and - ;; whether `--show-cdup' now is the empty string. If - ;; both is the case, then we are at the toplevel of - ;; the same working tree, but also avoided needlessly - ;; following any symlinks. - (progn - (setq updir (file-name-as-directory - (magit-rev-parse-safe "--show-cdup"))) - (setq updir (if (file-name-absolute-p updir) - (concat (file-remote-p default-directory) - updir) - (expand-file-name updir))) - (and-let* - ((default-directory updir) - (top (and (string-equal - (magit-rev-parse-safe "--show-cdup") "") - (magit-rev-parse-safe "--show-toplevel")))) - (string-equal (magit-expand-git-file-name top) topdir)))) - updir) - ((concat (file-remote-p default-directory) - (file-name-as-directory topdir))))) - (and-let* ((gitdir (magit-rev-parse-safe "--git-dir")) - (gitdir (file-name-as-directory - (if (file-name-absolute-p gitdir) - ;; We might have followed a symlink. - (concat (file-remote-p default-directory) - (magit-expand-git-file-name gitdir)) - (expand-file-name gitdir))))) - (if (magit-bare-repo-p) - gitdir - (let* ((link (expand-file-name "gitdir" gitdir)) - (wtree (and (file-exists-p link) - (magit-file-line link)))) - (cond - ((and wtree - ;; Ignore .git/gitdir files that result from a - ;; Git bug. See #2364. - (not (equal wtree ".git"))) - ;; Return the linked working tree. - (concat (file-remote-p default-directory) - (file-name-directory wtree))) - ;; The working directory may not be the parent - ;; directory of .git if it was set up with - ;; "git init --separate-git-dir". See #2955. - ((car (rassoc gitdir magit--separated-gitdirs))) - (;; Step outside the control directory to enter the - ;; working tree. - (file-name-directory (directory-file-name gitdir)))))))))))) - -(defun magit--toplevel-safe () - (or (magit-toplevel) - (magit--not-inside-repository-error))) - -(defmacro magit-with-toplevel (&rest body) - (declare (indent defun) (debug (body))) - `(let ((default-directory (magit--toplevel-safe))) - ,@body)) - -(define-error 'magit-outside-git-repo "Not inside Git repository") -(define-error 'magit-corrupt-git-config "Corrupt Git configuration") -(define-error 'magit-git-executable-not-found - (concat "Git executable cannot be found " - "(see https://magit.vc/goto/e6a78ed2)")) - -(defun magit--assert-usable-git () - (if (not (compat-call executable-find (magit-git-executable) t)) - (signal 'magit-git-executable-not-found (magit-git-executable)) - (let ((magit-git-debug - (lambda (err) - (signal 'magit-corrupt-git-config - (format "%s: %s" default-directory err))))) - ;; This should always succeed unless there's a corrupt config - ;; (or at least a similarly severe failing state). Note that - ;; git-config's --default is avoided because it's not available - ;; until Git 2.18. - (magit-git-string "config" "--get-color" "" "reset")) - nil)) - -(defun magit--not-inside-repository-error () - (magit--assert-usable-git) - (signal 'magit-outside-git-repo default-directory)) - -(defun magit-inside-gitdir-p (&optional noerror) - "Return t if `default-directory' is below the repository directory. -If it is below the working directory, then return nil. -If it isn't below either, then signal an error unless NOERROR -is non-nil, in which case return nil." - (and (magit--assert-default-directory noerror) - ;; Below a repository directory that is not located below the - ;; working directory "git rev-parse --is-inside-git-dir" prints - ;; "false", which is wrong. - (let ((gitdir (magit-gitdir))) - (cond (gitdir (file-in-directory-p default-directory gitdir)) - (noerror nil) - ((signal 'magit-outside-git-repo default-directory)))))) - -(defun magit-inside-worktree-p (&optional noerror) - "Return t if `default-directory' is below the working directory. -If it is below the repository directory, then return nil. -If it isn't below either, then signal an error unless NOERROR -is non-nil, in which case return nil." - (and (magit--assert-default-directory noerror) - (condition-case nil - (magit-rev-parse-true "--is-inside-work-tree") - (magit-invalid-git-boolean - (and (not noerror) - (signal 'magit-outside-git-repo default-directory)))))) - -(cl-defgeneric magit-bare-repo-p (&optional noerror) - "Return t if the current repository is bare. -If it is non-bare, then return nil. If `default-directory' -isn't below a Git repository, then signal an error unless -NOERROR is non-nil, in which case return nil." - (and (magit--assert-default-directory noerror) - (condition-case nil - (magit-rev-parse-true "--is-bare-repository") - (magit-invalid-git-boolean - (and (not noerror) - (signal 'magit-outside-git-repo default-directory)))))) - -(defun magit--assert-default-directory (&optional noerror) - (or (file-directory-p default-directory) - (and (not noerror) - (let ((exists (file-exists-p default-directory))) - (signal (if exists 'file-error 'file-missing) - (list "Running git in directory" - (if exists - "Not a directory" - "No such file or directory") - default-directory)))))) - -(defun magit-git-repo-p (directory &optional non-bare) - "Return t if DIRECTORY is a Git repository. -When optional NON-BARE is non-nil also return nil if DIRECTORY is -a bare repository." - (and (file-directory-p directory) ; Avoid archives, see #3397. - (or (file-regular-p (expand-file-name ".git" directory)) - (file-directory-p (expand-file-name ".git" directory)) - (and (not non-bare) - (file-regular-p (expand-file-name "HEAD" directory)) - (file-directory-p (expand-file-name "refs" directory)) - (file-directory-p (expand-file-name "objects" directory)))))) - -(defun magit-file-relative-name (&optional file tracked) - "Return the path of FILE relative to the repository root. - -If optional FILE is nil or omitted, return the relative path of -the file being visited in the current buffer, if any, else nil. -If the file is not inside a Git repository, then return nil. - -If TRACKED is non-nil, return the path only if it matches a -tracked file." - (unless file - (with-current-buffer (or (buffer-base-buffer) - (current-buffer)) - (setq file (or magit-buffer-file-name buffer-file-name - (and (derived-mode-p 'dired-mode) default-directory))))) - (when (and file (or (not tracked) - (magit-file-tracked-p (file-relative-name file)))) - (and-let* ((dir (magit-toplevel - (magit--safe-default-directory - (directory-file-name (file-name-directory file)))))) - (file-relative-name file dir)))) - -(defun magit-file-ignored-p (file) - (magit-git-string-p "ls-files" "--others" "--ignored" "--exclude-standard" - "--" (magit-convert-filename-for-git file))) - -(defun magit-file-tracked-p (file) - (magit-git-success "ls-files" "--error-unmatch" - "--" (magit-convert-filename-for-git file))) - -(defun magit-list-files (&rest args) - (apply #'magit-git-items "ls-files" "-z" "--full-name" args)) - -(defun magit-tracked-files () - (magit-list-files "--cached")) - -(defun magit-untracked-files (&optional all files compact) - (if compact - (--mapcat (and (eq (aref it 0) ??) - (list (substring it 3))) - (magit-git-items "status" "-z" "--porcelain" - (magit-ignore-submodules-p t) - "--" files)) - (magit-list-files "--other" - (and (not all) "--exclude-standard") - "--" files))) - -(defun magit-modified-files (&optional nomodules files) - (magit-git-items "diff-index" "-z" "--name-only" - ;; Work around a bug in Git v2.46.0. See #5212 and #5221. - (if nomodules "--ignore-submodules" "--submodule=short") - (magit-headish) "--" files)) - -(defun magit-unstaged-files (&optional nomodules files) - (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=u" - ;; Work around a bug in Git v2.46.0. See #5212 and #5221. - (if nomodules "--ignore-submodules" "--submodule=short") - "--" files)) - -(defun magit-staged-files (&optional nomodules files) - (magit-git-items "diff-index" "-z" "--name-only" "--cached" - ;; Work around a bug in Git v2.46.0. See #5212 and #5221. - (if nomodules "--ignore-submodules" "--submodule=short") - (magit-headish) "--" files)) - -(defun magit-binary-files (&rest args) - (--mapcat (and (string-match "^-\t-\t\\(.+\\)" it) - (list (match-string 1 it))) - (apply #'magit-git-items - "diff" "-z" "--numstat" "--ignore-submodules" - args))) - -(defun magit-unmerged-files () - (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=U")) - -(defun magit-ignored-files () - (magit-git-items "ls-files" "-z" "--others" "--ignored" - "--exclude-standard" "--directory")) - -(defun magit-stashed-files (stash) - (magit-git-items "stash" "show" "-z" "--name-only" stash)) - -(defun magit-skip-worktree-files () - (--keep (and (= (aref it 0) ?S) - (substring it 2)) - (magit-list-files "-t"))) - -(defun magit-assume-unchanged-files () - (--keep (and (memq (aref it 0) '(?h ?s ?m ?r ?c ?k)) - (substring it 2)) - (magit-list-files "-v"))) - -(defun magit-revision-files (rev) - (magit-with-toplevel - (magit-git-items "ls-tree" "-z" "-r" "--name-only" rev))) - -(defun magit-revision-directories (rev) - "List directories that contain a tracked file in revision REV." - (magit-with-toplevel - (mapcar #'file-name-as-directory - (magit-git-items "ls-tree" "-z" "-r" "-d" "--name-only" rev)))) - -(defun magit-changed-files (rev-or-range &optional other-rev) - "Return list of files the have changed between two revisions. -If OTHER-REV is non-nil, REV-OR-RANGE should be a revision, not a -range. Otherwise, it can be any revision or range accepted by -\"git diff\" (i.e., <rev>, <revA>..<revB>, or <revA>...<revB>)." - (magit-with-toplevel - (magit-git-items "diff" "-z" "--name-only" rev-or-range other-rev))) - -(defun magit-renamed-files (revA revB) - (mapcar (pcase-lambda (`(,_status ,fileA ,fileB)) - (cons fileA fileB)) - (seq-partition (magit-git-items "diff" "-z" "--name-status" - "--find-renames" - "--diff-filter=R" revA revB) - 3))) - -(defun magit--rev-file-name (file rev other-rev) - "For FILE, potentially renamed between REV and OTHER-REV, return name in REV. -Return nil, if FILE appears neither in REV nor OTHER-REV, -or if no rename is detected." - (or (car (member file (magit-revision-files rev))) - (and-let* ((renamed (magit-renamed-files rev other-rev))) - (car (rassoc file renamed))))) - -(defun magit-file-status (&rest args) - (magit--with-temp-process-buffer - (save-excursion (magit-git-insert "status" "-z" args)) - (let ((pos (point)) status) - (while (> (skip-chars-forward "[:print:]") 0) - (let ((x (char-after pos)) - (y (char-after (1+ pos))) - (file (buffer-substring (+ pos 3) (point)))) - (forward-char) - (if (memq x '(?R ?C)) - (progn - (setq pos (point)) - (skip-chars-forward "[:print:]") - (push (list file (buffer-substring pos (point)) x y) status) - (forward-char)) - (push (list file nil x y) status))) - (setq pos (point))) - status))) - -(defcustom magit-cygwin-mount-points - (and (eq system-type 'windows-nt) - (cl-sort (--map (if (string-match "^\\(.*\\) on \\(.*\\) type" it) - (cons (file-name-as-directory (match-string 2 it)) - (file-name-as-directory (match-string 1 it))) - (lwarn '(magit) :error - "Failed to parse Cygwin mount: %S" it)) - ;; If --exec-path is not a native Windows path, - ;; then we probably have a cygwin git. - (let ((process-environment - (append magit-git-environment - process-environment))) - (and (not (string-match-p - "\\`[a-zA-Z]:" - (car (process-lines - magit-git-executable "--exec-path")))) - (ignore-errors (process-lines "mount"))))) - #'> :key (pcase-lambda (`(,cyg . ,_win)) (length cyg)))) - "Alist of (CYGWIN . WIN32) directory names. -Sorted from longest to shortest CYGWIN name." - :package-version '(magit . "2.3.0") - :group 'magit-process - :type '(alist :key-type string :value-type directory)) - -(defun magit-expand-git-file-name (filename) - (unless (file-name-absolute-p filename) - (setq filename (expand-file-name filename))) - (if-let ((cyg:win (and (not (file-remote-p default-directory)) ; see #4976 - (cl-assoc filename magit-cygwin-mount-points - :test (lambda (f cyg) (string-prefix-p cyg f)))))) - (concat (cdr cyg:win) - (substring filename (length (car cyg:win)))) - filename)) - -(defun magit-convert-filename-for-git (filename) - "Convert FILENAME so that it can be passed to git. -1. If it is a absolute filename, then pass it through - `expand-file-name' to replace things such as \"~/\" that - Git does not understand. -2. If it is a remote filename, then remove the remote part. -3. Deal with an `windows-nt' Emacs vs. Cygwin Git incompatibility." - (if (file-name-absolute-p filename) - (if-let ((cyg:win (cl-rassoc filename magit-cygwin-mount-points - :test (lambda (f win) (string-prefix-p win f))))) - (concat (car cyg:win) - (substring filename (length (cdr cyg:win)))) - (let ((expanded (expand-file-name filename))) - (or (file-remote-p expanded 'localname) - expanded))) - filename)) - -(defun magit-decode-git-path (path) - (if (eq (aref path 0) ?\") - (decode-coding-string (read path) - (or magit-git-output-coding-system - (car default-process-coding-system)) - t) - path)) - -(defun magit-file-at-point (&optional expand assert) - (if-let ((file (magit-section-case - (file (oref it value)) - (hunk (magit-section-parent-value it))))) - (if expand - (expand-file-name file (magit-toplevel)) - file) - (when assert - (user-error "No file at point")))) - -(defun magit-current-file () - (or (magit-file-relative-name) - (magit-file-at-point) - (and (derived-mode-p 'magit-log-mode) - (car magit-buffer-log-files)))) - -;;; Predicates - -(defun magit-no-commit-p () - "Return t if there is no commit in the current Git repository." - (not (magit-rev-verify "HEAD"))) - -(defun magit-merge-commit-p (commit) - "Return t if COMMIT is a merge commit." - (length> (magit-commit-parents commit) 1)) - -(defun magit-anything-staged-p (&optional ignore-submodules &rest files) - "Return t if there are any staged changes. -If optional FILES is non-nil, then only changes to those files -are considered." - (magit-git-failure "diff" "--quiet" "--cached" - (if ignore-submodules - "--ignore-submodules" - ;; Work around a bug in Git v2.46.0. See #5212 and #5221. - "--submodule=short") - "--" files)) - -(defun magit-anything-unstaged-p (&optional ignore-submodules &rest files) - "Return t if there are any unstaged changes. -If optional FILES is non-nil, then only changes to those files -are considered." - (magit-git-failure "diff" "--quiet" - (if ignore-submodules - "--ignore-submodules" - ;; Work around a bug in Git v2.46.0. See #5212 and #5221. - "--submodule=short") - "--" files)) - -(defun magit-anything-modified-p (&optional ignore-submodules &rest files) - "Return t if there are any staged or unstaged changes. -If optional FILES is non-nil, then only changes to those files -are considered." - (or (apply #'magit-anything-staged-p ignore-submodules files) - (apply #'magit-anything-unstaged-p ignore-submodules files))) - -(defun magit-anything-unmerged-p (&rest files) - "Return t if there are any merge conflicts. -If optional FILES is non-nil, then only conflicts in those files -are considered." - (and (magit-git-string "ls-files" "--unmerged" files) t)) - -(defun magit-module-worktree-p (module) - (magit-with-toplevel - (file-exists-p (expand-file-name ".git" module)))) - -(defun magit-module-no-worktree-p (module) - (not (magit-module-worktree-p module))) - -(defun magit-ignore-submodules-p (&optional return-argument) - (or (cl-find-if (lambda (arg) - (string-prefix-p "--ignore-submodules" arg)) - magit-buffer-diff-args) - (and-let* ((value (magit-get "diff.ignoreSubmodules"))) - (if return-argument - (concat "--ignore-submodules=" value) - (concat "diff.ignoreSubmodules=" value))))) - -;;; Revisions and References - -(defun magit-rev-parse (&rest args) - "Execute `git rev-parse ARGS', returning first line of output. -If there is no output, return nil." - (apply #'magit-git-string "rev-parse" args)) - -(defun magit-rev-parse-safe (&rest args) - "Execute `git rev-parse ARGS', returning first line of output. -If there is no output, return nil. Like `magit-rev-parse' but -ignore `magit-git-debug'." - (apply #'magit-git-str "rev-parse" args)) - -(defun magit-rev-parse-true (&rest args) - "Execute `git rev-parse ARGS', returning t if it prints \"true\". -If it prints \"false\", then return nil. For any other output -signal an error." - (magit-git-true "rev-parse" args)) - -(defun magit-rev-parse-false (&rest args) - "Execute `git rev-parse ARGS', returning t if it prints \"false\". -If it prints \"true\", then return nil. For any other output -signal an error." - (magit-git-false "rev-parse" args)) - -(defun magit-rev-parse-p (&rest args) - "Execute `git rev-parse ARGS', returning t if it prints \"true\". -Return t if the first (and usually only) output line is the -string \"true\", otherwise return nil." - (equal (magit-git-str "rev-parse" args) "true")) - -(defun magit-rev-verify (rev) - (magit-git-string-p "rev-parse" "--verify" rev)) - -(defun magit-commit-p (rev) - "Return full hash for REV if it names an existing commit." - (magit-rev-verify (magit--rev-dereference rev))) - -(defalias 'magit-rev-verify-commit #'magit-commit-p) - -(defalias 'magit-rev-hash #'magit-commit-p) - -(defun magit--rev-dereference (rev) - "Return a rev that forces Git to interpret REV as a commit. -If REV is nil or has the form \":/TEXT\", return REV itself." - (cond ((not rev) nil) - ((string-match-p "^:/" rev) rev) - ((concat rev "^{commit}")))) - -(defun magit-rev-equal (a b) - "Return t if there are no differences between the commits A and B." - (magit-git-success "diff" "--quiet" a b)) - -(defun magit-rev-eq (a b) - "Return t if A and B refer to the same commit." - (let ((a (magit-commit-p a)) - (b (magit-commit-p b))) - (and a b (equal a b)))) - -(defun magit-rev-ancestor-p (a b) - "Return non-nil if commit A is an ancestor of commit B." - (magit-git-success "merge-base" "--is-ancestor" a b)) - -(defun magit-rev-head-p (rev) - (or (equal rev "HEAD") - (and rev - (not (string-search ".." rev)) - (equal (magit-rev-parse rev) - (magit-rev-parse "HEAD"))))) - -(defun magit-rev-author-p (rev) - "Return t if the user is the author of REV. -More precisely return t if `user.name' is equal to the author -name of REV and/or `user.email' is equal to the author email -of REV." - (or (equal (magit-get "user.name") (magit-rev-format "%an" rev)) - (equal (magit-get "user.email") (magit-rev-format "%ae" rev)))) - -(defun magit-rev-name (rev &optional pattern not-anchored) - "Return a symbolic name for REV using `git-name-rev'. - -PATTERN can be used to limit the result to a matching ref. -Unless NOT-ANCHORED is non-nil, the beginning of the ref must -match PATTERN. - -An anchored lookup is done using the arguments -\"--exclude=*/<PATTERN> --exclude=*/HEAD\" in addition to -\"--refs=<PATTERN>\", provided at least version v2.13 of Git is -used. Older versions did not support the \"--exclude\" argument. -When \"--exclude\" cannot be used and `git-name-rev' returns a -ref that should have been excluded, then that is discarded and -this function returns nil instead. This is unfortunate because -there might be other refs that do match. To fix that, update -Git." - (if (magit-git-version< "2.13") - (and-let* - ((ref (magit-git-string "name-rev" "--name-only" "--no-undefined" - (and pattern (concat "--refs=" pattern)) - rev))) - (if (and pattern - (string-match-p "\\`refs/[^/]+/\\*\\'" pattern)) - (let ((namespace (substring pattern 0 -1))) - (and (not (or (string-suffix-p "HEAD" ref) - (and (string-match-p namespace ref) - (not (magit-rev-verify - (concat namespace ref)))))) - ref)) - ref)) - (magit-git-string "name-rev" "--name-only" "--no-undefined" - (and pattern (concat "--refs=" pattern)) - (and pattern - (not not-anchored) - (list "--exclude=*/HEAD" - (concat "--exclude=*/" pattern))) - rev))) - -(defun magit-rev-branch (rev) - (and-let* ((name (magit-rev-name rev "refs/heads/*"))) - (and (not (string-match-p "[~^]" name)) name))) - -(defun magit-rev-fixup-target (rev) - (let ((msg (magit-rev-format "%s" rev))) - (save-match-data - (and (string-match "\\`\\(fixup\\|squash\\)! \\(.+\\)" msg) - (magit-rev-format - "%h" (format "%s^{/^%s}" rev - (magit--ext-regexp-quote (match-string 2 msg)))))))) - -(defun magit-get-shortname (rev) - (let* ((fn (apply-partially #'magit-rev-name rev)) - (name (or (funcall fn "refs/tags/*") - (funcall fn "refs/heads/*") - (funcall fn "refs/remotes/*")))) - (cond ((not name) - (magit-rev-parse "--short" rev)) - ((string-match "^\\(?:tags\\|remotes\\)/\\(.+\\)" name) - (if (magit-ref-ambiguous-p (match-string 1 name)) - name - (match-string 1 name))) - ((magit-ref-maybe-qualify name))))) - -(defun magit-name-branch (rev &optional lax) - (or (magit-name-local-branch rev) - (magit-name-remote-branch rev) - (and lax (or (magit-name-local-branch rev t) - (magit-name-remote-branch rev t))))) - -(defun magit-name-local-branch (rev &optional lax) - (and-let* ((name (magit-rev-name rev "refs/heads/*"))) - (and (or lax (not (string-match-p "[~^]" name))) name))) - -(defun magit-name-remote-branch (rev &optional lax) - (and-let* ((name (magit-rev-name rev "refs/remotes/*"))) - (and (or lax (not (string-match-p "[~^]" name))) - (substring name 8)))) - -(defun magit-name-tag (rev &optional lax) - (and-let* ((name (magit-rev-name rev "refs/tags/*"))) - ;; The progn is necessary to work around debbugs#31840. This, and all - ;; the other instances, can be removed once we require at least Emacs 27. - (progn - (when (string-suffix-p "^0" name) - (setq name (substring name 0 -2))) - (and (or lax (not (string-match-p "[~^]" name))) - (substring name 5))))) - -(defun magit-ref-abbrev (refname) - "Return an unambiguous abbreviation of REFNAME." - (magit-rev-parse "--verify" "--abbrev-ref" refname)) - -(defun magit-ref-fullname (refname) - "Return fully qualified refname for REFNAME. -If REFNAME is ambiguous, return nil." - (magit-rev-parse "--verify" "--symbolic-full-name" refname)) - -(defun magit-ref-ambiguous-p (refname) - (save-match-data - (if (string-match "\\`\\([^^~]+\\)\\(.*\\)" refname) - (not (magit-ref-fullname (match-string 1 refname))) - (error "%S has an unrecognized format" refname)))) - -(defun magit-ref-maybe-qualify (refname &optional prefix) - "If REFNAME is ambiguous, try to disambiguate it by prepend PREFIX to it. -Return an unambiguous refname, either REFNAME or that prefixed -with PREFIX, nil otherwise. If REFNAME has an offset suffix -such as \"~1\", then that is preserved. If optional PREFIX is -nil, then use \"heads/\". " - (if (magit-ref-ambiguous-p refname) - (let ((refname (concat (or prefix "heads/") refname))) - (and (not (magit-ref-ambiguous-p refname)) refname)) - refname)) - -(defun magit-ref-exists-p (ref) - (magit-git-success "show-ref" "--verify" ref)) - -(defun magit-ref-equal (a b) - "Return t if the refnames A and B are `equal'. -A symbolic-ref pointing to some ref, is `equal' to that ref, -as are two symbolic-refs pointing to the same ref. Refnames -may be abbreviated." - (let ((a (magit-ref-fullname a)) - (b (magit-ref-fullname b))) - (and a b (equal a b)))) - -(defun magit-ref-eq (a b) - "Return t if the refnames A and B are `eq'. -A symbolic-ref is `eq' to itself, but not to the ref it points -to, or to some other symbolic-ref that points to the same ref." - (let ((symbolic-a (magit-symbolic-ref-p a)) - (symbolic-b (magit-symbolic-ref-p b))) - (or (and symbolic-a - symbolic-b - (equal a b)) - (and (not symbolic-a) - (not symbolic-b) - (magit-ref-equal a b))))) - -(defun magit-headish () - "Return the `HEAD' or if that doesn't exist the hash of the empty tree." - (if (magit-no-commit-p) - (magit-git-string "mktree") - "HEAD")) - -(defun magit-branch-at-point () - (magit-section-case - (branch (oref it value)) - (commit (or (magit--painted-branch-at-point) - (magit-name-branch (oref it value)))))) - -(defun magit--painted-branch-at-point (&optional type) - (or (and (not (eq type 'remote)) - (memq (get-text-property (magit-point) 'font-lock-face) - (list 'magit-branch-local - 'magit-branch-current)) - (and-let* ((branch (magit-thing-at-point 'git-revision t))) - (cdr (magit-split-branch-name branch)))) - (and (not (eq type 'local)) - (memq (get-text-property (magit-point) 'font-lock-face) - (list 'magit-branch-remote - 'magit-branch-remote-head)) - (thing-at-point 'git-revision t)))) - -(defun magit-local-branch-at-point () - (magit-section-case - (branch (let ((branch (magit-ref-maybe-qualify (oref it value)))) - (when (member branch (magit-list-local-branch-names)) - branch))) - (commit (or (magit--painted-branch-at-point 'local) - (magit-name-local-branch (oref it value)))))) - -(defun magit-remote-branch-at-point () - (magit-section-case - (branch (let ((branch (oref it value))) - (when (member branch (magit-list-remote-branch-names)) - branch))) - (commit (or (magit--painted-branch-at-point 'remote) - (magit-name-remote-branch (oref it value)))))) - -(defun magit-commit-at-point () - (or (magit-section-value-if 'commit) - (magit-thing-at-point 'git-revision t) - (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) - (fboundp 'magit-current-blame-chunk) - (magit-current-blame-chunk)))) - (oref chunk orig-rev)) - (and (derived-mode-p 'magit-stash-mode - 'magit-merge-preview-mode - 'magit-revision-mode) - magit-buffer-revision))) - -(defun magit-branch-or-commit-at-point () - (or (magit-section-case - (branch (magit-ref-maybe-qualify (oref it value))) - (commit (or (magit--painted-branch-at-point) - (let ((rev (oref it value))) - (or (magit-name-branch rev) rev)))) - (tag (magit-ref-maybe-qualify (oref it value) "tags/")) - (pullreq (or (and (fboundp 'forge--pullreq-branch) - (magit-branch-p - (forge--pullreq-branch (oref it value)))) - (magit-ref-p (format "refs/pullreqs/%s" - (oref (oref it value) number))))) - ((unpulled unpushed) - (magit-ref-abbrev - (replace-regexp-in-string "\\.\\.\\.?" "" (oref it value))))) - (magit-thing-at-point 'git-revision t) - (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) - (fboundp 'magit-current-blame-chunk) - (magit-current-blame-chunk)))) - (oref chunk orig-rev)) - (and magit-buffer-file-name - magit-buffer-refname) - (and (derived-mode-p 'magit-stash-mode - 'magit-merge-preview-mode - 'magit-revision-mode) - magit-buffer-revision))) - -(defun magit-tag-at-point () - (magit-section-case - (tag (oref it value)) - (commit (magit-name-tag (oref it value))))) - -(defun magit-stash-at-point () - (magit-section-value-if 'stash)) - -(defun magit-remote-at-point () - (magit-section-case - (remote (oref it value)) - ([branch remote] (magit-section-parent-value it)))) - -(defun magit-module-at-point (&optional predicate) - (when (magit-section-match 'module) - (let ((module (oref (magit-current-section) value))) - (and (or (not predicate) - (funcall predicate module)) - module)))) - -(defun magit-get-current-branch () - "Return the refname of the currently checked out branch. -Return nil if no branch is currently checked out." - (magit-git-string "symbolic-ref" "--short" "HEAD")) - -(defvar magit-get-previous-branch-timeout 0.5 - "Maximum time to spend in `magit-get-previous-branch'. -Given as a number of seconds.") - -(defun magit-get-previous-branch () - "Return the refname of the previously checked out branch. -Return nil if no branch can be found in the `HEAD' reflog -which is different from the current branch and still exists. -The amount of time spent searching is limited by -`magit-get-previous-branch-timeout'." - (let ((t0 (float-time)) - (current (magit-get-current-branch)) - (i 1) prev) - (while (if (> (- (float-time) t0) magit-get-previous-branch-timeout) - (setq prev nil) ;; Timed out. - (and (setq prev (magit-rev-verify (format "@{-%d}" i))) - (or (not (setq prev (magit-rev-branch prev))) - (equal prev current)))) - (cl-incf i)) - prev)) - -(defun magit--set-default-branch (newname oldname) - (let ((remote (or (magit-primary-remote) - (user-error "Cannot determine primary remote"))) - (branches (mapcar (lambda (line) (split-string line "\t")) - (magit-git-lines - "for-each-ref" "refs/heads" - "--format=%(refname:short)\t%(upstream:short)")))) - (when-let ((old (assoc oldname branches)) - ((not (assoc newname branches)))) - (magit-call-git "branch" "-m" oldname newname) - (setcar old newname)) - (let ((new (if (magit-branch-p newname) - newname - (concat remote "/" newname)))) - (pcase-dolist (`(,branch ,upstream) branches) - (cond - ((equal upstream oldname) - (magit-set-upstream-branch branch new)) - ((equal upstream (concat remote "/" oldname)) - (magit-set-upstream-branch branch (concat remote "/" newname)))))))) - -(defun magit--get-default-branch (&optional update) - (let ((remote (magit-primary-remote))) - (when update - (if (not remote) - (user-error "Cannot determine primary remote") - (message "Determining default branch...") - (magit-git "fetch" "--prune") - (magit-git "remote" "set-head" "--auto" remote) - (message "Determining default branch...done"))) - (let ((branch (magit-git-string "symbolic-ref" "--short" - (format "refs/remotes/%s/HEAD" remote)))) - (when (and update (not branch)) - (error "Cannot determine new default branch")) - (list remote (and branch (cdr (magit-split-branch-name branch))))))) - -(defun magit-set-upstream-branch (branch upstream) - "Set UPSTREAM as the upstream of BRANCH. -If UPSTREAM is nil, then unset BRANCH's upstream. -Otherwise UPSTREAM has to be an existing branch." - (if upstream - (magit-call-git "branch" "--set-upstream-to" upstream branch) - (magit-call-git "branch" "--unset-upstream" branch))) - -(defun magit-get-upstream-ref (&optional branch) - "Return the upstream branch of BRANCH as a fully qualified ref. -It BRANCH is nil, then return the upstream of the current branch, -if any, nil otherwise. If the upstream is not configured, the -configured remote is an url, or the named branch does not exist, -then return nil. I.e., return an existing local or -remote-tracking branch ref." - (and-let* ((branch (or branch (magit-get-current-branch)))) - (magit-ref-fullname (concat branch "@{upstream}")))) - -(defun magit-get-upstream-branch (&optional branch) - "Return the name of the upstream branch of BRANCH. -It BRANCH is nil, then return the upstream of the current branch -if any, nil otherwise. If the upstream is not configured, the -configured remote is an url, or the named branch does not exist, -then return nil. I.e., return the name of an existing local or -remote-tracking branch. The returned string is colorized -according to the branch type." - (magit--with-refresh-cache - (list default-directory 'magit-get-upstream-branch branch) - (and-let* ((branch (or branch (magit-get-current-branch))) - (upstream (magit-ref-abbrev (concat branch "@{upstream}")))) - (magit--propertize-face - upstream (if (equal (magit-get "branch" branch "remote") ".") - 'magit-branch-local - 'magit-branch-remote))))) - -(defun magit-get-indirect-upstream-branch (branch &optional force) - (let ((remote (magit-get "branch" branch "remote"))) - (and remote (not (equal remote ".")) - ;; The user has opted in... - (or force - (--some (if (magit-git-success "check-ref-format" "--branch" it) - (equal it branch) - (string-match-p it branch)) - magit-branch-prefer-remote-upstream)) - ;; and local BRANCH tracks a remote branch... - (let ((upstream (magit-get-upstream-branch branch))) - ;; whose upstream... - (and upstream - ;; has the same name as BRANCH... - (equal (substring upstream (1+ (length remote))) branch) - ;; and can be fast-forwarded to BRANCH. - (magit-rev-ancestor-p upstream branch) - upstream))))) - -(defun magit-get-upstream-remote (&optional branch allow-unnamed) - (and-let* ((branch (or branch (magit-get-current-branch))) - (remote (magit-get "branch" branch "remote"))) - (and (not (equal remote ".")) - (cond ((member remote (magit-list-remotes)) - (magit--propertize-face remote 'magit-branch-remote)) - ((and allow-unnamed - (string-match-p "\\(\\`.\\{0,2\\}/\\|[:@]\\)" remote)) - (magit--propertize-face remote 'bold)))))) - -(defun magit-get-unnamed-upstream (&optional branch) - (and-let* ((branch (or branch (magit-get-current-branch))) - (remote (magit-get "branch" branch "remote")) - (merge (magit-get "branch" branch "merge"))) - (and (magit--unnamed-upstream-p remote merge) - (list (magit--propertize-face remote 'bold) - (magit--propertize-face merge 'magit-branch-remote))))) - -(defun magit--unnamed-upstream-p (remote merge) - (and remote (string-match-p "\\(\\`\\.\\{0,2\\}/\\|[:@]\\)" remote) - merge (string-prefix-p "refs/" merge))) - -(defun magit--valid-upstream-p (remote merge) - (and (or (equal remote ".") - (member remote (magit-list-remotes))) - (string-prefix-p "refs/" merge))) - -(defun magit-get-current-remote (&optional allow-unnamed) - (or (magit-get-upstream-remote nil allow-unnamed) - (and-let* ((remotes (magit-list-remotes)) - (remote (if (length= remotes 1) - (car remotes) - (magit-primary-remote)))) - (magit--propertize-face remote 'magit-branch-remote)))) - -(defun magit-get-push-remote (&optional branch) - (and-let* ((remote - (or (and (or branch (setq branch (magit-get-current-branch))) - (magit-get "branch" branch "pushRemote")) - (magit-get "remote.pushDefault")))) - (magit--propertize-face remote 'magit-branch-remote))) - -(defun magit-get-push-branch (&optional branch verify) - (magit--with-refresh-cache - (list default-directory 'magit-get-push-branch branch verify) - (and-let* ((branch (or branch (setq branch (magit-get-current-branch)))) - (remote (magit-get-push-remote branch)) - (target (concat remote "/" branch))) - (and (or (not verify) - (magit-rev-verify target)) - (magit--propertize-face target 'magit-branch-remote))))) - -(defun magit-get-@{push}-branch (&optional branch) - (let ((ref (magit-rev-parse "--symbolic-full-name" - (concat branch "@{push}")))) - (and ref - (string-prefix-p "refs/remotes/" ref) - (substring ref 13)))) - -(defun magit-get-remote (&optional branch) - (and (or branch (setq branch (magit-get-current-branch))) - (let ((remote (magit-get "branch" branch "remote"))) - (and (not (equal remote ".")) - remote)))) - -(defun magit-get-some-remote (&optional branch) - (or (magit-get-remote branch) - (and-let* ((main (magit-main-branch))) - (magit-get-remote main)) - (magit-primary-remote) - (car (magit-list-remotes)))) - -(defvar magit-primary-remote-names - '("upstream" "origin")) - -(defun magit-primary-remote () - "Return the primary remote. - -The primary remote is the remote that tracks the repository that -other repositories are forked from. It often is called \"origin\" -but because many people name their own fork \"origin\", using that -term would be ambiguous. Likewise we avoid the term \"upstream\" -because a branch's @{upstream} branch may be a local branch or a -branch from a remote other than the primary remote. - -If a remote exists whose name matches `magit.primaryRemote', then -that is considered the primary remote. If no remote by that name -exists, then remotes in `magit-primary-remote-names' are tried in -order and the first remote from that list that actually exists in -the current repository is considered its primary remote." - (let ((remotes (magit-list-remotes))) - (seq-find (lambda (name) - (member name remotes)) - (delete-dups - (delq nil - (cons (magit-get "magit.primaryRemote") - magit-primary-remote-names)))))) - -(defun magit-branch-merged-p (branch &optional target) - "Return non-nil if BRANCH is merged into its upstream and TARGET. - -TARGET defaults to the current branch. If `HEAD' is detached and -TARGET is nil, then always return nil. As a special case, if -TARGET is t, then return non-nil if BRANCH is merged into any one -of the other local branches. - -If, and only if, BRANCH has an upstream, then only return non-nil -if BRANCH is merged into both TARGET (as described above) as well -as into its upstream." - (and (if-let ((upstream (and (magit-branch-p branch) - (magit-get-upstream-branch branch)))) - (magit-rev-ancestor-p branch upstream) - t) - (if (eq target t) - (delete (magit-name-local-branch branch) - (magit-list-containing-branches branch)) - (and-let* ((target (or target (magit-get-current-branch)))) - (magit-rev-ancestor-p branch target))))) - -(defun magit-get-tracked (refname) - "Return the remote branch tracked by the remote-tracking branch REFNAME. -The returned value has the form (REMOTE . REF), where REMOTE is -the name of a remote and REF is the ref local to the remote." - (and-let* ((ref (magit-ref-fullname refname))) - (save-match-data - (seq-some (lambda (line) - (and (string-match "\ -\\`remote\\.\\([^.]+\\)\\.fetch=\\+?\\([^:]+\\):\\(.+\\)" line) - (let ((rmt (match-string 1 line)) - (src (match-string 2 line)) - (dst (match-string 3 line))) - (and (string-match (format "\\`%s\\'" - (string-replace - "*" "\\(.+\\)" dst)) - ref) - (cons rmt (string-replace - "*" (match-string 1 ref) src)))))) - (magit-git-lines "config" "--local" "--list"))))) - -(defun magit-split-branch-name (branch) - (cond ((member branch (magit-list-local-branch-names)) - (cons "." branch)) - ((string-match "/" branch) - (or (seq-some (lambda (remote) - (and (string-match - (format "\\`\\(%s\\)/\\(.+\\)\\'" remote) - branch) - (cons (match-string 1 branch) - (match-string 2 branch)))) - (magit-list-remotes)) - (error "Invalid branch name %s" branch))))) - -(defun magit-get-current-tag (&optional rev with-distance) - "Return the closest tag reachable from REV. - -If optional REV is nil, then default to `HEAD'. -If optional WITH-DISTANCE is non-nil then return (TAG COMMITS), -if it is `dirty' return (TAG COMMIT DIRTY). COMMITS is the number -of commits in `HEAD' but not in TAG and DIRTY is t if there are -uncommitted changes, nil otherwise." - (and-let* ((str (magit-git-str "describe" "--long" "--tags" - (and (eq with-distance 'dirty) "--dirty") - rev))) - (save-match-data - (string-match - "\\(.+\\)-\\(?:0[0-9]*\\|\\([0-9]+\\)\\)-g[0-9a-z]+\\(-dirty\\)?$" str) - (if with-distance - `(,(match-string 1 str) - ,(string-to-number (or (match-string 2 str) "0")) - ,@(and (match-string 3 str) (list t))) - (match-string 1 str))))) - -(defun magit-get-next-tag (&optional rev with-distance) - "Return the closest tag from which REV is reachable. - -If optional REV is nil, then default to `HEAD'. -If no such tag can be found or if the distance is 0 (in which -case it is the current tag, not the next), return nil instead. -If optional WITH-DISTANCE is non-nil, then return (TAG COMMITS) -where COMMITS is the number of commits in TAG but not in REV." - (and-let* ((str (magit-git-str "describe" "--contains" (or rev "HEAD")))) - (save-match-data - (when (string-match "^[^^~]+" str) - (setq str (match-string 0 str)) - (unless (equal str (magit-get-current-tag rev)) - (if with-distance - (list str (car (magit-rev-diff-count str rev))) - str)))))) - -(defun magit-list-refs (&optional namespaces format sortby) - "Return list of references, excluding symbolic references. - -When NAMESPACES is non-nil, list refs from these namespaces -rather than those from `magit-list-refs-namespaces'. - -FORMAT is passed to the `--format' flag of `git for-each-ref' -and defaults to \"%(refname)\". - -SORTBY is a key or list of keys to pass to the `--sort' flag of -`git for-each-ref'. When nil, use `magit-list-refs-sortby'" - (unless format - (setq format "%(refname)")) - (seq-keep (lambda (line) - (pcase-let* ((`(,symrefp ,value) - (split-string line " ")) - (symrefp (not (equal symrefp "")))) - (and (not symrefp) value))) - (magit-git-lines "for-each-ref" - (concat "--format=%(symref) " format) - (--map (concat "--sort=" it) - (pcase (or sortby magit-list-refs-sortby) - ((and val (pred stringp)) (list val)) - ((and val (pred listp)) val))) - (or namespaces magit-list-refs-namespaces)))) - -(defun magit-list-branches () - (magit-list-refs (list "refs/heads" "refs/remotes"))) - -(defun magit-list-local-branches () - (magit-list-refs "refs/heads")) - -(defun magit-list-remote-branches (&optional remote) - (magit-list-refs (concat "refs/remotes/" remote))) - -(defun magit-list-related-branches (relation &optional commit &rest args) - (--remove (string-match-p "\\(\\`(HEAD\\|HEAD -> \\)" it) - (--map (substring it 2) - (magit-git-lines "branch" args relation commit)))) - -(defun magit-list-containing-branches (&optional commit &rest args) - (magit-list-related-branches "--contains" commit args)) - -(defun magit-list-publishing-branches (&optional commit) - (--filter (magit-rev-ancestor-p (or commit "HEAD") it) - magit-published-branches)) - -(defun magit-list-merged-branches (&optional commit &rest args) - (magit-list-related-branches "--merged" commit args)) - -(defun magit-list-unmerged-branches (&optional commit &rest args) - (magit-list-related-branches "--no-merged" commit args)) - -(defun magit-list-unmerged-to-upstream-branches () - (--filter (and-let* ((upstream (magit-get-upstream-branch it))) - (member it (magit-list-unmerged-branches upstream))) - (magit-list-local-branch-names))) - -(defun magit-list-branches-pointing-at (commit) - (let ((re (format "\\`%s refs/\\(heads\\|remotes\\)/\\(.*\\)\\'" - (magit-rev-verify commit)))) - (--keep (and (string-match re it) - (let ((name (match-string 2 it))) - (and (not (string-suffix-p "HEAD" name)) - name))) - (magit-git-lines "show-ref")))) - -(defun magit-list-refnames (&optional namespaces include-special) - (nconc (magit-list-refs namespaces "%(refname:short)") - (and include-special - (magit-list-special-refnames)))) - -(defvar magit-special-refnames - '("HEAD" "ORIG_HEAD" "FETCH_HEAD" "MERGE_HEAD" "CHERRY_PICK_HEAD")) - -(defun magit-list-special-refnames () - (let ((gitdir (magit-gitdir))) - (cl-mapcan (lambda (name) - (and (file-exists-p (expand-file-name name gitdir)) - (list name))) - magit-special-refnames))) - -(defun magit-list-branch-names () - (magit-list-refnames (list "refs/heads" "refs/remotes"))) - -(defun magit-list-local-branch-names () - (magit-list-refnames "refs/heads")) - -(defun magit-list-remote-branch-names (&optional remote relative) - (if (and remote relative) - (let ((regexp (format "^refs/remotes/%s/\\(.+\\)" remote))) - (--mapcat (when (string-match regexp it) - (list (match-string 1 it))) - (magit-list-remote-branches remote))) - (magit-list-refnames (concat "refs/remotes/" remote)))) - -(defun magit-format-refs (format &rest args) - (let ((lines (magit-git-lines - "for-each-ref" (concat "--format=" format) - (or args (list "refs/heads" "refs/remotes" "refs/tags"))))) - (if (string-search "\f" format) - (--map (split-string it "\f") lines) - lines))) - -(defun magit-list-remotes () - (magit-git-lines "remote")) - -(defun magit-list-tags () - (magit-git-lines "tag")) - -(defun magit-list-stashes (&optional format) - (magit-git-lines "stash" "list" (concat "--format=" (or format "%gd")))) - -(defun magit-list-active-notes-refs () - "Return notes refs according to `core.notesRef' and `notes.displayRef'." - (magit-git-lines "for-each-ref" "--format=%(refname)" - (or (magit-get "core.notesRef") "refs/notes/commits") - (magit-get-all "notes.displayRef"))) - -(defun magit-list-notes-refnames () - (--map (substring it 6) (magit-list-refnames "refs/notes"))) - -(defun magit-remote-list-tags (remote) - (--keep (and (not (string-suffix-p "^{}" it)) - (substring it 51)) - (magit-git-lines "ls-remote" "--tags" remote))) - -(defun magit-remote-list-branches (remote) - (--keep (and (not (string-suffix-p "^{}" it)) - (substring it 52)) - (magit-git-lines "ls-remote" "--heads" remote))) - -(defun magit-remote-list-refs (remote) - (--keep (and (not (string-suffix-p "^{}" it)) - (substring it 41)) - (magit-git-lines "ls-remote" remote))) - -(defun magit-remote-head (remote) - (and-let* ((line (cl-find-if - (lambda (line) - (string-match - "\\`ref: refs/heads/\\([^\s\t]+\\)[\s\t]HEAD\\'" line)) - (magit-git-lines "ls-remote" "--symref" remote "HEAD")))) - (match-string 1 line))) - -(defun magit-list-modified-modules () - (--keep (and (string-match "\\`\\+\\([^ ]+\\) \\(.+\\) (.+)\\'" it) - (match-string 2 it)) - (magit-git-lines "submodule" "status"))) - -(defun magit-list-module-paths () - (magit-with-toplevel - (--mapcat (and (string-match "^160000 [0-9a-z]\\{40,\\} 0\t\\(.+\\)$" it) - (list (match-string 1 it))) - (magit-git-items "ls-files" "-z" "--stage")))) - -(defun magit-list-module-names () - (mapcar #'magit-get-submodule-name (magit-list-module-paths))) - -(defun magit-get-submodule-name (path) - "Return the name of the submodule at PATH. -PATH has to be relative to the super-repository." - (if (magit-git-version>= "2.38.0") - ;; "git submodule--helper name" was removed, - ;; but might still come back in another form. - (substring - (car (split-string - (car (or (magit-git-items - "config" "-z" - "-f" (expand-file-name ".gitmodules" (magit-toplevel)) - "--get-regexp" "^submodule\\..*\\.path$" - (concat "^" (regexp-quote (directory-file-name path)) "$")) - (error "No such submodule `%s'" path))) - "\n")) - 10 -5) - (magit-git-string "submodule--helper" "name" path))) - -(defun magit-list-worktrees () - "Return list of the worktrees of this repository. - -The returned list has the form (PATH COMMIT BRANCH BARE DETACHED -LOCKED PRUNABLE). The last four elements are booleans, with the -exception of LOCKED and PRUNABLE, which may also be strings. -See git-worktree(1) manpage for the meaning of the various parts. - -This function corrects a situation where \"git worktree list\" -would claim a worktree is bare, even though the working tree is -specified using `core.worktree'." - (let ((remote (file-remote-p default-directory)) - worktrees worktree) - (dolist (line (let ((magit-git-global-arguments - ;; KLUDGE At least in Git v2.8.3 this argument - ;; would trigger a segfault. - (remove "--no-pager" magit-git-global-arguments))) - (if (magit-git-version>= "2.36") - (magit-git-items "worktree" "list" "--porcelain" "-z") - (magit-git-lines "worktree" "list" "--porcelain")))) - (cond ((string-prefix-p "worktree" line) - (let ((path (substring line 9))) - (when remote - (setq path (concat remote path))) - ;; If the git directory is separate from the main - ;; worktree, then "git worktree" returns the git - ;; directory instead of the worktree, which isn't - ;; what it is supposed to do and not what we want. - ;; However, if the worktree has been removed, then - ;; we want to return it anyway; instead of nil. - (setq path (or (magit-toplevel path) path)) - (setq worktree (list path nil nil nil nil nil nil)) - (push worktree worktrees))) - ((string-prefix-p "HEAD" line) - (setf (nth 1 worktree) (substring line 5))) - ((string-prefix-p "branch" line) - (setf (nth 2 worktree) (substring line 18))) - ((string-equal line "bare") - (let* ((default-directory (car worktree)) - (wt (and (not (magit-get-boolean "core.bare")) - (magit-get "core.worktree")))) - (if (and wt (file-exists-p (expand-file-name wt))) - (progn (setf (nth 0 worktree) (expand-file-name wt)) - (setf (nth 2 worktree) (magit-rev-parse "HEAD")) - (setf (nth 3 worktree) (magit-get-current-branch))) - (setf (nth 3 worktree) t)))) - ((string-equal line "detached") - (setf (nth 4 worktree) t)) - ((string-prefix-p line "locked") - (setf (nth 5 worktree) - (if (> (length line) 6) (substring line 7) t))) - ((string-prefix-p line "prunable") - (setf (nth 6 worktree) - (if (> (length line) 8) (substring line 9) t))))) - (nreverse worktrees))) - -(defun magit-symbolic-ref-p (name) - (magit-git-success "symbolic-ref" "--quiet" name)) - -(defun magit-ref-p (rev) - (or (car (member rev (magit-list-refs "refs/"))) - (car (member rev (magit-list-refnames "refs/"))))) - -(defun magit-branch-p (rev) - (or (car (member rev (magit-list-branches))) - (car (member rev (magit-list-branch-names))))) - -(defun magit-local-branch-p (rev) - (or (car (member rev (magit-list-local-branches))) - (car (member rev (magit-list-local-branch-names))))) - -(defun magit-remote-branch-p (rev) - (or (car (member rev (magit-list-remote-branches))) - (car (member rev (magit-list-remote-branch-names))))) - -(defun magit-branch-set-face (branch) - (magit--propertize-face branch (if (magit-local-branch-p branch) - 'magit-branch-local - 'magit-branch-remote))) - -(defun magit-tag-p (rev) - (car (member rev (magit-list-tags)))) - -(defun magit-remote-p (string) - (car (member string (magit-list-remotes)))) - -(defvar magit-main-branch-names - '("main" "master" "trunk" "development") - "Branch names reserved for use by the primary branch. -Use function `magit-main-branch' to get the name actually used in -the current repository.") - -(defvar magit-long-lived-branches - (append magit-main-branch-names (list "maint" "next")) - "Branch names reserved for use by long lived branches.") - -(defun magit-main-branch () - "Return the main branch. - -If a branch exists whose name matches `init.defaultBranch', then -that is considered the main branch. If no branch by that name -exists, then the branch names in `magit-main-branch-names' are -tried in order. The first branch from that list that actually -exists in the current repository is considered its main branch." - (let ((branches (magit-list-local-branch-names))) - (seq-find (lambda (name) - (member name branches)) - (delete-dups - (delq nil - (cons (magit-get "init.defaultBranch") - magit-main-branch-names)))))) - -(defun magit-rev-diff-count (a b &optional first-parent) - "Return the commits in A but not B and vice versa. -Return a list of two integers: (A>B B>A). - -If `first-parent' is set, traverse only first parents." - (mapcar #'string-to-number - (split-string (magit-git-string "rev-list" - "--count" "--left-right" - (and first-parent "--first-parent") - (concat a "..." b)) - "\t"))) - -(defun magit-abbrev-length () - (let ((abbrev (magit-get "core.abbrev"))) - (if (and abbrev (not (equal abbrev "auto"))) - (string-to-number abbrev) - ;; Guess the length git will be using based on an example - ;; abbreviation. Actually HEAD's abbreviation might be an - ;; outlier, so use the shorter of the abbreviations for two - ;; commits. See #3034. - (if-let ((head (magit-rev-parse "--short" "HEAD")) - (head-len (length head))) - (min head-len - (if-let ((rev (magit-rev-parse "--short" "HEAD~"))) - (length rev) - head-len)) - ;; We're on an unborn branch, but perhaps the repository has - ;; other commits. See #4123. - (if-let ((commits (magit-git-lines "rev-list" "-n2" "--all" - "--abbrev-commit"))) - (apply #'min (mapcar #'length commits)) - ;; A commit does not exist. Fall back to the default of 7. - 7))))) - -(defun magit-abbrev-arg (&optional arg) - (format "--%s=%d" (or arg "abbrev") (magit-abbrev-length))) - -(defun magit-rev-abbrev (rev) - (magit-rev-parse (magit-abbrev-arg "short") rev)) - -(defun magit-commit-children (commit &optional args) - (mapcar #'car - (--filter (member commit (cdr it)) - (--map (split-string it " ") - (magit-git-lines - "log" "--format=%H %P" - (or args (list "--branches" "--tags" "--remotes")) - "--not" commit))))) - -(defun magit-commit-parents (commit) - (and-let* ((str (magit-git-string "rev-list" "-1" "--parents" commit))) - (cdr (split-string str)))) - -(defun magit-patch-id (rev) - (magit--with-connection-local-variables - (magit--with-temp-process-buffer - (magit-process-file - shell-file-name nil '(t nil) nil shell-command-switch - (let ((exec (shell-quote-argument (magit-git-executable)))) - (format "%s diff-tree -u %s | %s patch-id" exec rev exec))) - (car (split-string (buffer-string)))))) - -(defun magit-rev-format (format &optional rev args) - ;; Prefer `git log --no-walk' to `git show --no-patch' because it - ;; performs better in some scenarios. - (let ((str (magit-git-string "log" "--no-walk" - (concat "--format=" format) args - (if rev (magit--rev-dereference rev) "HEAD") - "--"))) - (and (not (string-equal str "")) - str))) - -(defun magit-rev-insert-format (format &optional rev args) - ;; Prefer `git log --no-walk' to `git show --no-patch' because it - ;; performs better in some scenarios. - (magit-git-insert "log" "--no-walk" - (concat "--format=" format) args - (if rev (magit--rev-dereference rev) "HEAD") - "--")) - -(defun magit-format-rev-summary (rev) - (and-let* ((str (magit-rev-format "%h %s" rev))) - (progn - (magit--put-face 0 (string-match " " str) 'magit-hash str) - str))) - -(defvar magit-ref-namespaces - '(("\\`HEAD\\'" . magit-head) - ("\\`refs/tags/\\(.+\\)" . magit-tag) - ("\\`refs/heads/\\(.+\\)" . magit-branch-local) - ("\\`refs/remotes/\\(.+\\)" . magit-branch-remote) - ("\\`refs/bisect/\\(bad\\)" . magit-bisect-bad) - ("\\`refs/bisect/\\(skip.*\\)" . magit-bisect-skip) - ("\\`refs/bisect/\\(good.*\\)" . magit-bisect-good) - ("\\`refs/stash$" . magit-refname-stash) - ("\\`refs/wip/\\(.+\\)" . magit-refname-wip) - ("\\`refs/pullreqs/\\(.+\\)" . magit-refname-pullreq) - ("\\`\\(bad\\):" . magit-bisect-bad) - ("\\`\\(skip\\):" . magit-bisect-skip) - ("\\`\\(good\\):" . magit-bisect-good) - ("\\`\\(.+\\)" . magit-refname)) - "How refs are formatted for display. - -Each entry controls how a certain type of ref is displayed, and -has the form (REGEXP . FACE). REGEXP is a regular expression -used to match full refs. The first entry whose REGEXP matches -the reference is used. - -In log and revision buffers the first regexp submatch becomes the -\"label\" that represents the ref and is propertized with FONT. -In refs buffers the displayed text is controlled by other means -and this option only controls what face is used.") - -(defun magit-format-ref-labels (string) - (save-match-data - (let ((regexp "\\(, \\|tag: \\|HEAD -> \\)") - names) - (if (and (derived-mode-p 'magit-log-mode) - (member "--simplify-by-decoration" magit-buffer-log-args)) - (let ((branches (magit-list-local-branch-names)) - (re (format "^%s/.+" (regexp-opt (magit-list-remotes))))) - (setq names - (--map (cond ((string-equal it "HEAD") it) - ((string-prefix-p "refs/" it) it) - ((member it branches) (concat "refs/heads/" it)) - ((string-match re it) (concat "refs/remotes/" it)) - (t (concat "refs/" it))) - (split-string - (string-replace "tag: " "refs/tags/" string) - regexp t)))) - (setq names (split-string string regexp t))) - (let (state head upstream tags branches remotes other combined) - (dolist (ref names) - (let* ((face (cdr (--first (string-match (car it) ref) - magit-ref-namespaces))) - (name (magit--propertize-face - (or (match-string 1 ref) ref) face))) - (cl-case face - ((magit-bisect-bad magit-bisect-skip magit-bisect-good) - (setq state name)) - (magit-head - (setq head (magit--propertize-face "@" 'magit-head))) - (magit-tag (push name tags)) - (magit-branch-local (push name branches)) - (magit-branch-remote (push name remotes)) - (t (push name other))))) - (setq remotes - (seq-keep - (lambda (name) - (if (string-match "\\`\\([^/]*\\)/\\(.*\\)\\'" name) - (let ((r (match-string 1 name)) - (b (match-string 2 name))) - (and (not (equal b "HEAD")) - (if (equal (concat "refs/remotes/" name) - (magit-git-string - "symbolic-ref" - (format "refs/remotes/%s/HEAD" r))) - (magit--propertize-face - name 'magit-branch-remote-head) - name))) - name)) - remotes)) - (let* ((current (magit-get-current-branch)) - (target (magit-get-upstream-branch current))) - (dolist (name branches) - (let ((push (car (member (magit-get-push-branch name) remotes)))) - (when push - (setq remotes (delete push remotes)) - (string-match "^[^/]*/" push) - (setq push (substring push 0 (match-end 0)))) - (cond - ((equal name current) - (setq head - (concat push - (magit--propertize-face - name 'magit-branch-current)))) - ((equal name target) - (setq upstream - (concat push - (magit--propertize-face - name '(magit-branch-upstream - magit-branch-local))))) - (t - (push (concat push name) combined))))) - (when (and target (not upstream)) - (if (member target remotes) - (progn - (magit--add-face-text-property - 0 (length target) 'magit-branch-upstream nil target) - (setq upstream target) - (setq remotes (delete target remotes))) - (when-let ((target (car (member target combined)))) - (magit--add-face-text-property - 0 (length target) 'magit-branch-upstream nil target) - (setq upstream target) - (setq combined (delete target combined)))))) - (string-join (flatten-tree `(,state - ,head - ,upstream - ,@(nreverse tags) - ,@(nreverse combined) - ,@(nreverse remotes) - ,@other)) - " "))))) - -(defun magit-object-type (object) - (magit-git-string "cat-file" "-t" object)) - -(defmacro magit-with-blob (commit file &rest body) - (declare (indent 2) - (debug (form form body))) - `(magit--with-temp-process-buffer - (let ((buffer-file-name ,file)) - (save-excursion - (magit-git-insert "cat-file" "-p" - (concat ,commit ":" buffer-file-name))) - (decode-coding-inserted-region - (point-min) (point-max) buffer-file-name t nil nil t) - ,@body))) - -(defmacro magit-with-temp-index (tree arg &rest body) - (declare (indent 2) (debug (form form body))) - (let ((file (cl-gensym "file"))) - `(let ((magit--refresh-cache nil) - (,file (magit-convert-filename-for-git - (make-temp-name - (expand-file-name "index.magit." (magit-gitdir)))))) - (unwind-protect - (magit-with-toplevel - (when-let* ((tree ,tree) - ((not (magit-git-success - "read-tree" ,arg tree - (concat "--index-output=" ,file))))) - (error "Cannot read tree %s" tree)) - (with-environment-variables (("GIT_INDEX_FILE" ,file)) - ,@body)) - (ignore-errors - (delete-file (concat (file-remote-p default-directory) ,file))))))) - -(defun magit-commit-tree (message &optional tree &rest parents) - (magit-git-string "commit-tree" "--no-gpg-sign" "-m" message - (--mapcat (list "-p" it) (delq nil parents)) - (or tree - (magit-git-string "write-tree") - (error "Cannot write tree")))) - -(defun magit-commit-worktree (message &optional arg &rest other-parents) - (magit-with-temp-index "HEAD" arg - (and (magit-update-files (magit-unstaged-files)) - (apply #'magit-commit-tree message nil "HEAD" other-parents)))) - -(defun magit-update-files (files) - (magit-git-success "update-index" "--add" "--remove" "--" files)) - -(defun magit-update-ref (ref message rev &optional stashish) - (let ((magit--refresh-cache nil)) - (or (if (magit-git-version>= "2.6.0") - (zerop (magit-call-git "update-ref" "--create-reflog" - "-m" message ref rev - (or (magit-rev-verify ref) ""))) - ;; `--create-reflog' didn't exist before v2.6.0 - (let ((oldrev (magit-rev-verify ref)) - (logfile (expand-file-name (concat "logs/" ref) - (magit-gitdir)))) - (unless (file-exists-p logfile) - (when oldrev - (magit-git-success "update-ref" "-d" ref oldrev)) - (make-directory (file-name-directory logfile) t) - (with-temp-file logfile) - (when (and oldrev (not stashish)) - (magit-git-success "update-ref" "-m" "enable reflog" - ref oldrev "")))) - (magit-git-success "update-ref" "-m" message ref rev - (or (magit-rev-verify ref) ""))) - (error "Cannot update %s with %s" ref rev)))) - -(defconst magit-range-re - (concat "\\`\\([^ \t]*[^.]\\)?" ; revA - "\\(\\.\\.\\.?\\)" ; range marker - "\\([^.][^ \t]*\\)?\\'")) ; revB - -(defun magit-split-range (range) - (pcase-let ((`(,beg ,end ,sep) (magit--split-range-raw range))) - (and sep - (let ((beg (or beg "HEAD")) - (end (or end "HEAD"))) - (if (string-equal (match-string 2 range) "...") - (and-let* ((base (magit-git-string "merge-base" beg end))) - (cons base end)) - (cons beg end)))))) - -(defun magit--split-range-raw (range) - (and (string-match magit-range-re range) - (let ((beg (match-string 1 range)) - (end (match-string 3 range))) - (and (or beg end) - (list beg end (match-string 2 range)))))) - -(defun magit-hash-range (range) - (if (string-match magit-range-re range) - (let ((beg (match-string 1 range)) - (end (match-string 3 range))) - (and (or beg end) - (let ((beg-hash (and beg (magit-rev-hash (match-string 1 range)))) - (end-hash (and end (magit-rev-hash (match-string 3 range))))) - (and (or (not beg) beg-hash) - (or (not end) end-hash) - (concat beg-hash (match-string 2 range) end-hash))))) - (magit-rev-hash range))) - -(defvar magit-revision-faces - '(magit-hash - magit-tag - magit-branch-remote - magit-branch-remote-head - magit-branch-local - magit-branch-current - magit-branch-upstream - magit-branch-warning - magit-head - magit-refname - magit-refname-stash - magit-refname-wip - magit-refname-pullreq)) - -(put 'git-revision 'thing-at-point #'magit-thingatpt--git-revision) -(defun magit-thingatpt--git-revision (&optional disallow) - ;; Support hashes and references. - (and-let* ((bounds - (let ((c (concat "\s\n\t~^:?*[\\" disallow))) - (cl-letf - (((get 'git-revision 'beginning-op) - (lambda () - (if (re-search-backward (format "[%s]" c) nil t) - (forward-char) - (goto-char (point-min))))) - ((get 'git-revision 'end-op) - (lambda () - (re-search-forward (format "\\=[^%s]*" c) nil t)))) - (bounds-of-thing-at-point 'git-revision)))) - (string (buffer-substring-no-properties (car bounds) (cdr bounds))) - ;; References are allowed to contain most parentheses and - ;; most punctuation, but if those characters appear at the - ;; edges of a possible reference in arbitrary text, then - ;; they are much more likely to be intended as just that: - ;; punctuation and delimiters. - (string (thread-first string - (string-trim-left "[(</]") - (string-trim-right "[])>/.,;!]")))) - (let (disallow) - (when (or (string-match-p "\\.\\." string) - (string-match-p "/\\." string)) - (setq disallow (concat disallow "."))) - (when (string-match-p "@{" string) - (setq disallow (concat disallow "@{"))) - (if disallow - ;; These additional restrictions overcompensate, - ;; but that only matters in rare cases. - (magit-thingatpt--git-revision disallow) - (and (not (equal string "@")) - (or (and (>= (length string) 7) - (string-match-p "[a-z]" string) - (magit-commit-p string)) - (and (magit-ref-p string) - (let ((face (get-text-property (point) 'face))) - (or (not face) - (member face magit-revision-faces))))) - string))))) - -(put 'git-revision-range 'thing-at-point #'magit-thingatpt--git-revision-range) -(defun magit-thingatpt--git-revision-range () - ;; Support hashes but no references. - (and-let* ((bounds - (cl-letf (((get 'git-revision 'beginning-op) - (lambda () - (if (re-search-backward "[^a-z0-9.]" nil t) - (forward-char) - (goto-char (point-min))))) - ((get 'git-revision 'end-op) - (lambda () - (and (re-search-forward "[^a-z0-9.]" nil t) - (backward-char))))) - (bounds-of-thing-at-point 'git-revision))) - (range (buffer-substring-no-properties (car bounds) (cdr bounds)))) - ;; Validate but return as-is. - (and (magit-hash-range range) range))) - -;;; Completion - -(defvar magit-revision-history nil) - -(defun magit--minibuf-default-add-commit () - (let ((fn minibuffer-default-add-function)) - (setq-local - minibuffer-default-add-function - (lambda () - (let ((rest (and (functionp fn) (funcall fn)))) - (if-let ((commit (with-selected-window (minibuffer-selected-window) - (or (magit-thing-at-point 'git-revision-range t) - (magit-commit-at-point))))) - (let ((rest (cons commit (delete commit rest))) - (def minibuffer-default)) - (if (listp def) - (append def rest) - (cons def (delete def rest)))) - rest)))))) - -(defun magit-read-branch (prompt &optional secondary-default) - (magit-completing-read prompt (magit-list-branch-names) - nil t nil 'magit-revision-history - (or (magit-branch-at-point) - secondary-default - (magit-get-current-branch)))) - -(defun magit-read-branch-or-commit (prompt &optional secondary-default exclude) - (let ((current (magit-get-current-branch)) - (branch-at-point (magit-branch-at-point)) - (commit-at-point (magit-commit-at-point)) - (choices (delete exclude (magit-list-refnames nil t)))) - (when (equal current exclude) - (setq current nil)) - (when (equal branch-at-point exclude) - (setq branch-at-point nil)) - (when (and commit-at-point (not branch-at-point)) - (setq choices (cons commit-at-point choices))) - (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit - (or (magit-completing-read - prompt choices nil nil nil 'magit-revision-history - (or branch-at-point commit-at-point secondary-default current)) - (user-error "Nothing selected"))))) - -(defun magit-read-range-or-commit (prompt &optional secondary-default) - (magit-read-range - prompt - (or (and-let* ((revs (magit-region-values '(commit branch) t))) - (progn - (deactivate-mark) - (concat (car (last revs)) ".." (car revs)))) - (magit-branch-or-commit-at-point) - secondary-default - (magit-get-current-branch)))) - -(defun magit-read-range (prompt &optional default) - (minibuffer-with-setup-hook - (lambda () - (magit--minibuf-default-add-commit) - (setq-local crm-separator "\\.\\.\\.?")) - (magit-completing-read-multiple - (concat prompt ": ") - (magit-list-refnames) - nil nil nil 'magit-revision-history default nil t))) - -(defun magit-read-remote-branch - (prompt &optional remote default local-branch require-match) - (let ((choice (magit-completing-read - prompt - (cl-union (and local-branch - (if remote - (list local-branch) - (--map (concat it "/" local-branch) - (magit-list-remotes)))) - (magit-list-remote-branch-names remote t) - :test #'equal) - nil require-match nil 'magit-revision-history default))) - (if (or remote (string-match "\\`\\([^/]+\\)/\\(.+\\)" choice)) - choice - (user-error "`%s' doesn't have the form REMOTE/BRANCH" choice)))) - -(defun magit-read-refspec (prompt remote) - (magit-completing-read prompt - (prog2 (message "Determining available refs...") - (magit-remote-list-refs remote) - (message "Determining available refs...done")))) - -(defun magit-read-local-branch (prompt &optional secondary-default) - (magit-completing-read prompt (magit-list-local-branch-names) - nil t nil 'magit-revision-history - (or (magit-local-branch-at-point) - secondary-default - (magit-get-current-branch)))) - -(defun magit-read-local-branch-or-commit (prompt) - (let ((choices (nconc (magit-list-local-branch-names) - (magit-list-special-refnames))) - (commit (magit-commit-at-point))) - (when commit - (push commit choices)) - (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit - (or (magit-completing-read prompt choices - nil nil nil 'magit-revision-history - (or (magit-local-branch-at-point) commit)) - (user-error "Nothing selected"))))) - -(defun magit-read-local-branch-or-ref (prompt &optional secondary-default) - (magit-completing-read prompt (nconc (magit-list-local-branch-names) - (magit-list-refs "refs/")) - nil t nil 'magit-revision-history - (or (magit-local-branch-at-point) - secondary-default - (magit-get-current-branch)))) - -(defun magit-read-other-branch - (prompt &optional exclude secondary-default no-require-match) - (let* ((current (magit-get-current-branch)) - (atpoint (magit-branch-at-point)) - (exclude (or exclude current)) - (default (or (and (not (equal atpoint exclude)) atpoint) - (and (not (equal current exclude)) current) - secondary-default - (magit-get-previous-branch)))) - (magit-completing-read prompt (delete exclude (magit-list-branch-names)) - nil (not no-require-match) - nil 'magit-revision-history default))) - -(defun magit-read-other-branch-or-commit - (prompt &optional exclude secondary-default) - (let* ((current (magit-get-current-branch)) - (atpoint (magit-branch-or-commit-at-point)) - (exclude (or exclude current)) - (default (or (and (not (equal atpoint exclude)) - (not (and (not current) - (magit-rev-equal atpoint "HEAD"))) - atpoint) - (and (not (equal current exclude)) current) - secondary-default - (magit-get-previous-branch)))) - (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit - (or (magit-completing-read prompt (delete exclude (magit-list-refnames)) - nil nil nil 'magit-revision-history default) - (user-error "Nothing selected"))))) - -(defun magit-read-other-local-branch - (prompt &optional exclude secondary-default no-require-match) - (let* ((current (magit-get-current-branch)) - (atpoint (magit-local-branch-at-point)) - (exclude (or exclude current)) - (default (or (and (not (equal atpoint exclude)) atpoint) - (and (not (equal current exclude)) current) - secondary-default - (magit-get-previous-branch)))) - (magit-completing-read prompt - (delete exclude (magit-list-local-branch-names)) - nil (not no-require-match) - nil 'magit-revision-history default))) - -(defun magit-read-branch-prefer-other (prompt) - (let* ((current (magit-get-current-branch)) - (commit (magit-commit-at-point)) - (atrev (and commit (magit-list-branches-pointing-at commit))) - (atpoint (magit--painted-branch-at-point))) - (magit-completing-read prompt (magit-list-branch-names) - nil t nil 'magit-revision-history - (or (magit-section-value-if 'branch) - atpoint - (and (not (cdr atrev)) (car atrev)) - (--first (not (equal it current)) atrev) - (magit-get-previous-branch) - (car atrev))))) - -(defun magit-read-upstream-branch (&optional branch prompt) - "Read the upstream for BRANCH using PROMPT. -If optional BRANCH is nil, then read the upstream for the -current branch, or raise an error if no branch is checked -out. Only existing branches can be selected." - (unless branch - (setq branch (or (magit-get-current-branch) - (error "Need a branch to set its upstream")))) - (let ((branches (delete branch (magit-list-branch-names)))) - (magit-completing-read - (or prompt (format "Change upstream of %s to" branch)) - branches nil t nil 'magit-revision-history - (or (let ((r (car (member (magit-remote-branch-at-point) branches))) - (l (car (member (magit-local-branch-at-point) branches)))) - (if magit-prefer-remote-upstream (or r l) (or l r))) - (and-let* ((main (magit-main-branch))) - (let ((r (car (member (concat "origin/" main) branches))) - (l (car (member main branches)))) - (if magit-prefer-remote-upstream (or r l) (or l r)))) - (car (member (magit-get-previous-branch) branches)))))) - -(defun magit-read-starting-point (prompt &optional branch default) - (or (magit-completing-read - (concat prompt - (and branch - (if (bound-and-true-p ivy-mode) - ;; Ivy-mode strips faces from prompt. - (format " `%s'" branch) - (concat " " (magit--propertize-face - branch 'magit-branch-local)))) - " starting at") - (nconc (list "HEAD") - (magit-list-refnames) - (directory-files (magit-gitdir) nil "_HEAD\\'")) - nil nil nil 'magit-revision-history - (or default (magit--default-starting-point))) - (user-error "Nothing selected"))) - -(defun magit--default-starting-point () - (or (let ((r (magit-remote-branch-at-point)) - (l (magit-local-branch-at-point))) - (if magit-prefer-remote-upstream (or r l) (or l r))) - (magit-commit-at-point) - (magit-stash-at-point) - (magit-get-current-branch))) - -(defun magit-read-tag (prompt &optional require-match) - (magit-completing-read prompt (magit-list-tags) nil - require-match nil 'magit-revision-history - (magit-tag-at-point))) - -(defun magit-read-stash (prompt) - (let* ((atpoint (magit-stash-at-point)) - (default (and atpoint - (concat atpoint (magit-rev-format " %s" atpoint)))) - (choices (mapcar (lambda (c) - (pcase-let ((`(,rev ,msg) (split-string c "\0"))) - (concat (propertize rev 'face 'magit-hash) - " " msg))) - (magit-list-stashes "%gd%x00%s"))) - (choice (magit-completing-read prompt choices - nil t nil nil - default - (car choices)))) - (and choice - (string-match "^\\([^ ]+\\) \\(.+\\)" choice) - (substring-no-properties (match-string 1 choice))))) - -(defun magit-read-remote (prompt &optional default use-only) - (let ((remotes (magit-list-remotes))) - (if (and use-only (length= remotes 1)) - (car remotes) - (magit-completing-read prompt remotes - nil t nil nil - (or default - (magit-remote-at-point) - (magit-get-remote)))))) - -(defun magit-read-remote-or-url (prompt &optional default) - (magit-completing-read prompt - (nconc (magit-list-remotes) - (list "https://" "git://" "git@")) - nil nil nil nil - (or default - (magit-remote-at-point) - (magit-get-remote)))) - -(defun magit-read-module-path (prompt &optional predicate) - (magit-completing-read prompt (magit-list-module-paths) - predicate t nil nil - (magit-module-at-point predicate))) - -(defun magit-module-confirm (verb &optional predicate) - ;; Some predicates use the inefficient `magit-toplevel' - ;; and some repositories have thousands of submodules. - (let ((magit--refresh-cache (list (cons 0 0))) - (modules nil)) - (if current-prefix-arg - (progn - (setq modules (magit-list-module-paths)) - (when predicate - (setq modules (seq-filter predicate modules))) - (unless modules - (if predicate - (user-error "No modules satisfying %s available" predicate) - (user-error "No modules available")))) - (setq modules (magit-region-values 'module)) - (when modules - (when predicate - (setq modules (seq-filter predicate modules))) - (unless modules - (user-error "No modules satisfying %s selected" predicate)))) - (if (or (length> modules 1) current-prefix-arg) - (magit-confirm t nil (format "%s %%d modules" verb) nil modules) - (list (magit-read-module-path (format "%s module" verb) predicate))))) - -;;; _ -(provide 'magit-git) -;;; magit-git.el ends here diff --git a/emacs/elpa/magit-20241106.1441/magit-git.elc b/emacs/elpa/magit-20241106.1441/magit-git.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-log.elc b/emacs/elpa/magit-20241106.1441/magit-log.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-pkg.el b/emacs/elpa/magit-20241106.1441/magit-pkg.el @@ -1,18 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "magit" "20241106.1441" - "A Git porcelain inside Emacs." - '((emacs "26.1") - (compat "30.0.0.0") - (dash "2.19.1") - (magit-section "4.1.2") - (seq "2.24") - (transient "0.7.8") - (with-editor "3.4.2")) - :url "https://github.com/magit/magit" - :commit "1c30bb1f9fb0668ec385fc3fb899b30d5507fad8" - :revdesc "1c30bb1f9fb0" - :keywords '("git" "tools" "vc") - :authors '(("Marius Vollmer" . "marius.vollmer@gmail.com") - ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) - :maintainers '(("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") - ("Kyle Meyer" . "kyle@kyleam.com"))) diff --git a/emacs/elpa/magit-20241106.1441/magit-stash.elc b/emacs/elpa/magit-20241106.1441/magit-stash.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit.el b/emacs/elpa/magit-20241106.1441/magit.el @@ -1,789 +0,0 @@ -;;; magit.el --- A Git porcelain inside Emacs -*- lexical-binding:t; coding:utf-8 -*- - -;; Copyright (C) 2008-2024 The Magit Project Contributors - -;; Author: Marius Vollmer <marius.vollmer@gmail.com> -;; Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> -;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> -;; Kyle Meyer <kyle@kyleam.com> -;; Former-Maintainers: -;; Nicolas Dudebout <nicolas.dudebout@gatech.edu> -;; Noam Postavsky <npostavs@users.sourceforge.net> -;; Peter J. Weisberg <pj@irregularexpressions.net> -;; Phil Jackson <phil@shellarchive.co.uk> -;; Rémi Vanicat <vanicat@debian.org> -;; Yann Hodique <yann.hodique@gmail.com> - -;; Homepage: https://github.com/magit/magit -;; Keywords: git tools vc - -;; Package-Version: 20241106.1441 -;; Package-Revision: 1c30bb1f9fb0 -;; Package-Requires: ( -;; (emacs "26.1") -;; (compat "30.0.0.0") -;; (dash "2.19.1") -;; (magit-section "4.1.2") -;; (seq "2.24") -;; (transient "0.7.8") -;; (with-editor "3.4.2")) - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; Magit 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. -;; -;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. - -;; You should have received a copy of the AUTHORS.md file, which -;; lists all contributors. If not, see https://magit.vc/authors. - -;;; Commentary: - -;; Magit is a text-based Git user interface that puts an unmatched focus -;; on streamlining workflows. Commands are invoked using short mnemonic -;; key sequences that take the cursor’s position in the highly actionable -;; interface into account to provide context-sensitive behavior. - -;; With Magit you can do nearly everything that you can do when using Git -;; on the command-line, but at greater speed and while taking advantage -;; of advanced features that previously seemed too daunting to use on a -;; daily basis. Many users will find that by using Magit they can become -;; more effective Git user. - -;;; Code: - -(require 'magit-core) -(require 'magit-diff) -(require 'magit-log) -(require 'magit-wip) -(require 'magit-apply) -(require 'magit-repos) -(require 'git-commit) - -(require 'format-spec) -(require 'package nil t) ; used in `magit-version' -(require 'with-editor) - -;; For `magit:--gpg-sign' -(declare-function epg-list-keys "epg" (context &optional name mode)) -(declare-function epg-decode-dn "epg" (alist)) -(defvar epa-protocol) - -;;; Options - -(defcustom magit-openpgp-default-signing-key nil - "Fingerprint of your default Openpgp key used for signing. -If the specified primary key has signing capacity then it is used -as the value of the `--gpg-sign' argument without prompting, even -when other such keys exist. To be able to select another key you -must then use a prefix argument." - :package-version '(magit . "4.0.0") - :group 'magit-commands - :type 'string) - -;;; Faces - -(defface magit-header-line - '((t :inherit magit-section-heading)) - "Face for the `header-line' in some Magit modes. -Note that some modes, such as `magit-log-select-mode', have their -own faces for the `header-line', or for parts of the -`header-line'." - :group 'magit-faces) - -(defface magit-header-line-key - '((t :inherit font-lock-builtin-face)) - "Face for keys in the `header-line'." - :group 'magit-faces) - -(defface magit-dimmed - '((((class color) (background light)) :foreground "grey50") - (((class color) (background dark)) :foreground "grey50")) - "Face for text that shouldn't stand out." - :group 'magit-faces) - -(defface magit-hash - '((((class color) (background light)) :foreground "grey60") - (((class color) (background dark)) :foreground "grey40")) - "Face for the commit object name in the log output." - :group 'magit-faces) - -(defface magit-tag - '((((class color) (background light)) :foreground "Goldenrod4") - (((class color) (background dark)) :foreground "LightGoldenrod2")) - "Face for tag labels shown in log buffer." - :group 'magit-faces) - -(defface magit-branch-remote - '((((class color) (background light)) :foreground "DarkOliveGreen4") - (((class color) (background dark)) :foreground "DarkSeaGreen2")) - "Face for remote branch head labels shown in log buffer." - :group 'magit-faces) - -(defface magit-branch-remote-head - '((((supports (:box t))) :inherit magit-branch-remote :box t) - (t :inherit magit-branch-remote :inverse-video t)) - "Face for current branch." - :group 'magit-faces) - -(defface magit-branch-local - '((((class color) (background light)) :foreground "SkyBlue4") - (((class color) (background dark)) :foreground "LightSkyBlue1")) - "Face for local branches." - :group 'magit-faces) - -(defface magit-branch-current - '((((supports (:box t))) :inherit magit-branch-local :box t) - (t :inherit magit-branch-local :inverse-video t)) - "Face for current branch." - :group 'magit-faces) - -(defface magit-branch-upstream - '((t :slant italic)) - "Face for upstream branch. -This face is only used in logs and it gets combined - with `magit-branch-local', `magit-branch-remote' -and/or `magit-branch-remote-head'." - :group 'magit-faces) - -(defface magit-branch-warning - '((t :inherit warning)) - "Face for warning about (missing) branch." - :group 'magit-faces) - -(defface magit-head - '((((class color) (background light)) :inherit magit-branch-local) - (((class color) (background dark)) :inherit magit-branch-local)) - "Face for the symbolic ref `HEAD'." - :group 'magit-faces) - -(defface magit-refname - '((((class color) (background light)) :foreground "grey30") - (((class color) (background dark)) :foreground "grey80")) - "Face for refnames without a dedicated face." - :group 'magit-faces) - -(defface magit-refname-stash - '((t :inherit magit-refname)) - "Face for stash refnames." - :group 'magit-faces) - -(defface magit-refname-wip - '((t :inherit magit-refname)) - "Face for wip refnames." - :group 'magit-faces) - -(defface magit-refname-pullreq - '((t :inherit magit-refname)) - "Face for pullreq refnames." - :group 'magit-faces) - -(defface magit-keyword - '((t :inherit font-lock-string-face)) - "Face for parts of commit messages inside brackets." - :group 'magit-faces) - -(defface magit-keyword-squash - '((t :inherit font-lock-warning-face)) - "Face for squash! and fixup! keywords in commit messages." - :group 'magit-faces) - -(defface magit-signature-good - '((t :foreground "green")) - "Face for good signatures." - :group 'magit-faces) - -(defface magit-signature-bad - '((t :foreground "red" :weight bold)) - "Face for bad signatures." - :group 'magit-faces) - -(defface magit-signature-untrusted - '((t :foreground "medium aquamarine")) - "Face for good untrusted signatures." - :group 'magit-faces) - -(defface magit-signature-expired - '((t :foreground "orange")) - "Face for signatures that have expired." - :group 'magit-faces) - -(defface magit-signature-expired-key - '((t :inherit magit-signature-expired)) - "Face for signatures made by an expired key." - :group 'magit-faces) - -(defface magit-signature-revoked - '((t :foreground "violet red")) - "Face for signatures made by a revoked key." - :group 'magit-faces) - -(defface magit-signature-error - '((t :foreground "light blue")) - "Face for signatures that cannot be checked (e.g., missing key)." - :group 'magit-faces) - -(defface magit-cherry-unmatched - '((t :foreground "cyan")) - "Face for unmatched cherry commits." - :group 'magit-faces) - -(defface magit-cherry-equivalent - '((t :foreground "magenta")) - "Face for equivalent cherry commits." - :group 'magit-faces) - -(defface magit-filename - '((t :weight normal)) - "Face for filenames." - :group 'magit-faces) - -;;; Global Bindings - -;;;###autoload -(defcustom magit-define-global-key-bindings 'default - "Which set of key bindings to add to the global keymap, if any. - -This option controls which set of Magit key bindings, if any, may -be added to the global keymap, even before Magit is first used in -the current Emacs session. - -If the value is nil, no bindings are added. - -If `default', maybe add: - - C-x g `magit-status' - C-x M-g `magit-dispatch' - C-c M-g `magit-file-dispatch' - -If `recommended', maybe add: - - C-x g `magit-status' - C-c g `magit-dispatch' - C-c f `magit-file-dispatch' - - These bindings are strongly recommended, but we cannot use - them by default, because the \"C-c <LETTER>\" namespace is - strictly reserved for bindings added by the user. - -The bindings in the chosen set may be added when -`after-init-hook' is run. Each binding is added if, and only -if, at that time no other key is bound to the same command, -and no other command is bound to the same key. In other words -we try to avoid adding bindings that are unnecessary, as well -as bindings that conflict with other bindings. - -Adding these bindings is delayed until `after-init-hook' is -run to allow users to set the variable anywhere in their init -file (without having to make sure to do so before `magit' is -loaded or autoloaded) and to increase the likelihood that all -the potentially conflicting user bindings have already been -added. - -To set this variable use either `setq' or the Custom interface. -Do not use the function `customize-set-variable' because doing -that would cause Magit to be loaded immediately, when that form -is evaluated (this differs from `custom-set-variables', which -doesn't load the libraries that define the customized variables). - -Setting this variable has no effect if `after-init-hook' has -already been run." - :package-version '(magit . "4.0.0") - :group 'magit-essentials - :type '(choice (const :tag "Add no binding" nil) - (const :tag "Use default bindings" default) - (const :tag "Use recommended bindings" recommended))) - -;;;###autoload -(progn - (defun magit-maybe-define-global-key-bindings (&optional force) - "See variable `magit-define-global-key-bindings'." - (when magit-define-global-key-bindings - (let ((map (current-global-map))) - (pcase-dolist (`(,key . ,def) - (cond ((eq magit-define-global-key-bindings 'recommended) - '(("C-x g" . magit-status) - ("C-c g" . magit-dispatch) - ("C-c f" . magit-file-dispatch))) - ('(("C-x g" . magit-status) - ("C-x M-g" . magit-dispatch) - ("C-c M-g" . magit-file-dispatch))))) - ;; This is autoloaded and thus is used before `compat' is - ;; loaded, so we cannot use `keymap-lookup' and `keymap-set'. - (when (or force - (not (or (lookup-key map (kbd key)) - (where-is-internal def (make-sparse-keymap) t)))) - (define-key map (kbd key) def)))))) - (if after-init-time - (magit-maybe-define-global-key-bindings) - (add-hook 'after-init-hook #'magit-maybe-define-global-key-bindings t))) - -;;; Dispatch Popup - -;;;###autoload (autoload 'magit-dispatch "magit" nil t) -(transient-define-prefix magit-dispatch () - "Invoke a Magit command from a list of available commands." - :info-manual "(magit)Top" - ["Transient and dwim commands" - ;; → bound in magit-mode-map or magit-section-mode-map - ;; ↓ bound below - [("A" "Apply" magit-cherry-pick) - ;; a ↓ - ("b" "Branch" magit-branch) - ("B" "Bisect" magit-bisect) - ("c" "Commit" magit-commit) - ("C" "Clone" magit-clone) - ("d" "Diff" magit-diff) - ("D" "Diff (change)" magit-diff-refresh) - ("e" "Ediff (dwim)" magit-ediff-dwim) - ("E" "Ediff" magit-ediff) - ("f" "Fetch" magit-fetch) - ("F" "Pull" magit-pull) - ;; g ↓ - ;; G → magit-refresh-all - ("h" "Help" magit-info) - ("H" "Section info" magit-describe-section :if-derived magit-mode)] - [("i" "Ignore" magit-gitignore) - ("I" "Init" magit-init) - ("j" "Jump to section"magit-status-jump :if-mode magit-status-mode) - ("j" "Display status" magit-status-quick :if-not-mode magit-status-mode) - ("J" "Display buffer" magit-display-repository-buffer) - ;; k ↓ - ;; K → magit-file-untrack - ("l" "Log" magit-log) - ("L" "Log (change)" magit-log-refresh) - ("m" "Merge" magit-merge) - ("M" "Remote" magit-remote) - ;; n → magit-section-forward - ;; N reserved → forge-dispatch - ("o" "Submodule" magit-submodule) - ("O" "Subtree" magit-subtree) - ;; p → magit-section-backward - ("P" "Push" magit-push) - ;; q → magit-mode-bury-buffer - ("Q" "Command" magit-git-command)] - [("r" "Rebase" magit-rebase) - ;; R → magit-file-rename - ;; s ↓ - ;; S ↓ - ("t" "Tag" magit-tag) - ("T" "Note" magit-notes) - ;; u ↓ - ;; U ↓ - ;; v ↓ - ("V" "Revert" magit-revert) - ("w" "Apply patches" magit-am) - ("W" "Format patches" magit-patch) - ;; x → magit-reset-quickly - ("X" "Reset" magit-reset) - ("y" "Show Refs" magit-show-refs) - ("Y" "Cherries" magit-cherry) - ("z" "Stash" magit-stash) - ("Z" "Worktree" magit-worktree) - ("!" "Run" magit-run)]] - ["Applying changes" - :if-derived magit-mode - [("a" "Apply" magit-apply) - ("v" "Reverse" magit-reverse) - ("k" "Discard" magit-discard)] - [("s" "Stage" magit-stage) - ("u" "Unstage" magit-unstage)] - [("S" "Stage all" magit-stage-modified) - ("U" "Unstage all" magit-unstage-all)]] - ["Essential commands" - :if-derived magit-mode - [("g" " Refresh current buffer" magit-refresh) - ("q" " Bury current buffer" magit-mode-bury-buffer) - ("<tab>" " Toggle section at point" magit-section-toggle) - ("<return>" "Visit thing at point" magit-visit-thing)] - [("C-x m" "Show all key bindings" describe-mode) - ("C-x i" "Show Info manual" magit-info)]]) - -;;; Git Popup - -(defcustom magit-shell-command-verbose-prompt t - "Whether to show the working directory when reading a command. -This affects `magit-git-command', `magit-git-command-topdir', -`magit-shell-command', and `magit-shell-command-topdir'." - :package-version '(magit . "2.11.0") - :group 'magit-commands - :type 'boolean) - -(defvar magit-git-command-history nil) - -;;;###autoload (autoload 'magit-run "magit" nil t) -(transient-define-prefix magit-run () - "Run git or another command, or launch a graphical utility." - [["Run git subcommand" - ("!" "in repository root" magit-git-command-topdir) - ("p" "in working directory" magit-git-command)] - ["Run shell command" - ("s" "in repository root" magit-shell-command-topdir) - ("S" "in working directory" magit-shell-command)] - ["Launch" - ("k" "gitk" magit-run-gitk) - ("a" "gitk --all" magit-run-gitk-all) - ("b" "gitk --branches" magit-run-gitk-branches) - ("g" "git gui" magit-run-git-gui) - ("m" "git mergetool --gui" magit-git-mergetool)]]) - -;;;###autoload -(defun magit-git-command (command) - "Execute COMMAND asynchronously; display output. - -Interactively, prompt for COMMAND in the minibuffer. \"git \" is -used as initial input, but can be deleted to run another command. - -With a prefix argument COMMAND is run in the top-level directory -of the current working tree, otherwise in `default-directory'." - (interactive (list (magit-read-shell-command nil "git "))) - (magit--shell-command command)) - -;;;###autoload -(defun magit-git-command-topdir (command) - "Execute COMMAND asynchronously; display output. - -Interactively, prompt for COMMAND in the minibuffer. \"git \" is -used as initial input, but can be deleted to run another command. - -COMMAND is run in the top-level directory of the current -working tree." - (interactive (list (magit-read-shell-command t "git "))) - (magit--shell-command command (magit-toplevel))) - -;;;###autoload -(defun magit-shell-command (command) - "Execute COMMAND asynchronously; display output. - -Interactively, prompt for COMMAND in the minibuffer. With a -prefix argument COMMAND is run in the top-level directory of -the current working tree, otherwise in `default-directory'." - (interactive (list (magit-read-shell-command))) - (magit--shell-command command)) - -;;;###autoload -(defun magit-shell-command-topdir (command) - "Execute COMMAND asynchronously; display output. - -Interactively, prompt for COMMAND in the minibuffer. COMMAND -is run in the top-level directory of the current working tree." - (interactive (list (magit-read-shell-command t))) - (magit--shell-command command (magit-toplevel))) - -(defun magit--shell-command (command &optional directory) - (let ((default-directory (or directory default-directory))) - (with-environment-variables (("GIT_PAGER" "cat")) - (magit--with-connection-local-variables - (magit-with-editor - (magit-start-process shell-file-name nil - shell-command-switch command))))) - (magit-process-buffer)) - -(defun magit-read-shell-command (&optional toplevel initial-input) - (let ((default-directory - (if (or toplevel current-prefix-arg) - (or (magit-toplevel) - (magit--not-inside-repository-error)) - default-directory))) - (read-shell-command (if magit-shell-command-verbose-prompt - (format "Async shell command in %s: " - (abbreviate-file-name default-directory)) - "Async shell command: ") - initial-input 'magit-git-command-history))) - -;;; Shared Infix Arguments - -(transient-define-argument magit:--gpg-sign () - :description "Sign using gpg" - :class 'transient-option - :shortarg "-S" - :argument "--gpg-sign=" - :allow-empty t - :reader #'magit-read-gpg-signing-key) - -(defvar magit-gpg-secret-key-hist nil) - -(defun magit-read-gpg-secret-key - (prompt &optional initial-input history predicate default) - (require 'epa) - (let* ((keys (cl-mapcan - (lambda (cert) - (and (or (not predicate) - (funcall predicate cert)) - (let* ((key (car (epg-key-sub-key-list cert))) - (fpr (epg-sub-key-fingerprint key)) - (id (epg-sub-key-id key)) - (author - (and-let* ((id-obj - (car (epg-key-user-id-list cert)))) - (let ((id-str (epg-user-id-string id-obj))) - (if (stringp id-str) - id-str - (epg-decode-dn id-obj)))))) - (list - (propertize fpr 'display - (concat (substring fpr 0 (- (length id))) - (propertize id 'face 'highlight) - " " author)))))) - (epg-list-keys (epg-make-context epa-protocol) nil t))) - (choice (or (and (not current-prefix-arg) - (or (and (length= keys 1) (car keys)) - (and default (car (member default keys))))) - (completing-read prompt keys nil nil nil - history nil initial-input)))) - (set-text-properties 0 (length choice) nil choice) - choice)) - -(defun magit-read-gpg-signing-key (prompt &optional initial-input history) - (magit-read-gpg-secret-key - prompt initial-input history - (lambda (cert) - (cl-some (lambda (key) - (memq 'sign (epg-sub-key-capability key))) - (epg-key-sub-key-list cert))) - magit-openpgp-default-signing-key)) - -;;; Font-Lock Keywords - -(defconst magit-font-lock-keywords - (eval-when-compile - `((,(concat "(\\(magit-define-section-jumper\\)\\_>" - "[ \t'(]*" - "\\(\\(?:\\sw\\|\\s_\\)+\\)?") - (1 'font-lock-keyword-face) - (2 'font-lock-function-name-face nil t)) - (,(concat "(" (regexp-opt '("magit-insert-section" - "magit-section-case" - "magit-bind-match-strings" - "magit-with-temp-index" - "magit-with-blob" - "magit-with-toplevel") - t) - "\\_>") - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode magit-font-lock-keywords) - -;;; Version - -(defvar magit-version #'undefined - "The version of Magit that you're using. -Use the function by the same name instead of this variable.") - -;;;###autoload -(defun magit-version (&optional print-dest interactive nowarn) - "Return the version of Magit currently in use. - -If optional argument PRINT-DEST is non-nil, also print the used -versions of Magit, Transient, Git and Emacs to the output stream -selected by that argument. Interactively use the echo area, or -with a prefix argument use the current buffer. Additionally put -the output in the kill ring. -\n(fn &optional PRINT-DEST)" - (interactive (list (if current-prefix-arg (current-buffer) t) t)) - (let ((magit-git-global-arguments nil) - (toplib (or load-file-name buffer-file-name)) - debug) - (unless (and toplib - (member (file-name-nondirectory toplib) - '("magit.el" "magit.el.gz"))) - (let ((load-suffixes (reverse load-suffixes))) ; prefer .el than .elc - (setq toplib (locate-library "magit")))) - (setq toplib (and toplib (magit--chase-links toplib))) - (push toplib debug) - (when toplib - (let* ((topdir (file-name-directory toplib)) - (gitdir (expand-file-name - ".git" (file-name-directory - (directory-file-name topdir)))) - (static (locate-library "magit-version.el" nil (list topdir))) - (static (and static (magit--chase-links static)))) - (or (progn - (push 'repo debug) - (when (and (file-exists-p gitdir) - ;; It is a repo, but is it the Magit repo? - (file-exists-p - (expand-file-name "../lisp/magit.el" gitdir))) - (push t debug) - ;; Inside the repo the version file should only exist - ;; while running make. - (when (and static (not noninteractive)) - (ignore-errors (delete-file static))) - (setq magit-version - (let ((default-directory topdir)) - (magit-git-string "describe" - "--tags" "--dirty" "--always"))))) - (progn - (push 'static debug) - (when (and static (file-exists-p static)) - (push t debug) - (load-file static) - magit-version)) - (when (featurep 'package) - (push 'elpa debug) - (ignore-errors - (when-let ((version (cadr (assq 'magit package-alist)))) - (push t debug) - (setq magit-version - (and (fboundp 'package-desc-version) - (package-version-join - (package-desc-version version))))))) - (progn - (push 'dirname debug) - (let ((dirname (file-name-nondirectory - (directory-file-name topdir)))) - (when (string-match "\\`magit-\\([0-9].*\\)" dirname) - (setq magit-version (match-string 1 dirname))))) - ;; If all else fails, just report the commit hash. It's - ;; better than nothing and we cannot do better in the case - ;; of e.g., a shallow clone. - (progn - (push 'hash debug) - ;; Same check as above to see if it's really the Magit repo. - (when (and (file-exists-p gitdir) - (file-exists-p - (expand-file-name "../lisp/magit.el" gitdir))) - (setq magit-version - (let ((default-directory topdir)) - (magit-git-string "rev-parse" "HEAD")))))))) - (if (stringp magit-version) - (when print-dest - (let ((str (format - "Magit %s%s, Transient %s,%s Git %s, Emacs %s, %s" - (or magit-version "(unknown)") - (or (and (ignore-errors - (magit--version>= magit-version "2008")) - (ignore-errors - (require 'lisp-mnt) - (and (fboundp 'lm-header) - (format - " [>= %s]" - (with-temp-buffer - (insert-file-contents - (locate-library "magit.el" t)) - (lm-header "Package-Version")))))) - "") - (or (ignore-errors - (require 'lisp-mnt) - (and (fboundp 'lm-header) - (with-temp-buffer - (insert-file-contents - (locate-library "transient.el" t)) - (lm-header "Package-Version")))) - "(unknown)") - (let ((lib (locate-library "forge.el" t))) - (or (and lib - (format - " Forge %s," - (or (ignore-errors - (require 'lisp-mnt) - (with-temp-buffer - (insert-file-contents lib) - (and (fboundp 'lm-header) - (lm-header "Package-Version")))) - "(unknown)"))) - "")) - (magit--safe-git-version) - emacs-version - system-type))) - (when interactive - (kill-new str)) - (princ str print-dest))) - (setq debug (reverse debug)) - (setq magit-version 'error) - (when magit-version - (push magit-version debug)) - (unless (or nowarn (equal (getenv "CI") "true")) - (message "Cannot determine Magit's version %S" debug))) - magit-version)) - -;;; Startup Asserts - -(defun magit-startup-asserts () - (when-let ((val (getenv "GIT_DIR"))) - (setenv "GIT_DIR") - (message - "Magit unset $GIT_DIR (was %S). See %s" val - ;; Note: Pass URL as argument rather than embedding in the format - ;; string to prevent the single quote from being rendered - ;; according to `text-quoting-style'. - "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) - (when-let ((val (getenv "GIT_WORK_TREE"))) - (setenv "GIT_WORK_TREE") - (message - "Magit unset $GIT_WORK_TREE (was %S). See %s" val - ;; See comment above. - "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) - ;; Git isn't required while building Magit. - (unless (bound-and-true-p byte-compile-current-file) - (magit-git-version-assert)) - (when (version< emacs-version magit--minimal-emacs) - (display-warning 'magit (format "\ -Magit requires Emacs >= %s, you are using %s. - -If this comes as a surprise to you, because you do actually have -a newer version installed, then that probably means that the -older version happens to appear earlier on the `$PATH'. If you -always start Emacs from a shell, then that can be fixed in the -shell's init file. If you start Emacs by clicking on an icon, -or using some sort of application launcher, then you probably -have to adjust the environment as seen by graphical interface. -For X11 something like ~/.xinitrc should work.\n" - magit--minimal-emacs emacs-version) - :error))) - -;;; Loading Libraries - -(provide 'magit) - -(cl-eval-when (load eval) - (require 'magit-status) - (require 'magit-refs) - (require 'magit-files) - (require 'magit-reset) - (require 'magit-branch) - (require 'magit-merge) - (require 'magit-tag) - (require 'magit-worktree) - (require 'magit-notes) - (require 'magit-sequence) - (require 'magit-commit) - (require 'magit-remote) - (require 'magit-clone) - (require 'magit-fetch) - (require 'magit-pull) - (require 'magit-push) - (require 'magit-bisect) - (require 'magit-stash) - (require 'magit-blame) - (require 'magit-submodule) - (unless (load "magit-autoloads" t t) - (require 'magit-patch) - (require 'magit-subtree) - (require 'magit-ediff) - (require 'magit-gitignore) - (require 'magit-sparse-checkout) - (require 'magit-extras) - (require 'git-rebase) - (require 'magit-bookmark))) - -(with-eval-after-load 'bookmark - (require 'magit-bookmark)) - -(unless (bound-and-true-p byte-compile-current-file) - (if after-init-time - (progn (magit-startup-asserts) - (magit-version nil nil t)) - (add-hook 'after-init-hook #'magit-startup-asserts t) - (add-hook 'after-init-hook #'magit-version t))) - -;;; magit.el ends here diff --git a/emacs/elpa/magit-20241106.1441/AUTHORS.md b/emacs/elpa/magit-20241116.1557/AUTHORS.md diff --git a/emacs/elpa/magit-20241106.1441/LICENSE b/emacs/elpa/magit-20241116.1557/LICENSE diff --git a/emacs/elpa/magit-20241106.1441/dir b/emacs/elpa/magit-20241116.1557/dir diff --git a/emacs/elpa/magit-20241106.1441/git-commit.el b/emacs/elpa/magit-20241116.1557/git-commit.el diff --git a/emacs/elpa/magit-20241116.1557/git-commit.elc b/emacs/elpa/magit-20241116.1557/git-commit.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/git-rebase.el b/emacs/elpa/magit-20241116.1557/git-rebase.el diff --git a/emacs/elpa/magit-20241106.1441/git-rebase.elc b/emacs/elpa/magit-20241116.1557/git-rebase.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-apply.el b/emacs/elpa/magit-20241116.1557/magit-apply.el diff --git a/emacs/elpa/magit-20241106.1441/magit-apply.elc b/emacs/elpa/magit-20241116.1557/magit-apply.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-autoloads.el b/emacs/elpa/magit-20241116.1557/magit-autoloads.el diff --git a/emacs/elpa/magit-20241106.1441/magit-autorevert.el b/emacs/elpa/magit-20241116.1557/magit-autorevert.el diff --git a/emacs/elpa/magit-20241106.1441/magit-autorevert.elc b/emacs/elpa/magit-20241116.1557/magit-autorevert.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-base.el b/emacs/elpa/magit-20241116.1557/magit-base.el diff --git a/emacs/elpa/magit-20241106.1441/magit-base.elc b/emacs/elpa/magit-20241116.1557/magit-base.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-bisect.el b/emacs/elpa/magit-20241116.1557/magit-bisect.el diff --git a/emacs/elpa/magit-20241106.1441/magit-bisect.elc b/emacs/elpa/magit-20241116.1557/magit-bisect.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-blame.el b/emacs/elpa/magit-20241116.1557/magit-blame.el diff --git a/emacs/elpa/magit-20241106.1441/magit-blame.elc b/emacs/elpa/magit-20241116.1557/magit-blame.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-bookmark.el b/emacs/elpa/magit-20241116.1557/magit-bookmark.el diff --git a/emacs/elpa/magit-20241106.1441/magit-bookmark.elc b/emacs/elpa/magit-20241116.1557/magit-bookmark.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-branch.el b/emacs/elpa/magit-20241116.1557/magit-branch.el diff --git a/emacs/elpa/magit-20241106.1441/magit-branch.elc b/emacs/elpa/magit-20241116.1557/magit-branch.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-bundle.el b/emacs/elpa/magit-20241116.1557/magit-bundle.el diff --git a/emacs/elpa/magit-20241106.1441/magit-bundle.elc b/emacs/elpa/magit-20241116.1557/magit-bundle.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-clone.el b/emacs/elpa/magit-20241116.1557/magit-clone.el diff --git a/emacs/elpa/magit-20241106.1441/magit-clone.elc b/emacs/elpa/magit-20241116.1557/magit-clone.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-commit.el b/emacs/elpa/magit-20241116.1557/magit-commit.el diff --git a/emacs/elpa/magit-20241106.1441/magit-commit.elc b/emacs/elpa/magit-20241116.1557/magit-commit.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-core.el b/emacs/elpa/magit-20241116.1557/magit-core.el diff --git a/emacs/elpa/magit-20241106.1441/magit-core.elc b/emacs/elpa/magit-20241116.1557/magit-core.elc Binary files differ. diff --git a/emacs/elpa/magit-20241116.1557/magit-diff.el b/emacs/elpa/magit-20241116.1557/magit-diff.el @@ -0,0 +1,3576 @@ +;;; magit-diff.el --- Inspect Git diffs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2024 The Magit Project Contributors + +;; Author: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> +;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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. +;; +;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements support for looking at Git diffs and +;; commits. + +;;; Code: + +(require 'magit-core) +(require 'git-commit) + +(eval-when-compile (require 'ansi-color)) +(require 'diff-mode) +(require 'image) +(require 'smerge-mode) + +;; For `magit-diff-popup' +(declare-function magit-stash-show "magit-stash" (stash &optional args files)) +;; For `magit-diff-visit-file' +(declare-function magit-find-file-noselect "magit-files" (rev file)) +(declare-function magit-status-setup-buffer "magit-status" (&optional directory)) +;; For `magit-diff-while-committing' +(declare-function magit-commit-diff-1 "magit-commit" ()) +(declare-function magit-commit-message-buffer "magit-commit" ()) +;; For `magit-insert-revision-gravatar' +(defvar gravatar-size) +;; For `magit-show-commit' and `magit-diff-show-or-scroll' +(declare-function magit-current-blame-chunk "magit-blame" (&optional type noerror)) +(declare-function magit-blame-mode "magit-blame" (&optional arg)) +(defvar magit-blame-mode) +;; For `magit-diff-show-or-scroll' +(declare-function git-rebase-current-line "git-rebase" ()) +;; For `magit-diff-unmerged' +(declare-function magit-merge-in-progress-p "magit-merge" ()) +(declare-function magit--merge-range "magit-merge" (&optional head)) +;; For `magit-diff--dwim' +(declare-function forge--pullreq-range "ext:forge-pullreq" + (pullreq &optional endpoints)) +(declare-function forge--pullreq-ref "ext:forge-pullreq" (pullreq)) +;; For `magit-diff-wash-diff' +(declare-function ansi-color-apply-on-region "ansi-color") +;; For `magit-diff-wash-submodule' +(declare-function magit-log-wash-log "magit-log" (style args)) +;; For keymaps and menus +(declare-function magit-apply "magit-apply" (&rest args)) +(declare-function magit-stage "magit-apply" (&optional indent)) +(declare-function magit-unstage "magit-apply" ()) +(declare-function magit-discard "magit-apply" ()) +(declare-function magit-reverse "magit-apply" (&rest args)) +(declare-function magit-file-rename "magit-files" (file newname)) +(declare-function magit-file-untrack "magit-files" (files &optional force)) +(declare-function magit-commit-add-log "magit-commit" ()) +(declare-function magit-diff-trace-definition "magit-log" ()) +(declare-function magit-patch-save "magit-patch" (files &optional arg)) +(declare-function magit-do-async-shell-command "magit-extras" (file)) +(declare-function magit-add-change-log-entry "magit-extras" + (&optional whoami file-name other-window)) +(declare-function magit-add-change-log-entry-other-window "magit-extras" + (&optional whoami file-name)) +(declare-function magit-diff-edit-hunk-commit "magit-extras" (file)) +(declare-function magit-smerge-keep-current "magit-apply" ()) +(declare-function magit-smerge-keep-all "magit-apply" ()) +(declare-function magit-smerge-keep-upper "magit-apply" ()) +(declare-function magit-smerge-keep-base "magit-apply" ()) +(declare-function magit-smerge-keep-lower "magit-apply" ()) + +(eval-when-compile + (cl-pushnew 'orig-rev eieio--known-slot-names) + (cl-pushnew 'action-type eieio--known-slot-names) + (cl-pushnew 'target eieio--known-slot-names)) + +;;; Options +;;;; Diff Mode + +(defgroup magit-diff nil + "Inspect and manipulate Git diffs." + :link '(info-link "(magit)Diffing") + :group 'magit-commands + :group 'magit-modes) + +(defcustom magit-diff-mode-hook nil + "Hook run after entering Magit-Diff mode." + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-sections-hook + '(magit-insert-diff + magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-diff-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-expansion-threshold 60 + "After how many seconds not to expand anymore diffs. + +Except in status buffers, diffs usually start out fully expanded. +Because that can take a long time, all diffs that haven't been +fontified during a refresh before the threshold defined here are +instead displayed with their bodies collapsed. + +Note that this can cause sections that were previously expanded +to be collapsed. So you should not pick a very low value here. + +The hook function `magit-diff-expansion-threshold' has to be a +member of `magit-section-set-visibility-hook' for this option +to have any effect." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'float) + +(defcustom magit-diff-highlight-hunk-body t + "Whether to highlight bodies of selected hunk sections. +This only has an effect if `magit-diff-highlight' is a +member of `magit-section-highlight-hook', which see." + :package-version '(magit . "2.1.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-highlight-hunk-region-functions + '(magit-diff-highlight-hunk-region-dim-outside + magit-diff-highlight-hunk-region-using-overlays) + "The functions used to highlight the hunk-internal region. + +`magit-diff-highlight-hunk-region-dim-outside' overlays the outside +of the hunk internal selection with a face that causes the added and +removed lines to have the same background color as context lines. +This function should not be removed from the value of this option. + +`magit-diff-highlight-hunk-region-using-overlays' and +`magit-diff-highlight-hunk-region-using-underline' emphasize the +region by placing delimiting horizontal lines before and after it. +The underline variant was implemented because Eli said that is +how we should do it. However the overlay variant actually works +better. Also see https://github.com/magit/magit/issues/2758. + +Instead of, or in addition to, using delimiting horizontal lines, +to emphasize the boundaries, you may wish to emphasize the text +itself, using `magit-diff-highlight-hunk-region-using-face'. + +In terminal frames it's not possible to draw lines as the overlay +and underline variants normally do, so there they fall back to +calling the face function instead." + :package-version '(magit . "2.9.0") + :set-after '(magit-diff-show-lines-boundaries) + :group 'magit-diff + :type 'hook + :options '(magit-diff-highlight-hunk-region-dim-outside + magit-diff-highlight-hunk-region-using-underline + magit-diff-highlight-hunk-region-using-overlays + magit-diff-highlight-hunk-region-using-face)) + +(defcustom magit-diff-unmarked-lines-keep-foreground t + "Whether `magit-diff-highlight-hunk-region-dim-outside' preserves foreground. +When this is set to nil, then that function only adjusts the +foreground color but added and removed lines outside the region +keep their distinct foreground colors." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-refine-hunk nil + "Whether to show word-granularity differences within diff hunks. + +nil Never show fine differences. +t Show fine differences for the current diff hunk only. +`all' Show fine differences for all displayed diff hunks." + :group 'magit-diff + :safe (lambda (val) (memq val '(nil t all))) + :type '(choice (const :tag "Never" nil) + (const :tag "Current" t) + (const :tag "All" all))) + +(defcustom magit-diff-refine-ignore-whitespace smerge-refine-ignore-whitespace + "Whether to ignore whitespace changes in word-granularity differences." + :package-version '(magit . "3.0.0") + :set-after '(smerge-refine-ignore-whitespace) + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(put 'magit-diff-refine-hunk 'permanent-local t) + +(defcustom magit-diff-adjust-tab-width nil + "Whether to adjust the width of tabs in diffs. + +Determining the correct width can be expensive if it requires +opening large and/or many files, so the widths are cached in +the variable `magit-diff--tab-width-cache'. Set that to nil +to invalidate the cache. + +nil Never adjust tab width. Use `tab-width's value from + the Magit buffer itself instead. + +t If the corresponding file-visiting buffer exits, then + use `tab-width's value from that buffer. Doing this is + cheap, so this value is used even if a corresponding + cache entry exists. + +`always' If there is no such buffer, then temporarily visit the + file to determine the value. + +NUMBER Like `always', but don't visit files larger than NUMBER + bytes." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type '(choice (const :tag "Never" nil) + (const :tag "If file-visiting buffer exists" t) + (integer :tag "If file isn't larger than N bytes") + (const :tag "Always" always))) + +(defcustom magit-diff-paint-whitespace t + "Specify where to highlight whitespace errors. + +nil Never highlight whitespace errors. +t Highlight whitespace errors everywhere. +`uncommitted' Only highlight whitespace errors in diffs + showing uncommitted changes. + +For backward compatibility `status' is treated as a synonym +for `uncommitted'. + +The option `magit-diff-paint-whitespace-lines' controls for +what lines (added/remove/context) errors are highlighted. + +The options `magit-diff-highlight-trailing' and +`magit-diff-highlight-indentation' control what kind of +whitespace errors are highlighted." + :group 'magit-diff + :safe (lambda (val) (memq val '(t nil uncommitted status))) + :type '(choice (const :tag "In all diffs" t) + (const :tag "Only in uncommitted changes" uncommitted) + (const :tag "Never" nil))) + +(defcustom magit-diff-paint-whitespace-lines t + "Specify in what kind of lines to highlight whitespace errors. + +t Highlight only in added lines. +`both' Highlight in added and removed lines. +`all' Highlight in added, removed and context lines." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :safe (lambda (val) (memq val '(t both all))) + :type '(choice (const :tag "in added lines" t) + (const :tag "in added and removed lines" both) + (const :tag "in added, removed and context lines" all))) + +(defcustom magit-diff-highlight-trailing t + "Whether to highlight whitespace at the end of a line in diffs. +Used only when `magit-diff-paint-whitespace' is non-nil." + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(defcustom magit-diff-highlight-indentation nil + "Highlight the \"wrong\" indentation style. +Used only when `magit-diff-paint-whitespace' is non-nil. + +The value is an alist of the form ((REGEXP . INDENT)...). The +path to the current repository is matched against each element +in reverse order. Therefore if a REGEXP matches, then earlier +elements are not tried. + +If the used INDENT is `tabs', highlight indentation with tabs. +If INDENT is an integer, highlight indentation with at least +that many spaces. Otherwise, highlight neither." + :group 'magit-diff + :type `(repeat (cons (string :tag "Directory regexp") + (choice (const :tag "Tabs" tabs) + (integer :tag "Spaces" :value ,tab-width) + (const :tag "Neither" nil))))) + +(defcustom magit-diff-hide-trailing-cr-characters + (and (memq system-type '(ms-dos windows-nt)) t) + "Whether to hide ^M characters at the end of a line in diffs." + :package-version '(magit . "2.6.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-highlight-keywords t + "Whether to highlight bracketed keywords in commit messages." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-extra-stat-arguments nil + "Additional arguments to be used alongside `--stat'. + +A list of zero or more arguments or a function that takes no +argument and returns such a list. These arguments are allowed +here: `--stat-width', `--stat-name-width', `--stat-graph-width' +and `--compact-summary'. See the git-diff(1) manpage." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :type '(radio (function-item magit-diff-use-window-width-as-stat-width) + function + (list string) + (const :tag "None" nil))) + +;;;; File Diff + +(defcustom magit-diff-buffer-file-locked t + "Whether `magit-diff-buffer-file' uses a dedicated buffer." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :group 'magit-diff + :type 'boolean) + +;;;; Revision Mode + +(defgroup magit-revision nil + "Inspect and manipulate Git commits." + :link '(info-link "(magit)Revision Buffer") + :group 'magit-modes) + +(defcustom magit-revision-mode-hook + '(bug-reference-mode + goto-address-mode) + "Hook run after entering Magit-Revision mode." + :group 'magit-revision + :type 'hook + :options '(bug-reference-mode + goto-address-mode)) + +(defcustom magit-revision-sections-hook + '(magit-insert-revision-tag + magit-insert-revision-headers + magit-insert-revision-message + magit-insert-revision-notes + magit-insert-revision-diff + magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-revision-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'hook) + +(defcustom magit-revision-headers-format "\ +Author: %aN <%aE> +AuthorDate: %ad +Commit: %cN <%cE> +CommitDate: %cd +" + "Format string used to insert headers in revision buffers. + +All headers in revision buffers are inserted by the section +inserter `magit-insert-revision-headers'. Some of the headers +are created by calling `git show --format=FORMAT' where FORMAT +is the format specified here. Other headers are hard coded or +subject to option `magit-revision-insert-related-refs'." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'string) + +(defcustom magit-revision-insert-related-refs t + "Whether to show related branches in revision buffers + +`nil' Don't show any related branches. +`t' Show related local branches. +`all' Show related local and remote branches. +`mixed' Show all containing branches and local merged branches. + +See user option `magit-revision-insert-related-refs-display-alist' +to hide specific sets of related branches." + :package-version '(magit . "2.1.0") + :group 'magit-revision + :type '(choice (const :tag "don't" nil) + (const :tag "local only" t) + (const :tag "all related" all) + (const :tag "all containing, local merged" mixed))) + +(defcustom magit-revision-insert-related-refs-display-alist nil + "How `magit-insert-revision-headers' displays related branch types. + +This is an alist, with recognised keys being the symbols +`parents', `merged', `contained', `follows', and `precedes'; +and the supported values for each key being: + +`nil' Hide these related branches. +`t' Show these related branches. + +Keys which are not present in the alist have an implicit value `t' +\(so the default alist value of nil means all related branch types +will be shown.) + +The types to be shown are additionally subject to user option +`magit-revision-insert-related-refs'." + :package-version '(magit . "3.3.1") + :group 'magit-revision + :type '(alist :key-type (symbol :tag "Type of related branch") + :value-type (boolean :tag "Display")) + :options (mapcar (lambda (sym) + `(,sym (choice (const :tag "Hide" nil) + (const :tag "Show" t)))) + '(parents merged contained follows precedes))) + +(defcustom magit-revision-use-hash-sections 'quicker + "Whether to turn hashes inside the commit message into sections. + +If non-nil, then hashes inside the commit message are turned into +`commit' sections. There is a trade off to be made between +performance and reliability: + +- `slow' calls git for every word to be absolutely sure. +- `quick' skips words less than seven characters long. +- `quicker' additionally skips words that don't contain a number. +- `quickest' uses all words that are at least seven characters + long and which contain at least one number as well as at least + one letter. + +If nil, then no hashes are turned into sections, but you can +still visit the commit at point using \"RET\"." + :package-version '(magit . "2.12.0") + :group 'magit-revision + :type '(choice (const :tag "Use sections, quickest" quickest) + (const :tag "Use sections, quicker" quicker) + (const :tag "Use sections, quick" quick) + (const :tag "Use sections, slow" slow) + (const :tag "Don't use sections" nil))) + +(defcustom magit-revision-show-gravatars nil + "Whether to show gravatar images in revision buffers. + +If nil, then don't insert any gravatar images. If t, then insert +both images. If `author' or `committer', then insert only the +respective image. + +If you have customized the option `magit-revision-header-format' +and want to insert the images then you might also have to specify +where to do so. In that case the value has to be a cons-cell of +two regular expressions. The car specifies where to insert the +author's image. The top half of the image is inserted right +after the matched text, the bottom half on the next line in the +same column. The cdr specifies where to insert the committer's +image, accordingly. Either the car or the cdr may be nil." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type '(choice + (const :tag "Don't show gravatars" nil) + (const :tag "Show gravatars" t) + (const :tag "Show author gravatar" author) + (const :tag "Show committer gravatar" committer) + (cons :tag "Show gravatars using custom regexps" + (choice (const :tag "No author image" nil) + (regexp :tag "Author regexp" "^Author: ")) + (choice (const :tag "No committer image" nil) + (regexp :tag "Committer regexp" "^Commit: "))))) + +(defcustom magit-revision-fill-summary-line nil + "Whether to fill excessively long summary lines. + +If this is an integer, then the summary line is filled if it is +longer than either the limit specified here or `window-width'. + +You may want to only set this locally in \".dir-locals-2.el\" for +repositories known to contain bad commit messages. + +The body of the message is left alone because (a) most people who +write excessively long summary lines usually don't add a body and +\(b) even people who have the decency to wrap their lines may have +a good reason to include a long line in the body sometimes." + :package-version '(magit . "2.90.0") + :group 'magit-revision + :type '(choice (const :tag "Don't fill" nil) + (integer :tag "Fill if longer than"))) + +(defcustom magit-revision-filter-files-on-follow nil + "Whether to honor file filter if log arguments include --follow. + +When a commit is displayed from a log buffer, the resulting +revision buffer usually shares the log's file arguments, +restricting the diff to those files. However, there's a +complication when the log arguments include --follow: if the log +follows a file across a rename event, keeping the file +restriction would mean showing an empty diff in revision buffers +for commits before the rename event. + +When this option is nil, the revision buffer ignores the log's +filter if the log arguments include --follow. If non-nil, the +log's file filter is always honored." + :package-version '(magit . "3.0.0") + :group 'magit-revision + :type 'boolean) + +;;;; Visit Commands + +(defcustom magit-diff-visit-previous-blob t + "Whether `magit-diff-visit-file' may visit the previous blob. + +When this is t and point is on a removed line in a diff for a +committed change, then `magit-diff-visit-file' visits the blob +from the last revision which still had that line. + +Currently this is only supported for committed changes, for +staged and unstaged changes `magit-diff-visit-file' always +visits the file in the working tree." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-visit-avoid-head-blob nil + "Whether `magit-diff-visit-file' avoids visiting a blob from `HEAD'. + +By default `magit-diff-visit-file' always visits the blob that +added the current line, while `magit-diff-visit-worktree-file' +visits the respective file in the working tree. For the `HEAD' +commit, the former command used to visit the worktree file too, +but that made it impossible to visit a blob from `HEAD'. + +When point is on a removed line and that change has not been +committed yet, then `magit-diff-visit-file' now visits the last +blob that still had that line, which is a blob from `HEAD'. +Previously this function used to visit the worktree file not +only for added lines but also for such removed lines. + +If you prefer the old behaviors, then set this to t." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :type 'boolean) + +;;; Faces + +(defface magit-diff-file-heading + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :weight bold)) + "Face for diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-highlight + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-section-highlight)) + "Face for current diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-selection + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-file-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-file-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff file headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey90" + :foreground "grey20") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey25" + :foreground "grey95")) + "Face for diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey80" + :foreground "grey20") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey35" + :foreground "grey95")) + "Face for current diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-selection + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-region + `((t :inherit bold + ,@(and (>= emacs-major-version 27) + (list :extend (ignore-errors (face-attribute 'region :extend)))))) + "Face used by `magit-diff-highlight-hunk-region-using-face'. + +This face is overlaid over text that uses other hunk faces, +and those normally set the foreground and background colors. +The `:foreground' and especially the `:background' properties +should be avoided here. Setting the latter would cause the +loss of information. Good properties to set here are `:weight' +and `:slant'." + :group 'magit-faces) + +(defface magit-diff-revision-summary + '((t :inherit magit-diff-hunk-heading)) + "Face for commit message summaries." + :group 'magit-faces) + +(defface magit-diff-revision-summary-highlight + '((t :inherit magit-diff-hunk-heading-highlight)) + "Face for highlighted commit message summaries." + :group 'magit-faces) + +(defface magit-diff-lines-heading + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :background "LightSalmon3") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :inherit magit-diff-hunk-heading-highlight + :foreground "grey80" + :background "salmon4")) + "Face for diff hunk heading when lines are marked." + :group 'magit-faces) + +(defface magit-diff-lines-boundary + `((t ,@(and (>= emacs-major-version 27) '(:extend t)) ; !important + :inherit magit-diff-lines-heading)) + "Face for boundary of marked lines in diff hunk." + :group 'magit-faces) + +(defface magit-diff-conflict-heading + '((t :inherit magit-diff-hunk-heading)) + "Face for conflict markers." + :group 'magit-faces) + +(defface magit-diff-added + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ddffdd" + :foreground "#22aa22") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#335533" + :foreground "#ddffdd")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ffdddd" + :foreground "#aa2222") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#553333" + :foreground "#ffdddd")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our + '((t :inherit magit-diff-removed)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#ffffcc" + :foreground "#aaaa11") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#555522" + :foreground "#ffffcc")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their + '((t :inherit magit-diff-added)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "grey50") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :foreground "grey70")) + "Face for lines in a diff that are unchanged." + :group 'magit-faces) + +(defface magit-diff-added-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#cceecc" + :foreground "#22aa22") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#336633" + :foreground "#cceecc")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#eecccc" + :foreground "#aa2222") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#663333" + :foreground "#eecccc")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our-highlight + '((t :inherit magit-diff-removed-highlight)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#eeeebb" + :foreground "#aaaa11") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#666622" + :foreground "#eeeebb")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their-highlight + '((t :inherit magit-diff-added-highlight)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context-highlight + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey95" + :foreground "grey50") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "grey20" + :foreground "grey70")) + "Face for lines in the current context in a diff." + :group 'magit-faces) + +(defface magit-diff-whitespace-warning + '((t :inherit trailing-whitespace)) + "Face for highlighting whitespace errors added lines." + :group 'magit-faces) + +(defface magit-diffstat-added + '((((class color) (background light)) :foreground "#22aa22") + (((class color) (background dark)) :foreground "#448844")) + "Face for plus sign in diffstat." + :group 'magit-faces) + +(defface magit-diffstat-removed + '((((class color) (background light)) :foreground "#aa2222") + (((class color) (background dark)) :foreground "#aa4444")) + "Face for minus sign in diffstat." + :group 'magit-faces) + +;;; Arguments +;;;; Prefix Classes + +(defclass magit-diff-prefix (transient-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform 'magit-diff-mode))) + +(defclass magit-diff-refresh-prefix (magit-diff-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform nil))) + +;;;; Prefix Methods + +(cl-defmethod transient-init-value ((obj magit-diff-prefix)) + (pcase-let ((`(,args ,files) + (magit-diff--get-value 'magit-diff-mode + magit-prefix-use-buffer-arguments))) + (when-let ((not (eq transient-current-command 'magit-dispatch)) + (file (magit-file-relative-name))) + (setq files (list file))) + (oset obj value (if files `(("--" ,@files) ,args) args)))) + +(cl-defmethod transient-init-value ((obj magit-diff-refresh-prefix)) + (oset obj value (if magit-buffer-diff-files + `(("--" ,@magit-buffer-diff-files) + ,magit-buffer-diff-args) + magit-buffer-diff-args))) + +(cl-defmethod transient-set-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj)) + +(cl-defmethod transient-save-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj 'save)) + +;;;; Argument Access + +(defun magit-diff-arguments (&optional mode) + "Return the current diff arguments." + (if (memq transient-current-command '(magit-diff magit-diff-refresh)) + (magit--transient-args-and-files) + (magit-diff--get-value (or mode 'magit-diff-mode)))) + +(defun magit-diff--get-value (mode &optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args files) + (cond + ((and (memq use-buffer-args '(always selected current)) + (eq major-mode mode)) + (setq args magit-buffer-diff-args) + (setq files magit-buffer-diff-files)) + ((when-let (((memq use-buffer-args '(always selected))) + (buffer (magit-get-mode-buffer + mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-diff-args buffer)) + (setq files (buffer-local-value 'magit-buffer-diff-files buffer)) + t)) + ((plist-member (symbol-plist mode) 'magit-diff-current-arguments) + (setq args (get mode 'magit-diff-current-arguments))) + ((when-let ((elt (assq (intern (format "magit-diff:%s" mode)) + transient-values))) + (setq args (cdr elt)) + t)) + (t + (setq args (get mode 'magit-diff-default-arguments)))) + (list args files))) + +(defun magit-diff--set-value (obj &optional save) + (pcase-let* ((obj (oref obj prototype)) + (mode (or (oref obj major-mode) major-mode)) + (key (intern (format "magit-diff:%s" mode))) + (`(,args ,files) (magit--transient-args-and-files))) + (put mode 'magit-diff-current-arguments args) + (when save + (setf (alist-get key transient-values) args) + (transient-save-values)) + (transient--history-push obj) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files) + (magit-refresh))) + +;;; Commands +;;;; Prefix Commands + +;;;###autoload (autoload 'magit-diff "magit-diff" nil t) +(transient-define-prefix magit-diff () + "Show changes between different versions." + :man-page "git-diff" + :class 'magit-diff-prefix + ["Limit arguments" + (magit:--) + (magit-diff:--ignore-submodules) + ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) + (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] + ["Context arguments" + (magit-diff:-U) + ("-W" "Show surrounding functions" ("-W" "--function-context"))] + ["Tune arguments" + (magit-diff:--diff-algorithm) + (magit-diff:--diff-merges) + (magit-diff:-M) + (magit-diff:-C) + (5 "-R" "Reverse sides" "-R") + (5 magit-diff:--color-moved) + (5 magit-diff:--color-moved-ws) + ("-x" "Disallow external diff drivers" "--no-ext-diff") + ("-s" "Show stats" "--stat") + ("=g" "Show signature" "--show-signature")] + ["Actions" + [("d" "Dwim" magit-diff-dwim) + ("r" "Diff range" magit-diff-range) + ("p" "Diff paths" magit-diff-paths)] + [("u" "Diff unstaged" magit-diff-unstaged) + ("s" "Diff staged" magit-diff-staged) + ("w" "Diff worktree" magit-diff-working-tree)] + [("c" "Show commit" magit-show-commit) + ("t" "Show stash" magit-stash-show)]]) + +;;;###autoload (autoload 'magit-diff-refresh "magit-diff" nil t) +(transient-define-prefix magit-diff-refresh () + "Change the arguments used for the diff(s) in the current buffer." + :man-page "git-diff" + :class 'magit-diff-refresh-prefix + ["Limit arguments" + (magit:--) + (magit-diff:--ignore-submodules) + ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) + (5 "-D" "Omit preimage for deletes" ("-D" "--irreversible-delete"))] + ["Context arguments" + (magit-diff:-U) + ("-W" "Show surrounding functions" ("-W" "--function-context"))] + ["Tune arguments" + (magit-diff:--diff-algorithm) + (magit-diff:--diff-merges) + (magit-diff:-M) + (magit-diff:-C) + (5 "-R" "Reverse sides" "-R" + :if-derived magit-diff-mode) + (5 magit-diff:--color-moved) + (5 magit-diff:--color-moved-ws) + ("-x" "Disallow external diff drivers" "--no-ext-diff") + ("-s" "Show stats" "--stat" + :if-derived magit-diff-mode) + ("=g" "Show signature" "--show-signature" + :if-derived magit-diff-mode)] + [["Refresh" + ("g" "buffer" magit-diff-refresh) + ("s" "buffer and set defaults" transient-set-and-exit) + ("w" "buffer and save defaults" transient-save-and-exit)] + ["Toggle" + ("t" "hunk refinement" magit-diff-toggle-refine-hunk) + ("F" "file filter" magit-diff-toggle-file-filter) + ("b" "buffer lock" magit-toggle-buffer-lock + :if-mode (magit-diff-mode magit-revision-mode magit-stash-mode))] + [:if-mode magit-diff-mode + :description "Do" + ("r" "switch range type" magit-diff-switch-range-type) + ("f" "flip revisions" magit-diff-flip-revs)]] + (interactive) + (when (derived-mode-p 'magit-merge-preview-mode) + (user-error "Cannot use %s in %s" this-command major-mode)) + (if (not (eq transient-current-command 'magit-diff-refresh)) + (transient-setup 'magit-diff-refresh) + (pcase-let ((`(,args ,files) (magit-diff-arguments))) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files)) + (magit-refresh))) + +;;;; Infix Commands + +(transient-define-argument magit:-- () + :description "Limit to files" + :class 'transient-files + :key "--" + :argument "--" + :prompt "Limit to file,s: " + :reader #'magit-read-files + :multi-value t) + +(defun magit-read-files (prompt initial-input history &optional list-fn) + (magit-with-toplevel + (magit-completing-read-multiple prompt + (funcall (or list-fn #'magit-list-files)) + nil nil + (or initial-input (magit-file-at-point)) + history))) + +(transient-define-argument magit-diff:-U () + :description "Context lines" + :class 'transient-option + :argument "-U" + :reader #'transient-read-number-N0) + +(transient-define-argument magit-diff:-M () + :description "Detect renames" + :class 'transient-option + :argument "-M" + :allow-empty t + :reader #'transient-read-number-N+) + +(transient-define-argument magit-diff:-C () + :description "Detect copies" + :class 'transient-option + :argument "-C" + :allow-empty t + :reader #'transient-read-number-N+) + +(transient-define-argument magit-diff:--diff-algorithm () + :description "Diff algorithm" + :class 'transient-option + :key "-A" + :argument "--diff-algorithm=" + :reader #'magit-diff-select-algorithm + :always-read t) + +(defun magit-diff-select-algorithm (&rest _ignore) + (magit-read-char-case nil t + (?u "[u]nspecified" nil) + (?d "[d]efault" "default") + (?m "[m]inimal" "minimal") + (?p "[p]atience" "patience") + (?h "[h]istogram" "histogram"))) + +(transient-define-argument magit-diff:--diff-merges () + :description "Diff merges" + :class 'transient-option + :key "-X" + :argument "--diff-merges=" + :reader #'magit-diff-select-merges + :always-read t) + +(defun magit-diff-select-merges (&rest _ignore) + (magit-read-char-case nil t + (?u "[u]nspecified" nil) + (?o "[o]ff" "off") + (?f "[f]irst-parent" "first-parent") + (?c "[c]ombined" "combined") + (?d "[d]ense-combined" "dense-combined"))) + +(transient-define-argument magit-diff:--ignore-submodules () + :description "Ignore submodules" + :class 'transient-option + :key "-i" + :argument "--ignore-submodules=" + :reader #'magit-diff-select-ignore-submodules) + +(defun magit-diff-select-ignore-submodules (&rest _ignored) + (magit-read-char-case "Ignore submodules " t + (?u "[u]ntracked" "untracked") + (?d "[d]irty" "dirty") + (?a "[a]ll" "all"))) + +(transient-define-argument magit-diff:--color-moved () + :description "Color moved lines" + :class 'transient-option + :key "-m" + :argument "--color-moved=" + :reader #'magit-diff-select-color-moved-mode) + +(defun magit-diff-select-color-moved-mode (&rest _ignore) + (magit-read-char-case "Color moved " t + (?d "[d]efault" "default") + (?p "[p]lain" "plain") + (?b "[b]locks" "blocks") + (?z "[z]ebra" "zebra") + (?Z "[Z] dimmed-zebra" "dimmed-zebra"))) + +(transient-define-argument magit-diff:--color-moved-ws () + :description "Whitespace treatment for --color-moved" + :class 'transient-option + :key "=w" + :argument "--color-moved-ws=" + :reader #'magit-diff-select-color-moved-ws-mode) + +(defun magit-diff-select-color-moved-ws-mode (&rest _ignore) + (magit-read-char-case "Ignore whitespace " t + (?i "[i]ndentation" "allow-indentation-change") + (?e "[e]nd of line" "ignore-space-at-eol") + (?s "[s]pace change" "ignore-space-change") + (?a "[a]ll space" "ignore-all-space") + (?n "[n]o" "no"))) + +;;;; Setup Commands + +;;;###autoload +(defun magit-diff-dwim (&optional args files) + "Show changes for the thing at point." + (interactive (magit-diff-arguments)) + (let ((default-directory default-directory) + (section (magit-current-section))) + (cond + ((magit-section-match 'module section) + (setq default-directory + (expand-file-name + (file-name-as-directory (oref section value)))) + (magit-diff-range (oref section range))) + (t + (when (magit-section-match 'module-commit section) + (setq args nil) + (setq files nil) + (setq default-directory + (expand-file-name + (file-name-as-directory (magit-section-parent-value section))))) + (pcase (magit-diff--dwim) + ('unmerged (magit-diff-unmerged args files)) + ('unstaged (magit-diff-unstaged args files)) + ('staged + (let ((file (magit-file-at-point))) + (if (and file (equal (cddr (car (magit-file-status file))) '(?D ?U))) + ;; File was deleted by us and modified by them. Show the latter. + (magit-diff-unmerged args (list file)) + (magit-diff-staged nil args files)))) + (`(stash . ,value) (magit-stash-show value args)) + (`(commit . ,value) + (magit-diff-range (format "%s^..%s" value value) args files)) + ((and range (pred stringp)) + (magit-diff-range range args files)) + (_ (call-interactively #'magit-diff-range))))))) + +(defun magit-diff--dwim () + "Return information for performing DWIM diff. + +The information can be in three forms: +1. TYPE + A symbol describing a type of diff where no additional information + is needed to generate the diff. Currently, this includes `staged', + `unstaged' and `unmerged'. +2. (TYPE . VALUE) + Like #1 but the diff requires additional information, which is + given by VALUE. Currently, this includes `commit' and `stash', + where VALUE is the given commit or stash, respectively. +3. RANGE + A string indicating a diff range. + +If no DWIM context is found, nil is returned." + (cond + ((and-let* ((commits (magit-region-values '(commit branch) t))) + (progn + (deactivate-mark) + (concat (car (last commits)) ".." (car commits))))) + (magit-buffer-refname + (cons 'commit magit-buffer-refname)) + ((derived-mode-p 'magit-stash-mode) + (cons 'commit + (magit-section-case + (commit (oref it value)) + (file (thread-first it + (oref parent) + (oref value))) + (hunk (thread-first it + (oref parent) + (oref parent) + (oref value)))))) + ((derived-mode-p 'magit-revision-mode) + (cons 'commit magit-buffer-revision)) + ((derived-mode-p 'magit-diff-mode) + magit-buffer-range) + (t + (magit-section-case + ([* unstaged] 'unstaged) + ([* staged] 'staged) + (unmerged 'unmerged) + (unpushed (magit-diff--range-to-endpoints (oref it value))) + (unpulled (magit-diff--range-to-endpoints (oref it value))) + (branch (let ((current (magit-get-current-branch)) + (atpoint (oref it value))) + (if (equal atpoint current) + (if-let ((upstream (magit-get-upstream-branch))) + (format "%s...%s" upstream current) + (if (magit-anything-modified-p) + current + (cons 'commit current))) + (format "%s...%s" + (or current "HEAD") + atpoint)))) + (commit (cons 'commit (oref it value))) + ([file commit] (cons 'commit (oref (oref it parent) value))) + ([hunk file commit] + (cons 'commit (oref (oref (oref it parent) parent) value))) + (stash (cons 'stash (oref it value))) + (pullreq (forge--pullreq-range (oref it value) t)))))) + +(defun magit-diff--range-to-endpoints (range) + (cond ((string-match "\\.\\.\\." range) (replace-match ".." nil nil range)) + ((string-match "\\.\\." range) (replace-match "..." nil nil range)) + (t range))) + +(defun magit-diff--region-range (&optional interactive mbase) + (and-let* ((commits (magit-region-values '(commit branch) t)) + (revA (car (last commits))) + (revB (car commits))) + (progn + (when interactive + (deactivate-mark)) + (if mbase + (let ((base (magit-git-string "merge-base" revA revB))) + (cond + ((string= (magit-rev-parse revA) base) + (format "%s..%s" revA revB)) + ((string= (magit-rev-parse revB) base) + (format "%s..%s" revB revA)) + (interactive + (let ((main (magit-completing-read "View changes along" + (list revA revB) + nil t nil nil revB))) + (format "%s...%s" + (if (string= main revB) revA revB) main))) + (t "%s...%s" revA revB))) + (format "%s..%s" revA revB))))) + +(defun magit-diff-read-range-or-commit (prompt &optional secondary-default mbase) + "Read range or revision with special diff range treatment. +If MBASE is non-nil, prompt for which rev to place at the end of +a \"revA...revB\" range. Otherwise, always construct +\"revA..revB\" range." + (or (magit-diff--region-range t mbase) + (magit-read-range prompt + (or (pcase (magit-diff--dwim) + (`(commit . ,value) + (format "%s^..%s" value value)) + ((and range (pred stringp)) + range)) + secondary-default + (magit-get-current-branch))))) + +;;;###autoload +(defun magit-diff-range (rev-or-range &optional args files) + "Show differences between two commits. + +REV-OR-RANGE should be a range or a single revision. If it is a +revision, then show changes in the working tree relative to that +revision. If it is a range, but one side is omitted, then show +changes relative to `HEAD'. + +If the region is active, use the revisions on the first and last +line of the region as the two sides of the range. With a prefix +argument, instead of diffing the revisions, choose a revision to +view changes along, starting at the common ancestor of both +revisions (i.e., use a \"...\" range)." + (interactive (cons (magit-diff-read-range-or-commit "Diff for range" + nil current-prefix-arg) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev-or-range nil args files 'committed)) + +;;;###autoload +(defun magit-diff-working-tree (&optional rev args files) + "Show changes between the current working tree and the `HEAD' commit. +With a prefix argument show changes between the working tree and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff working tree and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer (or rev "HEAD") nil args files 'committed)) + +;;;###autoload +(defun magit-diff-staged (&optional rev args files) + "Show changes between the index and the `HEAD' commit. +With a prefix argument show changes between the index and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff index and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev "--cached" args files 'staged)) + +;;;###autoload +(defun magit-diff-unstaged (&optional args files) + "Show changes between the working tree and the index." + (interactive (magit-diff-arguments)) + (magit-diff-setup-buffer nil nil args files 'unstaged)) + +;;;###autoload +(defun magit-diff-unmerged (&optional args files) + "Show changes that are being merged." + (interactive (magit-diff-arguments)) + (unless (magit-merge-in-progress-p) + (user-error "No merge is in progress")) + (magit-diff-setup-buffer (magit--merge-range) nil args files 'committed)) + +;;;###autoload +(defun magit-diff-while-committing () + "While committing, show the changes that are about to be committed. +While amending, invoking the command again toggles between +showing just the new changes or all the changes that will +be committed." + (interactive) + (unless (magit-commit-message-buffer) + (user-error "No commit in progress")) + (magit-commit-diff-1)) + +;;;###autoload +(defun magit-diff-buffer-file () + "Show diff for the blob or file visited in the current buffer. + +When the buffer visits a blob, then show the respective commit. +When the buffer visits a file, then show the differences between +`HEAD' and the working tree. In both cases limit the diff to +the file or blob." + (interactive) + (require 'magit) + (if-let ((file (magit-file-relative-name))) + (if magit-buffer-refname + (magit-show-commit magit-buffer-refname + (car (magit-show-commit--arguments)) + (list file)) + (save-buffer) + (let ((line (line-number-at-pos)) + (col (current-column))) + (with-current-buffer + (magit-diff-setup-buffer (or (magit-get-current-branch) "HEAD") + nil + (car (magit-diff-arguments)) + (list file) + 'unstaged + magit-diff-buffer-file-locked) + (magit-diff--goto-position file line col)))) + (user-error "Buffer isn't visiting a file"))) + +;;;###autoload +(defun magit-diff-paths (a b) + "Show changes between any two files on disk." + (interactive (list (read-file-name "First file: " nil nil t) + (read-file-name "Second file: " nil nil t))) + (magit-diff-setup-buffer nil "--no-index" nil + (list (magit-convert-filename-for-git + (expand-file-name a)) + (magit-convert-filename-for-git + (expand-file-name b))) + 'undefined)) + +(defun magit-show-commit--arguments () + (pcase-let ((`(,args ,diff-files) + (magit-diff-arguments 'magit-revision-mode))) + (list args (if (derived-mode-p 'magit-log-mode) + (and (or magit-revision-filter-files-on-follow + (not (member "--follow" magit-buffer-log-args))) + magit-buffer-log-files) + diff-files)))) + +;;;###autoload +(defun magit-show-commit (rev &optional args files module) + "Visit the revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision." + (interactive + (pcase-let* ((mcommit (magit-section-value-if 'module-commit)) + (atpoint (or mcommit + (magit-thing-at-point 'git-revision t) + (magit-branch-or-commit-at-point))) + (`(,args ,files) (magit-show-commit--arguments))) + (list (or (and (not current-prefix-arg) atpoint) + (magit-read-branch-or-commit "Show commit" atpoint)) + args + files + (and mcommit + (magit-section-parent-value (magit-current-section)))))) + (require 'magit) + (let* ((file (magit-file-relative-name)) + (ln (and file (line-number-at-pos)))) + (magit-with-toplevel + (when module + (setq default-directory + (expand-file-name (file-name-as-directory module)))) + (unless (magit-commit-p rev) + (user-error "%s is not a commit" rev)) + (when file + (save-buffer)) + (let ((buf (magit-revision-setup-buffer rev args files))) + (when file + (let ((line (magit-diff-visit--offset file (list "-R" rev) ln)) + (col (current-column))) + (with-current-buffer buf + (magit-diff--goto-position file line col)))))))) + +(defun magit-diff--locate-hunk (file line &optional parent) + (and-let* ((diff (cl-find-if (lambda (section) + (and (cl-typep section 'magit-file-section) + (equal (oref section value) file))) + (oref (or parent magit-root-section) children)))) + (let ((hunks (oref diff children))) + (cl-block nil + (while-let ((hunk (pop hunks))) + (when-let ((range (oref hunk to-range))) + (pcase-let* ((`(,beg ,len) range) + (end (+ beg len))) + (cond ((> beg line) (cl-return (list diff nil))) + ((<= beg line end) (cl-return (list hunk t))) + ((null hunks) (cl-return (list hunk nil))))))))))) + +(defun magit-diff--goto-position (file line column &optional parent) + (when-let ((pos (magit-diff--locate-hunk file line parent))) + (pcase-let ((`(,section ,exact) pos)) + (cond ((cl-typep section 'magit-file-section) + (goto-char (oref section start))) + (exact + (goto-char (oref section content)) + (let ((pos (car (oref section to-range)))) + (while (or (< pos line) + (= (char-after) ?-)) + (unless (= (char-after) ?-) + (cl-incf pos)) + (forward-line))) + (forward-char (1+ column))) + (t + (goto-char (oref section start)) + (setq section (oref section parent)))) + (while section + (when (oref section hidden) + (magit-section-show section)) + (setq section (oref section parent)))) + (magit-section-update-highlight) + t)) + +;;;; Setting Commands + +(defun magit-diff-switch-range-type () + "Convert diff range type. +Change \"revA..revB\" to \"revA...revB\", or vice versa." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (setq magit-buffer-range + (replace-match (if (string= (match-string 2 magit-buffer-range) "..") + "..." + "..") + t t magit-buffer-range 2)) + (user-error "No range to change")) + (magit-refresh)) + +(defun magit-diff-flip-revs () + "Swap revisions in diff range. +Change \"revA..revB\" to \"revB..revA\"." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (progn + (setq magit-buffer-range + (concat (match-string 3 magit-buffer-range) + (match-string 2 magit-buffer-range) + (match-string 1 magit-buffer-range))) + (magit-refresh)) + (user-error "No range to swap"))) + +(defun magit-diff-toggle-file-filter () + "Toggle the file restriction of the current buffer's diffs. +If the current buffer's mode is derived from `magit-log-mode', +toggle the file restriction in the repository's revision buffer +instead." + (interactive) + (cl-flet ((toggle () + (if (or magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (cl-rotatef magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (setq magit-buffer-diff-files + (transient-infix-read 'magit:--))) + (magit-refresh))) + (cond + ((derived-mode-p 'magit-log-mode + 'magit-cherry-mode + 'magit-reflog-mode) + (if-let ((buffer (magit-get-mode-buffer 'magit-revision-mode))) + (with-current-buffer buffer (toggle)) + (message "No revision buffer"))) + ((local-variable-p 'magit-buffer-diff-files) + (toggle)) + (t + (user-error "Cannot toggle file filter in this buffer"))))) + +(defun magit-diff-less-context (&optional count) + "Decrease the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context (lambda (cur) (max 0 (- (or cur 0) count))))) + +(defun magit-diff-more-context (&optional count) + "Increase the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context (lambda (cur) (+ (or cur 0) count)))) + +(defun magit-diff-default-context () + "Reset context for diff hunks to the default height." + (interactive) + (magit-diff-set-context #'ignore)) + +(defun magit-diff-set-context (fn) + (when (derived-mode-p 'magit-merge-preview-mode) + (user-error "Cannot use %s in %s" this-command major-mode)) + (let* ((def (if-let ((context (magit-get "diff.context"))) + (string-to-number context) + 3)) + (val magit-buffer-diff-args) + (arg (--first (string-match "^-U\\([0-9]+\\)?$" it) val)) + (num (if-let ((str (and arg (match-string 1 arg)))) + (string-to-number str) + def)) + (val (delete arg val)) + (num (funcall fn num)) + (arg (and num (not (= num def)) (format "-U%d" num))) + (val (if arg (cons arg val) val))) + (setq magit-buffer-diff-args val)) + (magit-refresh)) + +(defun magit-diff-context-p () + (if-let ((arg (--first (string-match "^-U\\([0-9]+\\)$" it) + magit-buffer-diff-args))) + (not (equal arg "-U0")) + t)) + +(defun magit-diff-ignore-any-space-p () + (--any-p (member it magit-buffer-diff-args) + '("--ignore-cr-at-eol" + "--ignore-space-at-eol" + "--ignore-space-change" "-b" + "--ignore-all-space" "-w" + "--ignore-blank-space"))) + +(defun magit-diff-toggle-refine-hunk (&optional style) + "Turn diff-hunk refining on or off. + +If hunk refining is currently on, then hunk refining is turned off. +If hunk refining is off, then hunk refining is turned on, in +`selected' mode (only the currently selected hunk is refined). + +With a prefix argument, the \"third choice\" is used instead: +If hunk refining is currently on, then refining is kept on, but +the refining mode (`selected' or `all') is switched. +If hunk refining is off, then hunk refining is turned on, in +`all' mode (all hunks refined). + +Customize variable `magit-diff-refine-hunk' to change the default mode." + (interactive "P") + (setq-local magit-diff-refine-hunk + (if style + (if (eq magit-diff-refine-hunk 'all) t 'all) + (not magit-diff-refine-hunk))) + (magit-diff-update-hunk-refinement)) + +;;;; Visit Commands +;;;;; Dwim Variants + +(defun magit-diff-visit-file (file &optional other-window) + "From a diff visit the appropriate version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +Visit the worktree version of the appropriate file. The location +of point inside the diff determines which file is being visited. +The visited version depends on what changes the diff is about. + +1. If the diff shows uncommitted changes (i.e., stage or unstaged + changes), then visit the file in the working tree (i.e., the + same \"real\" file that `find-file' would visit). In all + other cases visit a \"blob\" (i.e., the version of a file as + stored in some commit). + +2. If point is on a removed line, then visit the blob for the + first parent of the commit that removed that line, i.e., the + last commit where that line still exists. + +3. If point is on an added or context line, then visit the blob + that adds that line, or if the diff shows from more than a + single commit, then visit the blob from the last of these + commits. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. + +Note that this command only works if point is inside a diff. +In other cases `magit-find-file' (which see) has to be used." + (interactive (list (magit-diff--file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file nil + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-file-other-window (file) + "From a diff visit the appropriate version of FILE in another window. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-diff--file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-file-other-frame (file) + "From a diff visit the appropriate version of FILE in another frame. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-diff--file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-frame)) + +;;;;; Worktree Variants + +(defun magit-diff-visit-worktree-file (file &optional other-window) + "From a diff visit the worktree version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +Visit the worktree version of the appropriate file. The location +of point inside the diff determines which file is being visited. + +Unlike `magit-diff-visit-file' always visits the \"real\" file in +the working tree, i.e the \"current version\" of the file. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. Lines that were added +or removed in the working tree, the index and other commits in +between are automatically accounted for." + (interactive (list (magit-file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file t + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-worktree-file-other-window (file) + "From a diff visit the worktree version of FILE in another window. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-worktree-file-other-frame (file) + "From a diff visit the worktree version of FILE in another frame. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-frame)) + +;;;;; Internal + +(defun magit-diff-visit-file--internal (file force-worktree fn) + "From a diff visit the appropriate version of FILE. +If FORCE-WORKTREE is non-nil, then visit the worktree version of +the file, even if the diff is about a committed change. Use FN +to display the buffer in some window." + (if (file-accessible-directory-p file) + (magit-diff-visit-directory file force-worktree) + (pcase-let ((`(,buf ,pos) + (magit-diff-visit-file--noselect file force-worktree))) + (funcall fn buf) + (magit-diff-visit-file--setup buf pos) + buf))) + +(defun magit-diff-visit-directory (directory &optional other-window) + "Visit DIRECTORY in some window. +Display the buffer in the selected window unless OTHER-WINDOW is +non-nil. If DIRECTORY is the top-level directory of the current +repository, then visit the containing directory using Dired and +in the Dired buffer put point on DIRECTORY. Otherwise display +the Magit-Status buffer for DIRECTORY." + (if (equal (magit-toplevel directory) + (magit-toplevel)) + (dired-jump other-window (concat directory "/.")) + (let ((display-buffer-overriding-action + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window)))) + (magit-status-setup-buffer directory)))) + +(defun magit-diff-visit-file--setup (buf pos) + (if-let ((win (get-buffer-window buf 'visible))) + (with-selected-window win + (when pos + (unless (<= (point-min) pos (point-max)) + (widen)) + (goto-char pos)) + (when (and buffer-file-name + (magit-anything-unmerged-p buffer-file-name)) + (smerge-start-session)) + (run-hooks 'magit-diff-visit-file-hook)) + (error "File buffer is not visible"))) + +(defun magit-diff-visit-file--noselect (&optional file goto-worktree) + (unless file + (setq file (magit-diff--file-at-point t t))) + (let* ((hunk (magit-diff-visit--hunk)) + (goto-from (and hunk + (magit-diff-visit--goto-from-p hunk goto-worktree))) + (line (and hunk (magit-diff-hunk-line hunk goto-from))) + (col (and hunk (magit-diff-hunk-column hunk goto-from))) + (spec (magit-diff--dwim)) + (rev (if goto-from + (magit-diff-visit--range-from spec) + (magit-diff-visit--range-to spec))) + (buf (if (or goto-worktree + (equal magit-buffer-typearg "--no-index") + (and (not (stringp rev)) + (or magit-diff-visit-avoid-head-blob + (not goto-from)))) + (or (get-file-buffer file) + (find-file-noselect file)) + (magit-find-file-noselect (if (stringp rev) rev "HEAD") + file)))) + (if line + (with-current-buffer buf + (cond ((eq rev 'staged) + (setq line (magit-diff-visit--offset file nil line))) + ((and goto-worktree + (stringp rev)) + (setq line (magit-diff-visit--offset file rev line)))) + (list buf (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column col) + (point)))) + (list buf nil)))) + +(defun magit-diff--file-at-point (&optional expand assert) + ;; This is a variation of magit-file-at-point. + (if-let* ((file-section (magit-section-case + (file it) + (hunk (oref it parent)))) + (file (or (and (magit-section-match 'hunk) + (magit-diff-visit--goto-from-p + (magit-current-section) nil) + (oref file-section source)) + (oref file-section value)))) + (cond ((equal magit-buffer-typearg "--no-index") + (concat "/" file)) + (expand (expand-file-name file (magit-toplevel))) + (file)) + (when assert + (user-error "No file at point")))) + +(defun magit-diff-visit--hunk () + (and-let* ((scope (magit-diff-scope)) + (section (magit-current-section))) + (progn + (cl-case scope + ((file files) + (setq section (car (oref section children)))) + (list + (setq section (car (oref section children))) + (when section + (setq section (car (oref section children)))))) + (and + ;; Unmerged files appear in the list of staged changes + ;; but unlike in the list of unstaged changes no diffs + ;; are shown here. In that case `section' is nil. + section + ;; Currently the `hunk' type is also abused for file + ;; mode changes, which we are not interested in here. + (not (equal (oref section value) '(chmod))) + section)))) + +(defun magit-diff-visit--goto-from-p (section in-worktree) + (and magit-diff-visit-previous-blob + (not in-worktree) + (not (oref section combined)) + (not (< (magit-point) (oref section content))) + (= (char-after (line-beginning-position)) ?-))) + +(defvar magit-diff-visit-jump-to-change t) + +(defun magit-diff-hunk-line (section goto-from) + (save-excursion + (goto-char (line-beginning-position)) + (with-slots (content combined from-ranges from-range to-range) section + (when (or from-range to-range) + (when (and magit-diff-visit-jump-to-change (< (point) content)) + (goto-char content) + (re-search-forward "^[-+]")) + (+ (car (if goto-from from-range to-range)) + (let ((prefix (if combined (length from-ranges) 1)) + (target (point)) + (offset 0)) + (goto-char content) + (while (< (point) target) + (unless (string-search + (if goto-from "+" "-") + (buffer-substring (point) (+ (point) prefix))) + (cl-incf offset)) + (forward-line)) + offset)))))) + +(defun magit-diff-hunk-column (section goto-from) + (if (or (< (magit-point) + (oref section content)) + (and (not goto-from) + (= (char-after (line-beginning-position)) ?-))) + 0 + (max 0 (- (+ (current-column) 2) + (length (oref section value)))))) + +(defun magit-diff-visit--range-from (spec) + (cond ((consp spec) + (concat (cdr spec) "^")) + ((stringp spec) + (car (magit-split-range spec))) + (t + spec))) + +(defun magit-diff-visit--range-to (spec) + (if (symbolp spec) + spec + (let ((rev (if (consp spec) + (cdr spec) + (cdr (magit-split-range spec))))) + (if (and magit-diff-visit-avoid-head-blob + (magit-rev-head-p rev)) + 'unstaged + rev)))) + +(defun magit-diff-visit--offset (file rev line) + (let ((offset 0)) + (with-temp-buffer + (save-excursion + (magit-with-toplevel + (magit-git-insert "diff" rev "--" file))) + (catch 'found + (while (re-search-forward + "^@@ -\\([0-9]+\\),\\([0-9]+\\) \\+\\([0-9]+\\),\\([0-9]+\\) @@.*\n" + nil t) + (let ((from-beg (string-to-number (match-string 1))) + (from-len (string-to-number (match-string 2))) + ( to-len (string-to-number (match-string 4)))) + (if (<= from-beg line) + (if (< (+ from-beg from-len) line) + (cl-incf offset (- to-len from-len)) + (let ((rest (- line from-beg))) + (while (> rest 0) + (pcase (char-after) + (?\s (cl-decf rest)) + (?- (cl-decf offset) (cl-decf rest)) + (?+ (cl-incf offset))) + (forward-line)))) + (throw 'found nil)))))) + (+ line offset))) + +;;;; Scroll Commands + +(defun magit-diff-show-or-scroll-up () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer up. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll #'scroll-up)) + +(defun magit-diff-show-or-scroll-down () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer down. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll #'scroll-down)) + +(defun magit-diff-show-or-scroll (fn) + (let (rev cmd buf win) + (cond + ((and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk)) + (setq rev (oref (magit-current-blame-chunk) orig-rev)) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + ((derived-mode-p 'git-rebase-mode) + (with-slots (action-type target) + (git-rebase-current-line) + (if (not (eq action-type 'commit)) + (user-error "No commit on this line") + (setq rev target) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))))) + (t + (magit-section-case + (branch + (setq rev (magit-ref-maybe-qualify (oref it value))) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (commit + (setq rev (oref it value)) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (tag + (setq rev (magit-rev-hash (oref it value))) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (stash + (setq rev (oref it value)) + (setq cmd #'magit-stash-show) + (setq buf (magit-get-mode-buffer 'magit-stash-mode)))))) + (if rev + (if (and buf + (setq win (get-buffer-window buf)) + (with-current-buffer buf + (and (equal rev magit-buffer-revision) + (equal (magit-rev-parse rev) + magit-buffer-revision-hash)))) + (with-selected-window win + (condition-case nil + (funcall fn) + (error + (goto-char (pcase fn + ('scroll-up (point-min)) + ('scroll-down (point-max))))))) + (let ((magit-display-buffer-noselect t)) + (if (eq cmd #'magit-show-commit) + (apply #'magit-show-commit rev (magit-show-commit--arguments)) + (funcall cmd rev)))) + (call-interactively #'magit-show-commit)))) + +;;;; Section Commands + +(defun magit-section-cycle-diffs () + "Cycle visibility of diff-related sections in the current buffer." + (interactive) + (when-let ((sections + (cond ((derived-mode-p 'magit-status-mode) + (--mapcat + (when it + (when (oref it hidden) + (magit-section-show it)) + (oref it children)) + (list (magit-get-section '((staged) (status))) + (magit-get-section '((unstaged) (status)))))) + ((derived-mode-p 'magit-diff-mode) + (seq-filter #'magit-file-section-p + (oref magit-root-section children)))))) + (if (--any-p (oref it hidden) sections) + (dolist (s sections) + (magit-section-show s) + (magit-section-hide-children s)) + (let ((children (--mapcat (oref it children) sections))) + (cond ((and (--any-p (oref it hidden) children) + (--any-p (oref it children) children)) + (mapc #'magit-section-show-headings sections)) + ((seq-some #'magit-section-hidden-body children) + (mapc #'magit-section-show-children sections)) + (t + (mapc #'magit-section-hide sections))))))) + +;;; Diff Mode + +(defvar-keymap magit-diff-mode-map + :doc "Keymap for `magit-diff-mode'." + :parent magit-mode-map + "C-c C-d" #'magit-diff-while-committing + "C-c C-b" #'magit-go-backward + "C-c C-f" #'magit-go-forward + "SPC" #'scroll-up + "DEL" #'scroll-down + "j" #'magit-jump-to-diffstat-or-diff + "<remap> <write-file>" #'magit-patch-save) + +(define-derived-mode magit-diff-mode magit-mode "Magit Diff" + "Mode for looking at a Git diff. + +This mode is documented in info node `(magit)Diff Buffer'. + +\\<magit-mode-map>\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\<magit-hunk-section-map>Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-diff-mode-map}" + :interactive nil + :group 'magit-diff + (magit-hack-dir-local-variables) + (setq magit--imenu-item-types 'file)) + +(put 'magit-diff-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-diff-setup-buffer ( range typearg args files + &optional type locked) + (require 'magit) + (magit-setup-buffer #'magit-diff-mode locked + (magit-buffer-range range) + (magit-buffer-typearg typearg) + (magit-buffer-diff-type type) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files) + (magit-buffer-diff-files-suspended nil))) + +(defun magit-diff-refresh-buffer () + "Refresh the current `magit-diff-mode' buffer." + (magit-set-header-line-format + (if (equal magit-buffer-typearg "--no-index") + (apply #'format "Differences between %s and %s" magit-buffer-diff-files) + (concat (if magit-buffer-range + (if (string-match-p "\\(\\.\\.\\|\\^-\\)" + magit-buffer-range) + (format "Changes in %s" magit-buffer-range) + (let ((msg "Changes from %s to %s") + (end (if (equal magit-buffer-typearg "--cached") + "index" + "working tree"))) + (if (member "-R" magit-buffer-diff-args) + (format msg end magit-buffer-range) + (format msg magit-buffer-range end)))) + (cond ((equal magit-buffer-typearg "--cached") + "Staged changes") + ((and (magit-repository-local-get 'this-commit-command) + (not (magit-anything-staged-p))) + "Uncommitting changes") + (t "Unstaged changes"))) + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " in file " (car magit-buffer-diff-files))) + (_ (concat " in files " + (string-join magit-buffer-diff-files ", "))))))) + (setq magit-buffer-range-hashed + (and magit-buffer-range (magit-hash-range magit-buffer-range))) + (magit-insert-section (diffbuf) + (magit-run-section-hook 'magit-diff-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-diff-mode)) + (nconc (cond (magit-buffer-range + (delq nil (list magit-buffer-range magit-buffer-typearg))) + ((equal magit-buffer-typearg "--cached") + (list 'staged)) + (t + (list 'unstaged magit-buffer-typearg))) + (and magit-buffer-diff-files (cons "--" magit-buffer-diff-files)))) + +(cl-defmethod magit-menu-common-value ((_section magit-diff-section)) + (magit-diff-scope)) + +(define-obsolete-variable-alias 'magit-diff-section-base-map + 'magit-diff-section-map "Magit-Section 4.0.0") + +(defvar-keymap magit-diff-section-map + :doc "Keymap for diff sections. +The classes `magit-file-section' and `magit-hunk-section' derive +from the abstract `magit-diff-section' class. Accordingly this +keymap is the parent of their keymaps." + "C-j" #'magit-diff-visit-worktree-file + "C-<return>" #'magit-diff-visit-worktree-file + "C-x 4 <return>" #'magit-diff-visit-file-other-window + "C-x 5 <return>" #'magit-diff-visit-file-other-frame + "&" #'magit-do-async-shell-command + "C" #'magit-commit-add-log + "C-x a" #'magit-add-change-log-entry + "C-x 4 a" #'magit-add-change-log-entry-other-window + "C-c C-t" #'magit-diff-trace-definition + "C-c C-e" #'magit-diff-edit-hunk-commit + "<remap> <magit-file-rename>" #'magit-file-rename + "<remap> <magit-file-untrack>" #'magit-file-untrack + "<remap> <magit-visit-thing>" #'magit-diff-visit-file + "<remap> <magit-revert-no-commit>" #'magit-reverse + "<remap> <magit-delete-thing>" #'magit-discard + "<remap> <magit-unstage-file>" #'magit-unstage + "<remap> <magit-stage-file>" #'magit-stage + "<remap> <magit-cherry-apply>" #'magit-apply + "<8>" (magit-menu-item "Rename file" #'magit-file-rename + '(:enable (eq (magit-diff-scope) 'file))) + "<7>" (magit-menu-item "Untrack %x" #'magit-file-untrack) + "<6>" (magit-menu-item "Visit file" #'magit-diff-visit-file + '(:enable (memq (magit-diff-scope) '(file files)))) + "<5>" (magit-menu-item "Reverse %x" #'magit-reverse + '(:enable (not (memq (magit-diff-type) + '(untracked unstaged))))) + "<4>" (magit-menu-item "Discard %x" #'magit-discard + '(:enable (not (memq (magit-diff-type) + '(committed undefined))))) + "<3>" (magit-menu-item "Unstage %x" #'magit-unstage + '(:enable (eq (magit-diff-type) 'staged))) + "<2>" (magit-menu-item "Stage %x" #'magit-stage + '(:enable (eq (magit-diff-type) 'unstaged))) + "<1>" (magit-menu-item "Apply %x" #'magit-apply + '(:enable (not (memq (magit-diff-type) + '(unstaged staged)))))) + +(defvar-keymap magit-file-section-map + ;; Even though this derived map doesn't add any bindings by default, + ;; it is quite possible that some users would want to add their own. + :doc "Keymap for `file' sections." + :parent magit-diff-section-base-map) + +(defvar-keymap magit-hunk-section-smerge-map + :doc "Keymap bound to `smerge-command-prefix' in `magit-hunk-section-map'." + "RET" #'magit-smerge-keep-current + "a" #'magit-smerge-keep-all + "u" #'magit-smerge-keep-upper + "b" #'magit-smerge-keep-base + "l" #'magit-smerge-keep-lower) + +(defvar-keymap magit-hunk-section-map + :doc "Keymap for `hunk' sections." + :parent magit-diff-section-base-map + (key-description smerge-command-prefix) magit-hunk-section-smerge-map) + +(defconst magit-diff-conflict-headline-re + (concat "^" (regexp-opt + ;; Defined in merge-tree.c in this order. + '("merged" + "added in remote" + "added in both" + "added in local" + "removed in both" + "changed in both" + "removed in local" + "removed in remote")))) + +(defconst magit-diff-headline-re + (concat "^\\(@@@?\\|diff\\|Submodule\\|" + "\\* Unmerged path\\|" + (substring magit-diff-conflict-headline-re 1) + "\\)")) + +(defconst magit-diff-statline-re + (concat "^ ?" + "\\(.*\\)" ; file + "\\( +| +\\)" ; separator + "\\([0-9]+\\|Bin\\(?: +[0-9]+ -> [0-9]+ bytes\\)?$\\) ?" + "\\(\\+*\\)" ; add + "\\(-*\\)$")) ; del + +(defvar magit-diff--reset-non-color-moved + (list + "-c" "color.diff.context=normal" + "-c" "color.diff.plain=normal" ; historical synonym for context + "-c" "color.diff.meta=normal" + "-c" "color.diff.frag=normal" + "-c" "color.diff.func=normal" + "-c" "color.diff.old=normal" + "-c" "color.diff.new=normal" + "-c" "color.diff.commit=normal" + "-c" "color.diff.whitespace=normal" + ;; "git-range-diff" does not support "--color-moved", so we don't + ;; need to reset contextDimmed, oldDimmed, newDimmed, contextBold, + ;; oldBold, and newBold. + )) + +(defun magit-insert-diff () + "Insert the diff into this `magit-diff-mode' buffer." + (magit--insert-diff t + "diff" magit-buffer-range "-p" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-typearg + magit-buffer-diff-args "--" + magit-buffer-diff-files)) + +(defun magit--insert-diff (keep-error &rest args) + (declare (indent 1)) + (pcase-let ((`(,cmd . ,args) + (flatten-tree args)) + (magit-git-global-arguments + (remove "--literal-pathspecs" magit-git-global-arguments))) + ;; As of Git 2.19.0, we need to generate diffs with + ;; --ita-visible-in-index so that `magit-stage' can work with + ;; intent-to-add files (see #4026). + (when (and (not (equal cmd "merge-tree")) + (magit-git-version>= "2.19.0")) + (push "--ita-visible-in-index" args)) + (setq args (magit-diff--maybe-add-stat-arguments args)) + (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) + (push "--color=always" args) + (setq magit-git-global-arguments + (append magit-diff--reset-non-color-moved + magit-git-global-arguments))) + (magit--git-wash #'magit-diff-wash-diffs + (if (member "--no-index" args) + 'wash-anyway + (or keep-error magit--git-wash-keep-error)) + cmd args))) + +(defun magit-diff--maybe-add-stat-arguments (args) + (if (member "--stat" args) + (append (if (functionp magit-diff-extra-stat-arguments) + (funcall magit-diff-extra-stat-arguments) + magit-diff-extra-stat-arguments) + args) + args)) + +(defun magit-diff-use-window-width-as-stat-width () + "Use the `window-width' as the value of `--stat-width'." + (and-let* ((window (get-buffer-window (current-buffer) 'visible))) + (list (format "--stat-width=%d" (window-width window))))) + +(defun magit-diff-wash-diffs (args &optional limit) + (run-hooks 'magit-diff-wash-diffs-hook) + (when (member "--show-signature" args) + (magit-diff-wash-signature magit-buffer-revision-hash)) + (when (member "--stat" args) + (magit-diff-wash-diffstat)) + (when (re-search-forward magit-diff-headline-re limit t) + (goto-char (line-beginning-position)) + (magit-wash-sequence (apply-partially #'magit-diff-wash-diff args)) + (insert ?\n))) + +(defun magit-jump-to-diffstat-or-diff () + "Jump to the diffstat or diff. +When point is on a file inside the diffstat section, then jump +to the respective diff section, otherwise jump to the diffstat +section or a child thereof." + (interactive) + (if-let ((section (magit-get-section + (append (magit-section-case + ([file diffstat] `((file . ,(oref it value)))) + (file `((file . ,(oref it value)) (diffstat))) + (t '((diffstat)))) + (magit-section-ident magit-root-section))))) + (magit-section-goto section) + (user-error "No diffstat in this buffer"))) + +(defun magit-diff-wash-signature (object) + (cond + ((looking-at "^No signature") + (delete-line)) + ((looking-at "^gpg: ") + (let (title end) + (save-excursion + (while (looking-at "^gpg: ") + (cond + ((looking-at "^gpg: Good signature from") + (setq title (propertize + (buffer-substring (point) (line-end-position)) + 'face 'magit-signature-good))) + ((looking-at "^gpg: Can't check signature") + (setq title (propertize + (buffer-substring (point) (line-end-position)) + 'face '(italic bold))))) + (forward-line)) + (setq end (point-marker))) + (magit-insert-section (signature object title) + (when title + (magit-insert-heading title)) + (goto-char end) + (set-marker end nil) + (insert "\n")))))) + +(defun magit-diff-wash-diffstat () + (let (heading (beg (point))) + (when (re-search-forward "^ ?\\([0-9]+ +files? change[^\n]*\n\\)" nil t) + (setq heading (match-string 1)) + (magit-delete-match) + (goto-char beg) + (magit-insert-section (diffstat) + (insert (propertize heading 'font-lock-face 'magit-diff-file-heading)) + (magit-insert-heading) + (let (files) + (while (looking-at "^[-0-9]+\t[-0-9]+\t\\(.+\\)$") + (push (magit-decode-git-path + (let ((f (match-string 1))) + (cond + ((string-match "{.* => \\(.*\\)}" f) + (replace-match (match-string 1 f) nil t f)) + ((string-match " => " f) + (substring f (match-end 0))) + (t f)))) + files) + (magit-delete-line)) + (setq files (nreverse files)) + (while (looking-at magit-diff-statline-re) + (magit-bind-match-strings (file sep cnt add del) nil + (magit-delete-line) + (when (string-match " +$" file) + (setq sep (concat (match-string 0 file) sep)) + (setq file (substring file 0 (match-beginning 0)))) + (let ((le (length file)) ld) + (setq file (magit-decode-git-path file)) + (setq ld (length file)) + (when (> le ld) + (setq sep (concat (make-string (- le ld) ?\s) sep)))) + (magit-insert-section (file (pop files)) + (insert (propertize file 'font-lock-face 'magit-filename) + sep cnt " ") + (when add + (insert (propertize add 'font-lock-face + 'magit-diffstat-added))) + (when del + (insert (propertize del 'font-lock-face + 'magit-diffstat-removed))) + (insert "\n"))))) + (if (looking-at "^$") (forward-line) (insert "\n")))))) + +(defun magit-diff-wash-diff (args) + (when (cl-member-if (lambda (arg) (string-prefix-p "--color-moved" arg)) args) + (require 'ansi-color) + (ansi-color-apply-on-region (point-min) (point-max))) + (cond + ((looking-at "^Submodule") + (magit-diff-wash-submodule)) + ((looking-at "^\\* Unmerged path \\(.*\\)") + (let ((file (magit-decode-git-path (match-string 1)))) + (magit-delete-line) + (unless (and (derived-mode-p 'magit-status-mode) + (not (member "--cached" args))) + (magit-insert-section (file file) + (insert (propertize + (format "unmerged %s%s" file + (pcase (cddr (car (magit-file-status file))) + ('(?D ?D) " (both deleted)") + ('(?D ?U) " (deleted by us)") + ('(?U ?D) " (deleted by them)") + ('(?A ?A) " (both added)") + ('(?A ?U) " (added by us)") + ('(?U ?A) " (added by them)") + ('(?U ?U) ""))) + 'font-lock-face 'magit-diff-file-heading)) + (insert ?\n)))) + t) + ((looking-at magit-diff-conflict-headline-re) + (let ((long-status (match-string 0)) + (status "BUG") + file orig base) + (if (equal long-status "merged") + (progn (setq status long-status) + (setq long-status nil)) + (setq status (pcase-exhaustive long-status + ("added in remote" "new file") + ("added in both" "new file") + ("added in local" "new file") + ("removed in both" "removed") + ("changed in both" "changed") + ("removed in local" "removed") + ("removed in remote" "removed")))) + (magit-delete-line) + (while (looking-at + "^ \\([^ ]+\\) +[0-9]\\{6\\} \\([a-z0-9]\\{40,\\}\\) \\(.+\\)$") + (magit-bind-match-strings (side _blob name) nil + (pcase side + ("result" (setq file name)) + ("our" (setq orig name)) + ("their" (setq file name)) + ("base" (setq base name)))) + (magit-delete-line)) + (when orig (setq orig (magit-decode-git-path orig))) + (when file (setq file (magit-decode-git-path file))) + (magit-diff-insert-file-section + (or file base) orig status nil nil nil nil long-status))) + ;; The files on this line may be ambiguous due to whitespace. + ;; That's okay. We can get their names from subsequent headers. + ((looking-at "^diff --\ +\\(?:\\(?1:git\\) \\(?:\\(?2:.+?\\) \\2\\)?\ +\\|\\(?:cc\\|combined\\) \\(?3:.+\\)\\)") + (let ((status (cond ((equal (match-string 1) "git") "modified") + ((derived-mode-p 'magit-revision-mode) "resolved") + (t "unmerged"))) + (orig nil) + (file (or (match-string 2) (match-string 3))) + (header (list (buffer-substring-no-properties + (line-beginning-position) (1+ (line-end-position))))) + (modes nil) + (rename nil) + (binary nil)) + (magit-delete-line) + (while (not (or (eobp) (looking-at magit-diff-headline-re))) + (cond + ((looking-at "old mode \\(?:[^\n]+\\)\nnew mode \\(?:[^\n]+\\)\n") + (setq modes (match-string 0))) + ((looking-at "deleted file .+\n") + (setq status "deleted")) + ((looking-at "new file .+\n") + (setq status "new file")) + ((looking-at "rename from \\(.+\\)\nrename to \\(.+\\)\n") + (setq rename (match-string 0)) + (setq orig (match-string 1)) + (setq file (match-string 2)) + (setq status "renamed")) + ((looking-at "copy from \\(.+\\)\ncopy to \\(.+\\)\n") + (setq orig (match-string 1)) + (setq file (match-string 2)) + (setq status "new file")) + ((looking-at "similarity index .+\n")) + ((looking-at "dissimilarity index .+\n")) + ((looking-at "index .+\n")) + ((looking-at "--- \\(.+?\\)\t?\n") + (unless (equal (match-string 1) "/dev/null") + (setq orig (match-string 1)))) + ((looking-at "\\+\\+\\+ \\(.+?\\)\t?\n") + (unless (equal (match-string 1) "/dev/null") + (setq file (match-string 1)))) + ((looking-at "Binary files .+ and .+ differ\n") + (setq binary t)) + ((looking-at "Binary files differ\n") + (setq binary t)) + ;; TODO Use all combined diff extended headers. + ((looking-at "mode .+\n")) + ((error "BUG: Unknown extended header: %S" + (buffer-substring (point) (line-end-position))))) + ;; These headers are treated as some sort of special hunk. + (unless (or (string-prefix-p "old mode" (match-string 0)) + (string-prefix-p "rename" (match-string 0))) + (push (match-string 0) header)) + (magit-delete-match)) + (when orig + (setq orig (magit-decode-git-path orig))) + (setq file (magit-decode-git-path file)) + (setq header (nreverse header)) + ;; KLUDGE `git-log' ignores `--no-prefix' when `-L' is used. + (when (and (derived-mode-p 'magit-log-mode) + (seq-some (lambda (arg) (string-prefix-p "-L" arg)) + magit-buffer-log-args)) + (when orig + (setq orig (substring orig 2))) + (setq file (substring file 2)) + (setq header (list (save-excursion + (string-match "diff [^ ]+" (car header)) + (format "%s %s %s\n" + (match-string 0 (car header)) + (or orig file) + (or file orig))) + (format "--- %s\n" (or orig "/dev/null")) + (format "+++ %s\n" (or file "/dev/null"))))) + (setq header (string-join header)) + (magit-diff-insert-file-section + file orig status modes rename header binary nil))))) + +(defun magit-diff-insert-file-section + (file orig status modes rename header binary long-status) + (magit-insert-section + ( file file + (or (equal status "deleted") (derived-mode-p 'magit-status-mode)) + :source (and (not (equal orig file)) orig) + :header header + :binary binary) + (insert (propertize (format "%-10s %s" status + (if (or (not orig) (equal orig file)) + file + (format "%s -> %s" orig file))) + 'font-lock-face 'magit-diff-file-heading)) + (cond ((and binary long-status) + (insert (format " (%s, binary)" long-status))) + ((or binary long-status) + (insert (format " (%s)" (if binary "binary" long-status))))) + (magit-insert-heading) + (when modes + (magit-insert-section (hunk '(chmod)) + (insert modes) + (magit-insert-heading))) + (when rename + (magit-insert-section (hunk '(rename)) + (insert rename) + (magit-insert-heading))) + (magit-wash-sequence #'magit-diff-wash-hunk))) + +(defun magit-diff-wash-submodule () + ;; See `show_submodule_summary' in submodule.c and "this" commit. + (when (looking-at "^Submodule \\([^ ]+\\)") + (let ((module (match-string 1)) + untracked modified) + (when (looking-at "^Submodule [^ ]+ contains untracked content$") + (magit-delete-line) + (setq untracked t)) + (when (looking-at "^Submodule [^ ]+ contains modified content$") + (magit-delete-line) + (setq modified t)) + (cond + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ :]+\\)\\( (rewind)\\)?:$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module range rewind) nil + (magit-delete-line) + (while (looking-at "^ \\([<>]\\) \\(.*\\)$") + (magit-delete-line)) + (when rewind + (setq range (replace-regexp-in-string "[^.]\\(\\.\\.\\)[^.]" + "..." range t t 1))) + (magit-insert-section (module module t) + (magit-insert-heading + (propertize (concat "modified " module) + 'font-lock-face 'magit-diff-file-heading) + " (" + (cond (rewind "rewind") + ((string-search "..." range) "non-ff") + (t "new commits")) + (and (or modified untracked) + (concat ", " + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content")) + ")") + (magit-insert-section-body + (let ((default-directory + (file-name-as-directory + (expand-file-name module (magit-toplevel))))) + (magit-git-wash (apply-partially #'magit-log-wash-log 'module) + "log" "--oneline" "--left-right" range) + (delete-char -1)))))) + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ ]+\\) (\\([^)]+\\))$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module _range msg) nil + (magit-delete-line) + (magit-insert-section (module module) + (magit-insert-heading + (propertize (concat "submodule " module) + 'font-lock-face 'magit-diff-file-heading) + " (" msg ")")))) + (t + (magit-insert-section (module module) + (magit-insert-heading + (propertize (concat "modified " module) + 'font-lock-face 'magit-diff-file-heading) + " (" + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content)"))))))) + +(defun magit-diff-wash-hunk () + (when (looking-at "^@\\{2,\\} \\(.+?\\) @\\{2,\\}\\(?: \\(.*\\)\\)?") + (let* ((heading (match-string 0)) + (ranges (mapcar + (lambda (str) + (let ((range + (mapcar #'string-to-number + (split-string (substring str 1) ",")))) + ;; A single line is +1 rather than +1,1. + (if (length= range 1) + (nconc range (list 1)) + range))) + (split-string (match-string 1)))) + (about (match-string 2)) + (combined (length= ranges 3)) + (value (cons about ranges))) + (magit-delete-line) + (magit-insert-section + ( hunk value nil + :washer #'magit-diff-paint-hunk + :combined combined + :from-range (if combined (butlast ranges) (car ranges)) + :to-range (car (last ranges)) + :about about) + (insert (propertize (concat heading "\n") + 'font-lock-face 'magit-diff-hunk-heading)) + (magit-insert-heading) + (while (not (or (eobp) (looking-at "^[^-+\s\\]"))) + (forward-line)))) + t)) + +(defun magit-diff-expansion-threshold (section) + "Keep new diff sections collapsed if washing takes too long." + (and (magit-file-section-p section) + (> (float-time (time-since magit-refresh-start-time)) + magit-diff-expansion-threshold) + 'hide)) + +(add-hook 'magit-section-set-visibility-hook #'magit-diff-expansion-threshold) + +;;; Revision Mode + +(define-derived-mode magit-revision-mode magit-diff-mode "Magit Rev" + "Mode for looking at a Git commit. + +This mode is documented in info node `(magit)Revision Buffer'. + +\\<magit-mode-map>\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\<magit-hunk-section-map>Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-revision-mode-map}" + :interactive nil + :group 'magit-revision + (magit-hack-dir-local-variables)) + +(put 'magit-revision-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-revision-setup-buffer (rev args files) + (magit-setup-buffer #'magit-revision-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)) + (magit-buffer-diff-type 'committed) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files) + (magit-buffer-diff-files-suspended nil))) + +(defun magit-revision-refresh-buffer () + (setq magit-buffer-revision-hash (magit-rev-hash magit-buffer-revision)) + (magit-set-header-line-format + (concat (magit-object-type magit-buffer-revision-hash) + " " magit-buffer-revision + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " limited to file " (car magit-buffer-diff-files))) + (_ (concat " limited to files " + (string-join magit-buffer-diff-files ", ")))))) + (magit-insert-section (commitbuf) + (magit-run-section-hook 'magit-revision-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-revision-mode)) + (cons magit-buffer-revision magit-buffer-diff-files)) + +(defun magit-insert-revision-diff () + "Insert the diff into this `magit-revision-mode' buffer." + (magit--insert-diff t + "show" "-p" "--format=" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-diff-args + (magit--rev-dereference magit-buffer-revision) + "--" magit-buffer-diff-files)) + +(defun magit-insert-revision-tag () + "Insert tag message and headers into a revision buffer. +This function only inserts anything when `magit-show-commit' is +called with a tag as argument, when that is called with a commit +or a ref which is not a branch, then it inserts nothing." + (when (equal (magit-object-type magit-buffer-revision) "tag") + (magit-insert-section (taginfo) + (let ((beg (point))) + ;; "git verify-tag -v" would output what we need, but the gpg + ;; output is send to stderr and we have no control over the + ;; order in which stdout and stderr are inserted, which would + ;; make parsing hard. We are forced to use "git cat-file tag" + ;; instead, which inserts the signature instead of verifying + ;; it. We remove that later and then insert the verification + ;; output using "git verify-tag" (without the "-v"). + (magit-git-insert "cat-file" "tag" magit-buffer-revision) + (goto-char beg) + (forward-line 3) + (delete-region beg (point))) + (looking-at "^tagger \\([^<]+\\) <\\([^>]+\\)") + (let ((heading (format "Tagger: %s <%s>" + (match-string 1) + (match-string 2)))) + (magit-delete-line) + (insert (propertize heading 'font-lock-face + 'magit-section-secondary-heading))) + (magit-insert-heading) + (forward-line) + (magit-insert-section + ( message nil nil + :heading-highlight-face 'magit-diff-revision-summary-highlight) + (let ((beg (point))) + (forward-line) + (magit--add-face-text-property + beg (point) 'magit-diff-revision-summary)) + (magit-insert-heading) + (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max))) + (insert ?\n)) + (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) + (progn + (let ((beg (match-beginning 0))) + (re-search-forward "-----END PGP SIGNATURE-----\n") + (delete-region beg (point))) + (save-excursion + (magit-process-git t "verify-tag" magit-buffer-revision)) + (magit-diff-wash-signature magit-buffer-revision)) + (goto-char (point-max))) + (insert ?\n)))) + +(defvar-keymap magit-commit-message-section-map + :doc "Keymap for `commit-message' sections." + "<remap> <magit-visit-thing>" #'magit-show-commit + "<1>" (magit-menu-item "Visit %t" #'magit-show-commit + '(:enable (magit-thing-at-point 'git-revision t)))) + +(defun magit-insert-revision-message () + "Insert the commit message into a revision buffer." + (magit-insert-section + ( commit-message nil nil + :heading-highlight-face 'magit-diff-revision-summary-highlight) + (if-let* ((rev magit-buffer-revision) + (msg (with-temp-buffer + (save-excursion (magit-rev-insert-format "%B" rev)) + (magit-revision--wash-message)))) + (progn + (save-excursion (insert msg)) + (magit-revision--wash-message-hashes) + (save-excursion + (magit--add-face-text-property (point) + (progn (forward-line) (point)) + 'magit-diff-revision-summary) + (magit-insert-heading)) + (goto-char (point-max))) + (insert "(no message)\n")))) + +(defun magit-insert-revision-notes () + "Insert commit notes into a revision buffer." + (let ((default (or (magit-get "core.notesRef") "refs/notes/commits"))) + (dolist (ref (magit-list-active-notes-refs)) + (when-let* ((rev magit-buffer-revision) + (msg (with-temp-buffer + (save-excursion + (magit-git-insert "-c" (concat "core.notesRef=" ref) + "notes" "show" rev)) + (magit-revision--wash-message)))) + (magit-insert-section + ( notes ref (not (equal ref default)) + :heading-highlight-face 'magit-diff-hunk-heading-highlight) + (save-excursion (insert msg)) + (magit-revision--wash-message-hashes) + (save-excursion + (end-of-line) + (insert (format " (%s)" + (propertize (if (string-prefix-p "refs/notes/" ref) + (substring ref 11) + ref) + 'font-lock-face 'magit-refname)))) + (magit--add-face-text-property (point) + (progn (forward-line) (point)) + 'magit-diff-revision-summary) + (magit-insert-heading) + (goto-char (point-max)) + (insert ?\n)))))) + +(defun magit-revision--wash-message () + (let ((major-mode 'git-commit-mode)) + (hack-dir-local-variables) + (hack-local-variables-apply)) + (unless (memq git-commit-major-mode '(nil text-mode)) + (funcall git-commit-major-mode) + (font-lock-ensure)) + (when (> (point-max) (point-min)) + (save-excursion + (while (search-forward "\r\n" nil t) ; Remove trailing CRs. + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + (when magit-revision-fill-summary-line + (let ((fill-column (min magit-revision-fill-summary-line + (window-width (get-buffer-window nil t))))) + (fill-region (point) (line-end-position)))) + (when magit-diff-highlight-keywords + (save-excursion + (while (re-search-forward "\\[[^[]*\\]" nil t) + (put-text-property (match-beginning 0) + (match-end 0) + 'font-lock-face 'magit-keyword)))) + (run-hook-wrapped 'magit-wash-message-hook + (lambda (fn) (save-excursion (funcall fn)))) + (buffer-string))) + +(defun magit-revision--wash-message-hashes () + (when magit-revision-use-hash-sections + (save-excursion + ;; Start after beg to prevent a (commit text) section from + ;; starting at the same point as the (commit-message) + ;; section. + (while (not (eobp)) + (re-search-forward "\\_<" nil 'move) + (let ((beg (point))) + (re-search-forward "\\_>" nil t) + (when (> (point) beg) + (let ((text (buffer-substring-no-properties beg (point)))) + (when (pcase magit-revision-use-hash-sections + ('quickest ; false negatives and positives + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (string-match-p "[a-z]" text))) + ('quicker ; false negatives (number-less hashes) + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (magit-commit-p text))) + ('quick ; false negatives (short hashes) + (and (>= (length text) 7) + (magit-commit-p text))) + ('slow + (magit-commit-p text))) + (put-text-property beg (point) + 'font-lock-face 'magit-hash) + (let ((end (point))) + (goto-char beg) + (magit-insert-section (commit text) + (goto-char end))))))))))) + +(defun magit-insert-revision-headers () + "Insert headers about the commit into a revision buffer." + (magit-insert-section (headers) + (when-let ((string (magit-rev-format "%D" magit-buffer-revision + "--decorate=full"))) + (insert (magit-format-ref-labels string) ?\s)) + (insert (propertize + (magit-rev-parse (magit--rev-dereference magit-buffer-revision)) + 'font-lock-face 'magit-hash)) + (magit-insert-heading) + (let ((beg (point))) + (magit-rev-insert-format magit-revision-headers-format + magit-buffer-revision) + (magit-insert-revision-gravatars magit-buffer-revision beg)) + (when magit-revision-insert-related-refs + (when (magit-revision-insert-related-refs-display-p 'parents) + (dolist (parent (magit-commit-parents magit-buffer-revision)) + (magit-insert-section (commit parent) + (let ((line (magit-rev-format "%h %s" parent))) + (string-match "^\\([^ ]+\\) \\(.*\\)" line) + (magit-bind-match-strings (hash msg) line + (insert "Parent: ") + (insert (propertize hash 'font-lock-face 'magit-hash)) + (insert " " msg "\n")))))) + (when (magit-revision-insert-related-refs-display-p 'merged) + (magit--insert-related-refs + magit-buffer-revision "--merged" "Merged" + (eq magit-revision-insert-related-refs 'all))) + (when (magit-revision-insert-related-refs-display-p 'contained) + (magit--insert-related-refs + magit-buffer-revision "--contains" "Contained" + (memq magit-revision-insert-related-refs '(all mixed)))) + (when-let (((magit-revision-insert-related-refs-display-p 'follows)) + (follows (magit-get-current-tag magit-buffer-revision t))) + (let ((tag (car follows)) + (cnt (cadr follows))) + (magit-insert-section (tag tag) + (insert + (format "Follows: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-branch-local)))))) + (when-let (((magit-revision-insert-related-refs-display-p 'precedes)) + (precedes (magit-get-next-tag magit-buffer-revision t))) + (let ((tag (car precedes)) + (cnt (cadr precedes))) + (magit-insert-section (tag tag) + (insert (format "Precedes: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-tag)))))) + (insert ?\n)))) + +(defun magit-revision-insert-related-refs-display-p (sym) + "Whether to display related branches of type SYM. +Refer to user option `magit-revision-insert-related-refs-display-alist'." + (if-let ((elt (assq sym magit-revision-insert-related-refs-display-alist))) + (cdr elt) + t)) + +(defun magit--insert-related-refs (rev arg title remote) + (when-let ((refs (magit-list-related-branches arg rev (and remote "-a")))) + (insert title ":" (make-string (- 10 (length title)) ?\s)) + (dolist (branch refs) + (if (<= (+ (current-column) 1 (length branch)) + (window-width)) + (insert ?\s) + (insert ?\n (make-string 12 ?\s))) + (magit-insert-section (branch branch) + (insert (propertize branch 'font-lock-face + (if (string-prefix-p "remotes/" branch) + 'magit-branch-remote + 'magit-branch-local))))) + (insert ?\n))) + +(defun magit-insert-revision-gravatars (rev beg) + (when (and magit-revision-show-gravatars + (window-system)) + (require 'gravatar) + (pcase-let ((`(,author . ,committer) + (pcase magit-revision-show-gravatars + ('t '("^Author: " . "^Commit: ")) + ('author '("^Author: " . nil)) + ('committer '(nil . "^Commit: ")) + (_ magit-revision-show-gravatars)))) + (when-let ((email (and author (magit-rev-format "%aE" rev)))) + (magit-insert-revision-gravatar beg rev email author)) + (when-let ((email (and committer (magit-rev-format "%cE" rev)))) + (magit-insert-revision-gravatar beg rev email committer))))) + +(defun magit-insert-revision-gravatar (beg rev email regexp) + (save-excursion + (goto-char beg) + (when-let (((re-search-forward regexp nil t)) + (window (get-buffer-window))) + (let* ((column (length (match-string 0))) + (font-obj (query-font (font-at (point) window))) + (size (* 2 (+ (aref font-obj 4) + (aref font-obj 5)))) + (align-to (+ column + (ceiling (/ size (aref font-obj 7) 1.0)) + 1)) + (gravatar-size (- size 2))) + (ignore-errors ; service may be unreachable + (gravatar-retrieve email #'magit-insert-revision-gravatar-cb + (list gravatar-size rev + (point-marker) + align-to column))))))) + +(defun magit-insert-revision-gravatar-cb (image size rev marker align-to column) + (unless (eq image 'error) + (when-let ((buffer (marker-buffer marker))) + (with-current-buffer buffer + (save-excursion + (goto-char marker) + ;; The buffer might display another revision by now or + ;; it might have been refreshed, in which case another + ;; process might already have inserted the image. + (when (and (equal rev magit-buffer-revision) + (not (eq (car-safe + (car-safe + (get-text-property (point) 'display))) + 'image))) + (setf (image-property image :ascent) 'center) + (setf (image-property image :relief) 1) + (setf (image-property image :scale) 1) + (setf (image-property image :height) size) + (let ((top (list image '(slice 0.0 0.0 1.0 0.5))) + (bot (list image '(slice 0.0 0.5 1.0 1.0))) + (align `((space :align-to ,align-to)))) + (let ((inhibit-read-only t)) + (insert (propertize " " 'display top)) + (insert (propertize " " 'display align)) + (forward-line) + (forward-char column) + (insert (propertize " " 'display bot)) + (insert (propertize " " 'display align)))))))))) + +;;; Merge-Preview Mode + +(define-derived-mode magit-merge-preview-mode magit-diff-mode "Magit Merge" + "Mode for previewing a merge." + :interactive nil + :group 'magit-diff + (magit-hack-dir-local-variables)) + +(put 'magit-merge-preview-mode 'magit-diff-default-arguments + '("--no-ext-diff")) + +(defun magit-merge-preview-setup-buffer (rev) + (magit-setup-buffer #'magit-merge-preview-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)))) + +(defun magit-merge-preview-refresh-buffer () + (let* ((branch (magit-get-current-branch)) + (head (or branch (magit-rev-verify "HEAD")))) + (magit-set-header-line-format (format "Preview merge of %s into %s" + magit-buffer-revision + (or branch "HEAD"))) + (magit-insert-section (diffbuf) + (magit--insert-diff t + "merge-tree" (magit-git-string "merge-base" head magit-buffer-revision) + head magit-buffer-revision)))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-merge-preview-mode)) + magit-buffer-revision) + +;;; Hunk Section + +(defun magit-hunk-set-window-start (section) + "When SECTION is a `hunk', ensure that its beginning is visible. +It the SECTION has a different type, then do nothing." + (when (magit-hunk-section-p section) + (magit-section-set-window-start section))) + +(add-hook 'magit-section-movement-hook #'magit-hunk-set-window-start) + +(cl-defmethod magit-section-get-relative-position ((_section magit-hunk-section)) + (nconc (cl-call-next-method) + (and (region-active-p) + (progn + (goto-char (line-beginning-position)) + (when (looking-at "^[-+]") (forward-line)) + (while (looking-at "^[ @]") (forward-line)) + (let ((beg (magit-point))) + (list (cond + ((looking-at "^[-+]") + (forward-line) + (while (looking-at "^[-+]") (forward-line)) + (while (looking-at "^ ") (forward-line)) + (forward-line -1) + (regexp-quote (buffer-substring-no-properties + beg (line-end-position)))) + (t t)))))))) + +(cl-defmethod magit-section-goto-successor ((section magit-hunk-section) + line char &optional arg) + (or (magit-section-goto-successor--same section line char) + (and-let* ((parent (magit-get-section + (magit-section-ident + (oref section parent))))) + (let* ((children (oref parent children)) + (siblings (magit-section-siblings section 'prev)) + (previous (nth (length siblings) children))) + (if (not arg) + (when-let ((sibling (or previous (car (last children))))) + (magit-section-goto sibling) + t) + (when previous + (magit-section-goto previous)) + (if (and (stringp arg) + (re-search-forward arg (oref parent end) t)) + (goto-char (match-beginning 0)) + (goto-char (oref (car (last children)) end)) + (forward-line -1) + (while (looking-at "^ ") (forward-line -1)) + (while (looking-at "^[-+]") (forward-line -1)) + (forward-line))))) + (magit-section-goto-successor--related section))) + +;;; Diff Sections + +(defvar-keymap magit-unstaged-section-map + :doc "Keymap for the `unstaged' section." + "<remap> <magit-visit-thing>" #'magit-diff-unstaged + "<remap> <magit-stage-file>" #'magit-stage + "<remap> <magit-delete-thing>" #'magit-discard + "<3>" (magit-menu-item "Discard all" #'magit-discard) + "<2>" (magit-menu-item "Stage all" #'magit-stage) + "<1>" (magit-menu-item "Visit diff" #'magit-diff-unstaged)) + +(magit-define-section-jumper magit-jump-to-unstaged + "Unstaged changes" unstaged nil magit-insert-unstaged-changes) + +(defun magit-insert-unstaged-changes () + "Insert section showing unstaged changes." + (magit-insert-section (unstaged) + (magit-insert-heading t "Unstaged changes") + (magit--insert-diff nil + "diff" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files))) + +(defvar-keymap magit-staged-section-map + :doc "Keymap for the `staged' section." + "<remap> <magit-revert-no-commit>" #'magit-reverse + "<remap> <magit-delete-thing>" #'magit-discard + "<remap> <magit-unstage-file>" #'magit-unstage + "<remap> <magit-visit-thing>" #'magit-diff-staged + "<4>" (magit-menu-item "Reverse all" #'magit-reverse) + "<3>" (magit-menu-item "Discard all" #'magit-discard) + "<2>" (magit-menu-item "Unstage all" #'magit-unstage) + "<1>" (magit-menu-item "Visit diff" #'magit-diff-staged)) + +(magit-define-section-jumper magit-jump-to-staged + "Staged changes" staged nil magit-insert-staged-changes) + +(defun magit-insert-staged-changes () + "Insert section showing staged changes." + ;; Avoid listing all files as deleted when visiting a bare repo. + (unless (magit-bare-repo-p) + (magit-insert-section (staged) + (magit-insert-heading t "Staged changes") + (magit--insert-diff nil + "diff" "--cached" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files)))) + +;;; Diff Type + +(defvar magit--diff-use-recorded-type-p t) + +(defun magit-diff-type (&optional section) + "Return the diff type of SECTION. + +The returned type is one of the symbols `staged', `unstaged', +`committed', or `undefined'. This type serves a similar purpose +as the general type common to all sections (which is stored in +the `type' slot of the corresponding `magit-section' struct) but +takes additional information into account. When the SECTION +isn't related to diffs and the buffer containing it also isn't +a diff-only buffer, then return nil. + +Currently the type can also be one of `tracked' and `untracked' +but these values are not handled explicitly everywhere they +should be and a possible fix could be to just return nil here. + +The section has to be a `diff' or `hunk' section, or a section +whose children are of type `diff'. If optional SECTION is nil, +return the diff type for the current section. In buffers whose +major mode is `magit-diff-mode' SECTION is ignored and the type +is determined using other means. In `magit-revision-mode' +buffers the type is always `committed'. + +Do not confuse this with `magit-diff-scope' (which see)." + (when-let ((section (or section (magit-current-section)))) + (cond ((derived-mode-p 'magit-revision-mode 'magit-stash-mode) 'committed) + ((derived-mode-p 'magit-diff-mode) + (let ((range magit-buffer-range) + (const magit-buffer-typearg)) + (cond ((and magit--diff-use-recorded-type-p + magit-buffer-diff-type)) + ((equal const "--no-index") 'undefined) + ((or (not range) + (equal range "HEAD") + (magit-rev-eq range "HEAD")) + (if (equal const "--cached") + 'staged + 'unstaged)) + ((equal const "--cached") + (if (magit-rev-head-p range) + 'staged + 'undefined)) ; i.e., committed and staged + (t 'committed)))) + ((derived-mode-p 'magit-status-mode) + (let ((stype (oref section type))) + (if (memq stype '(staged unstaged tracked untracked)) + stype + (pcase stype + ((or 'file 'module) + (let* ((parent (oref section parent)) + (type (oref parent type))) + (if (memq type '(file module)) + (magit-diff-type parent) + type))) + ('hunk (thread-first section + (oref parent) + (oref parent) + (oref type))))))) + ((derived-mode-p 'magit-log-mode) + (if (or (and (magit-section-match 'commit section) + (oref section children)) + (magit-section-match [* file commit] section)) + 'committed + 'undefined)) + (t 'undefined)))) + +(cl-defun magit-diff-scope (&optional (section nil ssection) strict) + "Return the diff scope of SECTION or the selected section(s). + +A diff's \"scope\" describes what part of a diff is selected, it is +a symbol, one of `region', `hunk', `hunks', `file', `files', or +`list'. Do not confuse this with the diff \"type\", as returned by +`magit-diff-type'. + +If optional SECTION is non-nil, then return the scope of that, +ignoring the sections selected by the region. Otherwise return +the scope of the current section, or if the region is active and +selects a valid group of diff related sections, the type of these +sections, i.e., `hunks' or `files'. If SECTION, or if that is nil +the current section, is a `hunk' section; and the region region +starts and ends inside the body of a that section, then the type +is `region'. If the region is empty after a mouse click, then +`hunk' is returned instead of `region'. + +If optional STRICT is non-nil, then return nil if the diff type of +the section at point is `untracked' or the section at point is not +actually a `diff' but a `diffstat' section." + (let ((siblings (and (not ssection) (magit-region-sections nil t)))) + (setq section (or section (car siblings) (magit-current-section))) + (when (and section + (or (not strict) + (and (not (eq (magit-diff-type section) 'untracked)) + (not (eq (and-let* ((parent (oref section parent))) + (oref parent type)) + 'diffstat))))) + (pcase (list (oref section type) + (and siblings t) + (magit-diff-use-hunk-region-p) + ssection) + (`(hunk nil t ,_) + (if (magit-section-internal-region-p section) 'region 'hunk)) + ('(hunk t t nil) 'hunks) + (`(hunk ,_ ,_ ,_) 'hunk) + ('(file t t nil) 'files) + (`(file ,_ ,_ ,_) 'file) + ('(module t t nil) 'files) + (`(module ,_ ,_ ,_) 'file) + (`(,(or 'staged 'unstaged 'untracked) nil ,_ ,_) 'list))))) + +(defun magit-diff-use-hunk-region-p () + (and (region-active-p) + ;; TODO implement this from first principals + ;; currently it's trial-and-error + (not (and (or (eq this-command #'mouse-drag-region) + (eq last-command #'mouse-drag-region) + ;; When another window was previously + ;; selected then the last-command is + ;; some byte-code function. + (byte-code-function-p last-command)) + (eq (region-end) (region-beginning)))))) + +;;; Diff Highlight + +(add-hook 'magit-section-unhighlight-hook #'magit-diff-unhighlight) +(add-hook 'magit-section-highlight-hook #'magit-diff-highlight) + +(defun magit-diff-unhighlight (section selection) + "Remove the highlighting of the diff-related SECTION." + (when (magit-hunk-section-p section) + (magit-diff-paint-hunk section selection nil) + t)) + +(defun magit-diff-highlight (section selection) + "Highlight the diff-related SECTION. +If SECTION is not a diff-related section, then do nothing and +return nil. If SELECTION is non-nil, then it is a list of sections +selected by the region, including SECTION. All of these sections +are highlighted." + (if (and (magit-section-match 'commit section) + (oref section children)) + (progn (if selection + (dolist (section selection) + (magit-diff-highlight-list section selection)) + (magit-diff-highlight-list section)) + t) + (when-let ((scope (magit-diff-scope section t))) + (cond ((eq scope 'region) + (magit-diff-paint-hunk section selection t)) + (selection + (dolist (section selection) + (magit-diff-highlight-recursive section selection))) + (t + (magit-diff-highlight-recursive section))) + t))) + +(defun magit-diff-highlight-recursive (section &optional selection) + (pcase (magit-diff-scope section) + ('list (magit-diff-highlight-list section selection)) + ('file (magit-diff-highlight-file section selection)) + ('hunk (magit-diff-highlight-heading section selection) + (magit-diff-paint-hunk section selection t)) + (_ (magit-section-highlight section nil)))) + +(defun magit-diff-highlight-list (section &optional selection) + (if (oref section children) + (let ((beg (oref section start)) + (cnt (oref section content)) + (end (oref section end))) + (when (or (eq this-command #'mouse-drag-region) + (not selection)) + (unless (and (region-active-p) + (<= (region-beginning) beg)) + (magit-section-make-overlay beg cnt 'magit-section-highlight)) + (if (oref section hidden) + (oset section washer #'ignore) + (dolist (child (oref section children)) + (when (or (eq this-command #'mouse-drag-region) + (not (and (region-active-p) + (<= (region-beginning) + (oref child start))))) + (magit-diff-highlight-recursive child selection))))) + (when magit-diff-highlight-hunk-body + (magit-section-make-overlay (1- end) end 'magit-section-highlight))) + (magit-section-highlight section nil))) + +(defun magit-diff-highlight-file (section &optional selection) + (magit-diff-highlight-heading section selection) + (when (or (not (oref section hidden)) + (cl-typep section 'magit-module-section)) + (dolist (child (oref section children)) + (magit-diff-highlight-recursive child selection)))) + +(defun magit-diff-highlight-heading (section &optional selection) + (magit-section-make-overlay + (oref section start) + (or (oref section content) + (oref section end)) + (pcase (list (oref section type) + (and (member section selection) + (not (eq this-command #'mouse-drag-region)))) + ('(file t) 'magit-diff-file-heading-selection) + ('(file nil) 'magit-diff-file-heading-highlight) + ('(module t) 'magit-diff-file-heading-selection) + ('(module nil) 'magit-diff-file-heading-highlight) + ('(hunk t) 'magit-diff-hunk-heading-selection) + ('(hunk nil) 'magit-diff-hunk-heading-highlight)))) + +;;; Hunk Paint + +(cl-defun magit-diff-paint-hunk + (section &optional selection + (highlight (magit-section-selected-p section selection))) + (let (paint) + (unless magit-diff-highlight-hunk-body + (setq highlight nil)) + (cond (highlight + (unless (oref section hidden) + (add-to-list 'magit-section-highlighted-sections section) + (cond ((memq section magit-section-unhighlight-sections) + (setq magit-section-unhighlight-sections + (delq section magit-section-unhighlight-sections))) + (magit-diff-highlight-hunk-body + (setq paint t))))) + (t + (cond ((and (oref section hidden) + (memq section magit-section-unhighlight-sections)) + (add-to-list 'magit-section-highlighted-sections section) + (setq magit-section-unhighlight-sections + (delq section magit-section-unhighlight-sections))) + (t + (setq paint t))))) + (when paint + (save-excursion + (goto-char (oref section start)) + (let ((end (oref section end)) + (merging (looking-at "@@@")) + (diff-type (magit-diff-type)) + (stage nil) + (tab-width (magit-diff-tab-width + (magit-section-parent-value section)))) + (forward-line) + (while (< (point) end) + (when (and magit-diff-hide-trailing-cr-characters + (char-equal ?\r (char-before (line-end-position)))) + (put-text-property (1- (line-end-position)) (line-end-position) + 'invisible t)) + (put-text-property + (point) (1+ (line-end-position)) 'font-lock-face + (cond + ((looking-at "^\\+\\+?\\([<=|>]\\)\\{7\\}") + (setq stage (pcase (list (match-string 1) highlight) + ('("<" nil) 'magit-diff-our) + ('("<" t) 'magit-diff-our-highlight) + ('("|" nil) 'magit-diff-base) + ('("|" t) 'magit-diff-base-highlight) + ('("=" nil) 'magit-diff-their) + ('("=" t) 'magit-diff-their-highlight) + ('(">" nil) nil))) + 'magit-diff-conflict-heading) + ((looking-at (if merging "^\\(\\+\\| \\+\\)" "^\\+")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'added diff-type) + (or stage + (if highlight 'magit-diff-added-highlight 'magit-diff-added))) + ((looking-at (if merging "^\\(-\\| -\\)" "^-")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'removed diff-type) + (if highlight 'magit-diff-removed-highlight 'magit-diff-removed)) + (t + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'context diff-type) + (if highlight 'magit-diff-context-highlight 'magit-diff-context)))) + (forward-line)))))) + (magit-diff-update-hunk-refinement section)) + +(defvar magit-diff--tab-width-cache nil) + +(defun magit-diff-tab-width (file) + (setq file (expand-file-name file)) + (cl-flet ((cache (value) + (let ((elt (assoc file magit-diff--tab-width-cache))) + (if elt + (setcdr elt value) + (setq magit-diff--tab-width-cache + (cons (cons file value) + magit-diff--tab-width-cache)))) + value)) + (cond + ((not magit-diff-adjust-tab-width) + tab-width) + ((and-let* ((buffer (find-buffer-visiting file))) + (cache (buffer-local-value 'tab-width buffer)))) + ((and-let* ((elt (assoc file magit-diff--tab-width-cache))) + (or (cdr elt) + tab-width))) + ((or (eq magit-diff-adjust-tab-width 'always) + (and (numberp magit-diff-adjust-tab-width) + (>= magit-diff-adjust-tab-width + (nth 7 (file-attributes file))))) + (cache (buffer-local-value 'tab-width (find-file-noselect file)))) + (t + (cache nil) + tab-width)))) + +(defun magit-diff-paint-tab (merging width) + (save-excursion + (forward-char (if merging 2 1)) + (while (= (char-after) ?\t) + (put-text-property (point) (1+ (point)) + 'display (list (list 'space :width width))) + (forward-char)))) + +(defun magit-diff-paint-whitespace (merging line-type diff-type) + (when (and magit-diff-paint-whitespace + (or (not (memq magit-diff-paint-whitespace '(uncommitted status))) + (memq diff-type '(staged unstaged))) + (cl-case line-type + (added t) + (removed (memq magit-diff-paint-whitespace-lines '(all both))) + (context (memq magit-diff-paint-whitespace-lines '(all))))) + (let ((prefix (if merging "^[-\\+\s]\\{2\\}" "^[-\\+\s]")) + (indent + (if (local-variable-p 'magit-diff-highlight-indentation) + magit-diff-highlight-indentation + (setq-local + magit-diff-highlight-indentation + (cdr (--first (string-match-p (car it) default-directory) + (nreverse + (default-value + 'magit-diff-highlight-indentation)))))))) + (when (and magit-diff-highlight-trailing + (looking-at (concat prefix ".*?\\([ \t]+\\)?$"))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t))) + (when (or (and (eq indent 'tabs) + (looking-at (concat prefix "\\( *\t[ \t]*\\)"))) + (and (integerp indent) + (looking-at (format "%s\\([ \t]* \\{%s,\\}[ \t]*\\)" + prefix indent)))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t)))))) + +(defun magit-diff-update-hunk-refinement (&optional section) + (if section + (unless (oref section hidden) + (pcase (list magit-diff-refine-hunk + (oref section refined) + (eq section (magit-current-section))) + ((or `(all nil ,_) '(t nil t)) + (oset section refined t) + (save-excursion + (goto-char (oref section start)) + ;; `diff-refine-hunk' does not handle combined diffs. + (unless (looking-at "@@@") + (let ((smerge-refine-ignore-whitespace + magit-diff-refine-ignore-whitespace) + ;; Avoid fsyncing many small temp files + (write-region-inhibit-fsync t)) + (diff-refine-hunk))))) + ((or `(nil t ,_) '(t t nil)) + (oset section refined nil) + (remove-overlays (oref section start) + (oref section end) + 'diff-mode 'fine)))) + (cl-labels ((recurse (section) + (if (magit-section-match 'hunk section) + (magit-diff-update-hunk-refinement section) + (dolist (child (oref section children)) + (recurse child))))) + (recurse magit-root-section)))) + + +;;; Hunk Region + +(defun magit-diff-hunk-region-beginning () + (save-excursion (goto-char (region-beginning)) + (line-beginning-position))) + +(defun magit-diff-hunk-region-end () + (save-excursion (goto-char (region-end)) + (line-end-position))) + +(defun magit-diff-update-hunk-region (section) + "Highlight the hunk-internal region if any." + (when (and (eq (oref section type) 'hunk) + (eq (magit-diff-scope section t) 'region)) + (magit-diff--make-hunk-overlay + (oref section start) + (1- (oref section content)) + 'font-lock-face 'magit-diff-lines-heading + 'display (magit-diff-hunk-region-header section) + 'after-string (magit-diff--hunk-after-string 'magit-diff-lines-heading)) + (run-hook-with-args 'magit-diff-highlight-hunk-region-functions section) + t)) + +(defun magit-diff-highlight-hunk-region-dim-outside (section) + "Dim the parts of the hunk that are outside the hunk-internal region. +This is done by using the same foreground and background color +for added and removed lines as for context lines." + (let ((face (if magit-diff-highlight-hunk-body + 'magit-diff-context-highlight + 'magit-diff-context))) + (when magit-diff-unmarked-lines-keep-foreground + (setq face `(,@(and (>= emacs-major-version 27) '(:extend t)) + :background ,(face-attribute face :background)))) + (magit-diff--make-hunk-overlay (oref section content) + (magit-diff-hunk-region-beginning) + 'font-lock-face face + 'priority 2) + (magit-diff--make-hunk-overlay (1+ (magit-diff-hunk-region-end)) + (oref section end) + 'font-lock-face face + 'priority 2))) + +(defun magit-diff-highlight-hunk-region-using-face (_section) + "Highlight the hunk-internal region by making it bold. +Or rather highlight using the face `magit-diff-hunk-region', though +changing only the `:weight' and/or `:slant' is recommended for that +face." + (magit-diff--make-hunk-overlay (magit-diff-hunk-region-beginning) + (1+ (magit-diff-hunk-region-end)) + 'font-lock-face 'magit-diff-hunk-region)) + +(defun magit-diff-highlight-hunk-region-using-overlays (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented as single-pixel newlines places inside overlays." + (if (window-system) + (let ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (str (propertize + (concat (propertize "\s" 'display '(space :height (1))) + (propertize "\n" 'line-height t)) + 'font-lock-face 'magit-diff-lines-boundary))) + (magit-diff--make-hunk-overlay beg (1+ beg) 'before-string str) + (magit-diff--make-hunk-overlay end (1+ end) 'after-string str)) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff-highlight-hunk-region-using-underline (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented by overlining and underlining the first and +last (visual) lines of the region." + (if (window-system) + (let* ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (beg-eol (save-excursion (goto-char beg) + (end-of-visual-line) + (point))) + (end-bol (save-excursion (goto-char end) + (beginning-of-visual-line) + (point))) + (color (face-background 'magit-diff-lines-boundary nil t))) + (cl-flet ((ln (b e &rest face) + (magit-diff--make-hunk-overlay + b e 'font-lock-face face 'after-string + (magit-diff--hunk-after-string face)))) + (if (= beg end-bol) + (ln beg beg-eol :overline color :underline color) + (ln beg beg-eol :overline color) + (ln end-bol end :underline color)))) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff--make-hunk-overlay (start end &rest args) + (let ((ov (make-overlay start end nil t))) + (overlay-put ov 'evaporate t) + (while args (overlay-put ov (pop args) (pop args))) + (push ov magit-section--region-overlays) + ov)) + +(defun magit-diff--hunk-after-string (face) + (propertize "\s" + 'font-lock-face face + 'display (list 'space :align-to + `(+ (0 . right) + ,(min (window-hscroll) + (- (line-end-position) + (line-beginning-position))))) + ;; This prevents the cursor from being rendered at the + ;; edge of the window. + 'cursor t)) + +;;; Utilities + +(defun magit-diff-inside-hunk-body-p () + "Return non-nil if point is inside the body of a hunk." + (and (magit-section-match 'hunk) + (and-let* ((content (oref (magit-current-section) content))) + (> (magit-point) content)))) + +(defun magit-diff--combined-p (section) + (cl-assert (cl-typep section 'magit-file-section)) + (string-match-p "\\`diff --\\(combined\\|cc\\)" (oref section value))) + +;;; Diff Extract + +(defun magit-diff-file-header (section &optional no-rename) + (when (magit-hunk-section-p section) + (setq section (oref section parent))) + (and (magit-file-section-p section) + (let ((header (oref section header))) + (if no-rename + (replace-regexp-in-string + "^--- \\(.+\\)" (oref section value) header t t 1) + header)))) + +(defun magit-diff-hunk-region-header (section) + (let ((patch (magit-diff-hunk-region-patch section))) + (string-match "\n" patch) + (substring patch 0 (1- (match-end 0))))) + +(defun magit-diff-hunk-region-patch (section &optional args) + (let ((op (if (member "--reverse" args) "+" "-")) + (sbeg (oref section start)) + (rbeg (magit-diff-hunk-region-beginning)) + (rend (region-end)) + (send (oref section end)) + (patch nil)) + (save-excursion + (goto-char sbeg) + (while (< (point) send) + (looking-at "\\(.\\)\\([^\n]*\n\\)") + (cond ((or (string-match-p "[@ ]" (match-string-no-properties 1)) + (and (>= (point) rbeg) + (<= (point) rend))) + (push (match-string-no-properties 0) patch)) + ((equal op (match-string-no-properties 1)) + (push (concat " " (match-string-no-properties 2)) patch))) + (forward-line))) + (let ((buffer-list-update-hook nil)) ; #3759 + (with-temp-buffer + (insert (string-join (reverse patch))) + (diff-fixup-modifs (point-min) (point-max)) + (setq patch (buffer-string)))) + patch)) + +;;; _ +(provide 'magit-diff) +;;; magit-diff.el ends here diff --git a/emacs/elpa/magit-20241116.1557/magit-diff.elc b/emacs/elpa/magit-20241116.1557/magit-diff.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-ediff.el b/emacs/elpa/magit-20241116.1557/magit-ediff.el diff --git a/emacs/elpa/magit-20241106.1441/magit-ediff.elc b/emacs/elpa/magit-20241116.1557/magit-ediff.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-extras.el b/emacs/elpa/magit-20241116.1557/magit-extras.el diff --git a/emacs/elpa/magit-20241106.1441/magit-extras.elc b/emacs/elpa/magit-20241116.1557/magit-extras.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-fetch.el b/emacs/elpa/magit-20241116.1557/magit-fetch.el diff --git a/emacs/elpa/magit-20241106.1441/magit-fetch.elc b/emacs/elpa/magit-20241116.1557/magit-fetch.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-files.el b/emacs/elpa/magit-20241116.1557/magit-files.el diff --git a/emacs/elpa/magit-20241106.1441/magit-files.elc b/emacs/elpa/magit-20241116.1557/magit-files.elc Binary files differ. diff --git a/emacs/elpa/magit-20241116.1557/magit-git.el b/emacs/elpa/magit-20241116.1557/magit-git.el @@ -0,0 +1,2903 @@ +;;; magit-git.el --- Git functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2024 The Magit Project Contributors + +;; Author: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> +;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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. +;; +;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements wrappers for various Git plumbing commands. + +;;; Code: + +(require 'magit-base) + +(require 'format-spec) + +;; From `magit-branch'. +(defvar magit-branch-prefer-remote-upstream) +(defvar magit-published-branches) + +;; From `magit-margin'. +(declare-function magit-maybe-make-margin-overlay "magit-margin" ()) + +;; From `magit-mode'. +(declare-function magit-get-mode-buffer "magit-mode" + (mode &optional value frame)) +(declare-function magit-refresh "magit-mode" ()) +(defvar magit-buffer-diff-type) +(defvar magit-buffer-diff-args) +(defvar magit-buffer-file-name) +(defvar magit-buffer-log-args) +(defvar magit-buffer-log-files) +(defvar magit-buffer-refname) +(defvar magit-buffer-revision) + +;; From `magit-process'. +(declare-function magit-call-git "magit-process" (&rest args)) +(declare-function magit-git "magit-process" (&rest args)) +(declare-function magit-process-buffer "magit-process" (&optional nodisplay)) +(declare-function magit-process-file "magit-process" + (process &optional infile buffer display &rest args)) +(declare-function magit-process-finish-section "magit-process" + (section exit-code)) +(declare-function magit-process-git "magit-process" (destination &rest args)) +(declare-function magit-process-insert-section "magit-process" + (pwd program args &optional errcode errlog face)) +(defvar magit-this-error) +(defvar magit-process-error-message-regexps) + +(eval-when-compile + (cl-pushnew 'orig-rev eieio--known-slot-names) + (cl-pushnew 'number eieio--known-slot-names)) + +;;; Options + +;; For now this is shared between `magit-process' and `magit-git'. +(defgroup magit-process nil + "Git and other external processes used by Magit." + :group 'magit) + +(defvar magit-git-environment + (list (format "INSIDE_EMACS=%s,magit" emacs-version)) + "Prepended to `process-environment' while running git.") + +(defcustom magit-git-output-coding-system + (and (eq system-type 'windows-nt) 'utf-8) + "Coding system for receiving output from Git. + +If non-nil, the Git config value `i18n.logOutputEncoding' should +be set via `magit-git-global-arguments' to value consistent with +this." + :package-version '(magit . "2.9.0") + :group 'magit-process + :type '(choice (coding-system :tag "Coding system to decode Git output") + (const :tag "Use system default" nil))) + +(defvar magit-git-w32-path-hack nil + "Alist of (EXE . (PATHENTRY)). +This specifies what additional PATH setting needs to be added to +the environment in order to run the non-wrapper git executables +successfully.") + +(defcustom magit-git-executable + (or (and (eq system-type 'windows-nt) + ;; Avoid the wrappers "cmd/git.exe" and "cmd/git.cmd", + ;; which are much slower than using "bin/git.exe" directly. + (and-let* ((exec (executable-find "git"))) + (ignore-errors + ;; Git for Windows 2.x provides cygpath so we can + ;; ask it for native paths. + (let* ((core-exe + (car + (process-lines + exec "-c" + "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" + "X" "git"))) + (hack-entry (assoc core-exe magit-git-w32-path-hack)) + ;; Running the libexec/git-core executable + ;; requires some extra PATH entries. + (path-hack + (list (concat "PATH=" + (car (process-lines + exec "-c" + "alias.P=!cygpath -wp \"$PATH\"" + "P")))))) + ;; The defcustom STANDARD expression can be + ;; evaluated many times, so make sure it is + ;; idempotent. + (if hack-entry + (setcdr hack-entry path-hack) + (push (cons core-exe path-hack) magit-git-w32-path-hack)) + core-exe)))) + (and (eq system-type 'darwin) + (executable-find "git")) + "git") + "The Git executable used by Magit on the local host. +On remote machines `magit-remote-git-executable' is used instead." + :package-version '(magit . "3.2.0") + :group 'magit-process + :type 'string) + +(defcustom magit-remote-git-executable "git" + "The Git executable used by Magit on remote machines. +On the local host `magit-git-executable' is used instead. +Consider customizing `tramp-remote-path' instead of this +option." + :package-version '(magit . "3.2.0") + :group 'magit-process + :type 'string) + +(defcustom magit-git-global-arguments + `("--no-pager" "--literal-pathspecs" + "-c" "core.preloadindex=true" + "-c" "log.showSignature=false" + "-c" "color.ui=false" + "-c" "color.diff=false" + ,@(and (eq system-type 'windows-nt) + (list "-c" "i18n.logOutputEncoding=UTF-8"))) + "Global Git arguments. + +The arguments set here are used every time the git executable is +run as a subprocess. They are placed right after the executable +itself and before the git command - as in `git HERE... COMMAND +REST'. See the manpage `git(1)' for valid arguments. + +Be careful what you add here, especially if you are using Tramp +to connect to servers with ancient Git versions. Never remove +anything that is part of the default value, unless you really +know what you are doing. And think very hard before adding +something; it will be used every time Magit runs Git for any +purpose." + :package-version '(magit . "2.9.0") + :group 'magit-commands + :group 'magit-process + :type '(repeat string)) + +(defcustom magit-prefer-remote-upstream nil + "Whether to favor remote branches when reading the upstream branch. + +This controls whether commands that read a branch from the user +and then set it as the upstream branch, offer a local or a remote +branch as default completion candidate, when they have the choice. + +This affects all commands that use `magit-read-upstream-branch' +or `magit-read-starting-point', which includes most commands +that change the upstream and many that create new branches." + :package-version '(magit . "2.4.2") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-list-refs-namespaces + '("refs/heads" + "refs/remotes" + "refs/tags" + "refs/pullreqs") + "List of ref namespaces considered when reading a ref. + +This controls the order of refs returned by `magit-list-refs', +which is called by functions like `magit-list-branch-names' to +generate the collection of refs." + :package-version '(magit . "3.1.0") + :group 'magit-commands + :type '(repeat string)) + +(defcustom magit-list-refs-sortby nil + "How to sort the ref collection in the prompt. + +This affects commands that read a ref. More specifically, it +controls the order of refs returned by `magit-list-refs', which +is called by functions like `magit-list-branch-names' to generate +the collection of refs. By default, refs are sorted according to +their full refname (i.e., \"refs/...\"). + +Any value accepted by the `--sort' flag of \"git for-each-ref\" can +be used. For example, \"-creatordate\" places refs with more +recent committer or tagger dates earlier in the list. A list of +strings can also be given in order to pass multiple sort keys to +\"git for-each-ref\". + +Note that, depending on the completion framework you use, this +may not be sufficient to change the order in which the refs are +displayed. It only controls the order of the collection passed +to `magit-completing-read' or, for commands that support reading +multiple strings, `read-from-minibuffer'. The completion +framework ultimately determines how the collection is displayed." + :package-version '(magit . "2.11.0") + :group 'magit-miscellaneous + :type '(choice string (repeat string))) + +;;; Git + +(defvar magit-git-debug nil + "Whether to enable additional reporting of git errors. + +Magit basically calls git for one of these two reasons: for +side-effects or to do something with its standard output. + +When git is run for side-effects then its output, including error +messages, go into the process buffer which is shown when using \ +\\<magit-status-mode-map>\\[magit-process-buffer]. + +When git's output is consumed in some way, then it would be too +expensive to also insert it into this buffer, but when this +option is non-nil and git returns with a non-zero exit status, +then at least its standard error is inserted into this buffer. + +This is only intended for debugging purposes. Do not enable this +permanently, that would negatively affect performance. Also note +that just because git exits with a non-zero exit status and prints +an error message that usually doesn't mean that it is an error as +far as Magit is concerned, which is another reason we usually hide +these error messages. Whether some error message is relevant in +the context of some unexpected behavior has to be judged on a case +by case basis. + +The command `magit-toggle-git-debug' changes the value of this +variable. + +Also see `magit-process-extreme-logging'.") + +(defun magit-toggle-git-debug () + "Toggle whether additional git errors are reported. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (setq magit-git-debug (not magit-git-debug)) + (message "Additional reporting of Git errors %s" + (if magit-git-debug "enabled" "disabled"))) + +(defvar magit--refresh-cache nil) + +(defmacro magit--with-refresh-cache (key &rest body) + (declare (indent 1) (debug (form body))) + (let ((k (cl-gensym)) + (hit (cl-gensym))) + `(if magit--refresh-cache + (let ((,k ,key)) + (if-let ((,hit (assoc ,k (cdr magit--refresh-cache)))) + (progn (cl-incf (caar magit--refresh-cache)) + (cdr ,hit)) + (cl-incf (cdar magit--refresh-cache)) + (let ((value ,(macroexp-progn body))) + (push (cons ,k value) + (cdr magit--refresh-cache)) + value))) + ,@body))) + +(defvar magit-with-editor-envvar "GIT_EDITOR" + "The environment variable exported by `magit-with-editor'. +Set this to \"GIT_SEQUENCE_EDITOR\" if you do not want to use +Emacs to edit commit messages but would like to do so to edit +rebase sequences.") + +(defmacro magit-with-editor (&rest body) + "Like `with-editor*' but let-bind some more variables. +Also respect the value of `magit-with-editor-envvar'." + (declare (indent 0) (debug (body))) + `(let ((magit-process-popup-time -1) + ;; The user may have customized `shell-file-name' to + ;; something which results in `w32-shell-dos-semantics' nil + ;; (which changes the quoting style used by + ;; `shell-quote-argument'), but Git for Windows expects shell + ;; quoting in the dos style. + (shell-file-name (if (and (eq system-type 'windows-nt) + ;; If we have Cygwin mount points, + ;; the git flavor is cygwin, so dos + ;; shell quoting is probably wrong. + (not magit-cygwin-mount-points)) + "cmdproxy" + shell-file-name))) + (with-editor* magit-with-editor-envvar + ,@body))) + +(defmacro magit--with-temp-process-buffer (&rest body) + "Like `with-temp-buffer', but always propagate `process-environment'. +When that var is buffer-local in the calling buffer, it is not +propagated by `with-temp-buffer', so we explicitly ensure that +happens, so that processes will be invoked consistently. BODY is +as for that macro." + (declare (indent 0) (debug (body))) + (let ((p (cl-gensym))) + `(let ((,p process-environment)) + (with-temp-buffer + (setq-local process-environment ,p) + ,@body)))) + +(defsubst magit-git-executable () + "Return value of `magit-git-executable' or `magit-remote-git-executable'. +The variable is chosen depending on whether `default-directory' +is remote." + (if (file-remote-p default-directory) + magit-remote-git-executable + magit-git-executable)) + +(defun magit-process-git-arguments (args) + "Prepare ARGS for a function that invokes Git. + +Magit has many specialized functions for running Git; they all +pass arguments through this function before handing them to Git, +to do the following. + +* Flatten ARGS, removing nil arguments. +* Prepend `magit-git-global-arguments' to ARGS. +* On w32 systems, encode to `w32-ansi-code-page'." + (setq args (append magit-git-global-arguments (flatten-tree args))) + (if (and (eq system-type 'windows-nt) (boundp 'w32-ansi-code-page)) + ;; On w32, the process arguments *must* be encoded in the + ;; current code-page (see #3250). + (mapcar (lambda (arg) + (encode-coding-string + arg (intern (format "cp%d" w32-ansi-code-page)))) + args) + args)) + +(defun magit-git-exit-code (&rest args) + "Execute Git with ARGS, returning its exit code." + (magit-process-git nil args)) + +(defun magit-git-success (&rest args) + "Execute Git with ARGS, returning t if its exit code is 0." + (= (magit-git-exit-code args) 0)) + +(defun magit-git-failure (&rest args) + "Execute Git with ARGS, returning t if its exit code is 1." + (= (magit-git-exit-code args) 1)) + +(defun magit-git-string-p (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then return +nil. Neither of these results is considered an error; if that is +what you want, then use `magit-git-string-ng' instead. + +This is an experimental replacement for `magit-git-string', and +still subject to major changes." + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (and (zerop (magit-process-git t args)) + (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position))))))) + +(defun magit-git-string-ng (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then that +is considered an error, but instead of actually signaling an +error, return nil. Additionally the output is put in the process +buffer (creating it if necessary) and the error message is shown +in the status buffer (provided it exists). + +This is an experimental replacement for `magit-git-string', and +still subject to major changes. Also see `magit-git-string-p'." + (magit--with-refresh-cache + (list default-directory 'magit-git-string-ng args) + (magit--with-temp-process-buffer + (let* ((args (magit-process-git-arguments args)) + (status (magit-process-git t args))) + (if (zerop status) + (and (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties + (point) (line-end-position)))) + (let ((buf (current-buffer))) + (with-current-buffer (magit-process-buffer t) + (magit-process-insert-section default-directory + magit-git-executable args + status buf + 'magit-section-secondary-heading))) + (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) + (let ((msg (magit--locate-error-message))) + (with-current-buffer status-buf + (setq magit-this-error msg)))) + nil))))) + +(defun magit-git-str (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string. Like `magit-git-string' but +ignore `magit-git-debug'." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (magit-process-git (list t nil) args) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-output (&rest args) + "Execute Git with ARGS, returning its output." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (magit-process-git (list t nil) args) + (buffer-substring-no-properties (point-min) (point-max))))) + +(define-error 'magit-invalid-git-boolean "Not a Git boolean") + +(defun magit-git-true (&rest args) + "Execute Git with ARGS, returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") t) + ((or "false" "false\n") nil) + (output (signal 'magit-invalid-git-boolean (list output))))) + +(defun magit-git-false (&rest args) + "Execute Git with ARGS, returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") nil) + ((or "false" "false\n") t) + (output (signal 'magit-invalid-git-boolean (list output))))) + +(defun magit-git-config-p (variable &optional default) + "Return the boolean value of the Git variable VARIABLE. +VARIABLE has to be specified as a string. Return DEFAULT (which +defaults to nil) if VARIABLE is unset. If VARIABLE's value isn't +a boolean, then raise an error." + (let ((args (list "config" "--bool" "--default" (if default "true" "false") + variable))) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (let ((status (magit-process-git t args)) + (output (buffer-substring (point-min) (1- (point-max))))) + (if (zerop status) + (equal output "true") + (signal 'magit-invalid-git-boolean (list output)))))))) + +(defun magit-git-insert (&rest args) + "Execute Git with ARGS, insert stdout at point and return exit code. +If `magit-git-debug' in non-nil and the exit code is non-zero, then +insert the run command and stderr into the process buffer." + (apply #'magit--git-insert nil args)) + +(defun magit--git-insert (return-error &rest args) + (setq args (flatten-tree args)) + (if (or return-error magit-git-debug) + (let (log) + (unwind-protect + (let (exit errmsg) + (setq log (make-temp-file "magit-stderr")) + (delete-file log) + (setq exit (magit-process-git (list t log) args)) + (when (or (> exit 0) (eq magit-git-debug 'all)) + (when (file-exists-p log) + (with-temp-buffer + (insert-file-contents log) + (goto-char (point-max)) + (setq errmsg + (cond + ((eq return-error 'full) + (buffer-string)) + ((functionp magit-git-debug) + (funcall magit-git-debug (buffer-string))) + ((magit--locate-error-message))))) + (when magit-git-debug + (let ((magit-git-debug nil)) + (with-current-buffer (magit-process-buffer t) + (magit-process-finish-section + (magit-process-insert-section + default-directory magit-git-executable + (magit-process-git-arguments args) + exit log 'magit-section-secondary-heading) + exit))))) + (cond ((not magit-git-debug)) + (errmsg (message "%s" errmsg)) + ((zerop exit)) + ((message "Git returned with exit-code %s" exit)))) + (or errmsg exit)) + (ignore-errors (delete-file log)))) + (magit-process-git (list t nil) args))) + +(defun magit--locate-error-message () + (goto-char (point-max)) + (and (run-hook-wrapped 'magit-process-error-message-regexps + (lambda (re) (re-search-backward re nil t))) + (match-string-no-properties 1))) + +(defun magit-git-string (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-lines (&rest args) + "Execute Git with ARGS, returning its output as a list of lines. +Empty lines anywhere in the output are omitted. + +If Git exits with a non-zero exit status, then report show a +message and add a section in the respective process buffer." + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\n" t))) + +(defun magit-git-items (&rest args) + "Execute Git with ARGS, returning its null-separated output as a list. +Empty items anywhere in the output are omitted. + +If Git exits with a non-zero exit status, then report show a +message and add a section in the respective process buffer." + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\0" t))) + +(defvar magit--git-wash-keep-error t) + +(defun magit-git-wash (washer &rest args) + "Execute Git with ARGS, inserting washed output at point. +Actually first insert the raw output at point. If there is no +output, call `magit-cancel-section'. Otherwise temporarily narrow +the buffer to the inserted text, move to its beginning, and then +call function WASHER with ARGS as its sole argument." + (declare (indent 1)) + (apply #'magit--git-wash washer magit--git-wash-keep-error args)) + +(defun magit--git-wash (washer keep-error &rest args) + (declare (indent 2)) + (setq args (flatten-tree args)) + (let ((beg (point)) + (exit (magit--git-insert (and keep-error 'full) args))) + (when (stringp exit) + (goto-char beg) + (insert (propertize exit 'face 'error)) + (insert (if (bolp) "\n" "\n\n"))) + (if (= (point) beg) + (magit-cancel-section) + (unless (bolp) + (insert "\n")) + (when (or (equal exit 0) + (eq keep-error 'wash-anyway)) + (save-restriction + (narrow-to-region beg (point)) + (goto-char beg) + (funcall washer args)) + (when (or (= (point) beg) + (= (point) (1+ beg))) + (magit-cancel-section)) + (magit-maybe-make-margin-overlay))) + exit)) + +(defun magit-git-executable-find (command) + "Search for COMMAND in Git's exec path, falling back to `exec-path'. +Like `executable-find', return the absolute file name of the +executable." + (or (locate-file command + (list (concat + (file-remote-p default-directory) + (or (magit-git-string "--exec-path") + (error "`git --exec-path' failed")))) + exec-suffixes + #'file-executable-p) + (compat-call executable-find command t))) + +;;; Git Version + +(defconst magit--git-version-regexp + "\\`git version \\([0-9]+\\(\\.[0-9]+\\)\\{1,2\\}\\)") + +(defvar magit--host-git-version-cache nil) + +(defun magit-git-version>= (n) + "Return t if `magit-git-version's value is greater than or equal to N." + (magit--version>= (magit-git-version) n)) + +(defun magit-git-version< (n) + "Return t if `magit-git-version's value is smaller than N." + (version< (magit-git-version) n)) + +(defun magit-git-version () + "Return the Git version used for `default-directory'. +Raise an error if Git cannot be found, if it exits with a +non-zero status, or the output does not have the expected +format." + (magit--with-refresh-cache default-directory + (let ((host (file-remote-p default-directory))) + (or (cdr (assoc host magit--host-git-version-cache)) + (magit--with-temp-process-buffer + ;; Unset global arguments for ancient Git versions. + (let* ((magit-git-global-arguments nil) + (status (magit-process-git t "version")) + (output (buffer-string))) + (cond + ((not (zerop status)) + (display-warning + 'magit + (format "%S\n\nRunning \"%s --version\" failed with output:\n\n%s" + (if host + (format "Magit cannot find Git on host %S.\n +Check the value of `magit-remote-git-executable' using +`magit-debug-git-executable' and consult the info node +`(tramp)Remote programs'." host) + "Magit cannot find Git.\n +Check the values of `magit-git-executable' and `exec-path' +using `magit-debug-git-executable'.") + (magit-git-executable) + output))) + ((save-match-data + (and (string-match magit--git-version-regexp output) + (let ((version (match-string 1 output))) + (push (cons host version) + magit--host-git-version-cache) + version)))) + ((error "Unexpected \"%s --version\" output: %S" + (magit-git-executable) + output))))))))) + +(defun magit-git-version-assert (&optional minimal who) + "Assert that the used Git version is greater than or equal to MINIMAL. +If optional MINIMAL is nil, compare with `magit--minimal-git' +instead. Optional WHO if non-nil specifies what functionality +needs at least MINIMAL, otherwise it defaults to \"Magit\"." + (when (magit-git-version< (or minimal magit--minimal-git)) + (let* ((host (file-remote-p default-directory)) + (msg (format-spec + (cond (host "\ +%w requires Git %m or greater, but on %h the version is %v. + +If multiple Git versions are installed on the host, then the +problem might be that TRAMP uses the wrong executable. + +Check the value of `magit-remote-git-executable' and consult +the info node `(tramp)Remote programs'.\n") + (t "\ +%w requires Git %m or greater, but you are using %v. + +If you have multiple Git versions installed, then check the +values of `magit-remote-git-executable' and `exec-path'.\n")) + `((?w . ,(or who "Magit")) + (?m . ,(or minimal magit--minimal-git)) + (?v . ,(magit-git-version)) + (?h . ,host))))) + (display-warning 'magit msg :error)))) + +(defun magit--safe-git-version () + "Return the Git version used for `default-directory' or an error message." + (magit--with-temp-process-buffer + (let* ((magit-git-global-arguments nil) + (status (magit-process-git t "version")) + (output (buffer-string))) + (cond ((not (zerop status)) output) + ((save-match-data + (and (string-match magit--git-version-regexp output) + (match-string 1 output)))) + (t output))))) + +(defun magit-debug-git-executable () + "Display a buffer with information about `magit-git-executable'. +Also include information about `magit-remote-git-executable'. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (with-current-buffer (get-buffer-create "*magit-git-debug*") + (pop-to-buffer (current-buffer)) + (erase-buffer) + (insert (format "magit-remote-git-executable: %S\n" + magit-remote-git-executable)) + (insert (concat + (format "magit-git-executable: %S" magit-git-executable) + (and (not (file-name-absolute-p magit-git-executable)) + (format " [%S]" (executable-find magit-git-executable))) + (format " (%s)\n" (magit--safe-git-version)))) + (insert (format "exec-path: %S\n" exec-path)) + (when-let ((diff (cl-set-difference + (seq-filter #'file-exists-p (remq nil (parse-colon-path + (getenv "PATH")))) + (seq-filter #'file-exists-p (remq nil exec-path)) + :test #'file-equal-p))) + (insert (format " entries in PATH, but not in exec-path: %S\n" diff))) + (dolist (execdir exec-path) + (insert (format " %s (%s)\n" execdir (car (file-attributes execdir)))) + (when (file-directory-p execdir) + (dolist (exec (directory-files + execdir t (concat + "\\`git" (regexp-opt exec-suffixes) "\\'"))) + (insert (format " %s (%s)\n" exec + (magit--safe-git-version)))))))) + +;;; Variables + +(defun magit-config-get-from-cached-list (key) + (gethash + ;; `git config --list' downcases first and last components of the key. + (let* ((key (replace-regexp-in-string "\\`[^.]+" #'downcase key t t)) + (key (replace-regexp-in-string "[^.]+\\'" #'downcase key t t))) + key) + (magit--with-refresh-cache (cons (magit-toplevel) 'config) + (let ((configs (make-hash-table :test #'equal))) + (dolist (conf (magit-git-items "config" "--list" "-z")) + (let* ((nl-pos (cl-position ?\n conf)) + (key (substring conf 0 nl-pos)) + (val (if nl-pos (substring conf (1+ nl-pos)) ""))) + (puthash key (nconc (gethash key configs) (list val)) configs))) + configs)))) + +(defun magit-get (&rest keys) + "Return the value of the Git variable specified by KEYS." + (car (last (apply #'magit-get-all keys)))) + +(defun magit-get-all (&rest keys) + "Return all values of the Git variable specified by KEYS." + (let ((magit-git-debug nil) + (arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (if (and magit--refresh-cache (not arg)) + (magit-config-get-from-cached-list key) + (magit-git-items "config" arg "-z" "--get-all" "--include" key)))) + +(defun magit-get-boolean (&rest keys) + "Return the boolean value of the Git variable specified by KEYS. +Also see `magit-git-config-p'." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (equal (if magit--refresh-cache + (car (last (magit-config-get-from-cached-list key))) + (magit-git-str "config" arg "--bool" "--include" key)) + "true"))) + +(defun magit-set (value &rest keys) + "Set the value of the Git variable specified by KEYS to VALUE." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (if value + (magit-git-success "config" arg key value) + (magit-git-success "config" arg "--unset" key)) + value)) + +(gv-define-setter magit-get (val &rest keys) + `(magit-set ,val ,@keys)) + +(defun magit-set-all (values &rest keys) + "Set all values of the Git variable specified by KEYS to VALUES." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (var (string-join keys "."))) + (when (magit-get var) + (magit-call-git "config" arg "--unset-all" var)) + (dolist (v values) + (magit-call-git "config" arg "--add" var v)))) + +;;; Files + +(defun magit--safe-default-directory (&optional file) + (catch 'unsafe-default-dir + (let ((dir (file-name-as-directory + (expand-file-name (or file default-directory)))) + (previous nil)) + (while (not (file-accessible-directory-p dir)) + (setq dir (file-name-directory (directory-file-name dir))) + (when (equal dir previous) + (throw 'unsafe-default-dir nil)) + (setq previous dir)) + dir))) + +(defmacro magit--with-safe-default-directory (file &rest body) + (declare (indent 1) (debug (form body))) + `(when-let ((default-directory (magit--safe-default-directory ,file))) + ,@body)) + +(defun magit-git-dir (&optional path) + "Like (expand-file-name PATH (magit-gitdir)) or just (magit-gitdir)." + (declare (obsolete 'magit-gitdir "Magit 4.0.0")) + (and-let* ((dir (magit-gitdir))) + (if path + (expand-file-name (convert-standard-filename path) dir) + dir))) + +(defun magit-gitdir (&optional directory) + "Return the absolute and resolved path of the .git directory. + +If the `GIT_DIR' environment variable is defined, return that. +Otherwise return the .git directory for DIRECTORY, or if that is +nil, then for `default-directory' instead. If the directory is +not located inside a Git repository, then return nil." + (let ((default-directory (or directory default-directory))) + (magit--with-refresh-cache (list default-directory 'magit-gitdir) + (magit--with-safe-default-directory nil + (and-let* + ((dir (magit-rev-parse-safe "--git-dir")) + (dir (file-name-as-directory (magit-expand-git-file-name dir)))) + (if (file-remote-p dir) + dir + (concat (file-remote-p default-directory) dir))))))) + +(defvar magit--separated-gitdirs nil) + +(defun magit--record-separated-gitdir () + (let ((topdir (magit-toplevel)) + (gitdir (magit-gitdir))) + ;; Kludge: git-annex converts submodule gitdirs to symlinks. See #3599. + (when (file-symlink-p (directory-file-name gitdir)) + (setq gitdir (file-truename gitdir))) + ;; We want to delete the entry for `topdir' here, rather than within + ;; (unless ...), in case a `--separate-git-dir' repository was switched to + ;; the standard structure (i.e., "topdir/.git/"). + (setq magit--separated-gitdirs (cl-delete topdir + magit--separated-gitdirs + :key #'car :test #'equal)) + (unless (equal (file-name-as-directory (expand-file-name ".git" topdir)) + gitdir) + (push (cons topdir gitdir) magit--separated-gitdirs)))) + +(defun magit-toplevel (&optional directory) + "Return the absolute path to the toplevel of the current repository. + +From within the working tree or control directory of a repository +return the absolute path to the toplevel directory of the working +tree. As a special case, from within a bare repository return +the control directory instead. When called outside a repository +then return nil. + +When optional DIRECTORY is non-nil then return the toplevel for +that directory instead of the one for `default-directory'. + +Try to respect the option `find-file-visit-truename', i.e., when +the value of that option is nil, then avoid needlessly returning +the truename. When a symlink to a sub-directory of the working +tree is involved, or when called from within a sub-directory of +the gitdir or from the toplevel of a gitdir, which itself is not +located within the working tree, then it is not possible to avoid +returning the truename." + (or + (magit--with-refresh-cache + (cons (or directory default-directory) 'magit-toplevel) + (magit--with-safe-default-directory directory + (if-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (let (updir) + (setq topdir (magit-expand-git-file-name topdir)) + (cond + ((and + ;; Always honor these settings. + (not find-file-visit-truename) + (not (getenv "GIT_WORK_TREE")) + ;; `--show-cdup' is the relative path to the toplevel + ;; from `(file-truename default-directory)'. Here we + ;; pretend it is relative to `default-directory', and + ;; go to that directory. Then we check whether + ;; `--show-toplevel' still returns the same value and + ;; whether `--show-cdup' now is the empty string. If + ;; both is the case, then we are at the toplevel of + ;; the same working tree, but also avoided needlessly + ;; following any symlinks. + (progn + (setq updir (file-name-as-directory + (magit-rev-parse-safe "--show-cdup"))) + (setq updir (if (file-name-absolute-p updir) + (concat (file-remote-p default-directory) + updir) + (expand-file-name updir))) + (and-let* + ((default-directory updir) + (top (and (string-equal + (magit-rev-parse-safe "--show-cdup") "") + (magit-rev-parse-safe "--show-toplevel")))) + (string-equal (magit-expand-git-file-name top) topdir)))) + updir) + ((concat (file-remote-p default-directory) + (file-name-as-directory topdir))))) + (and-let* ((gitdir (magit-rev-parse-safe "--git-dir")) + (gitdir (file-name-as-directory + (if (file-name-absolute-p gitdir) + ;; We might have followed a symlink. + (concat (file-remote-p default-directory) + (magit-expand-git-file-name gitdir)) + (expand-file-name gitdir))))) + (if (magit-bare-repo-p) + gitdir + (let* ((link (expand-file-name "gitdir" gitdir)) + (wtree (and (file-exists-p link) + (magit-file-line link)))) + (cond + ((and wtree + ;; Ignore .git/gitdir files that result from a + ;; Git bug. See #2364. + (not (equal wtree ".git"))) + ;; Return the linked working tree. + (concat (file-remote-p default-directory) + (file-name-directory wtree))) + ;; The working directory may not be the parent + ;; directory of .git if it was set up with + ;; "git init --separate-git-dir". See #2955. + ((car (rassoc gitdir magit--separated-gitdirs))) + (;; Step outside the control directory to enter the + ;; working tree. + (file-name-directory (directory-file-name gitdir)))))))))))) + +(defun magit--toplevel-safe () + (or (magit-toplevel) + (magit--not-inside-repository-error))) + +(defmacro magit-with-toplevel (&rest body) + (declare (indent defun) (debug (body))) + `(let ((default-directory (magit--toplevel-safe))) + ,@body)) + +(define-error 'magit-outside-git-repo "Not inside Git repository") +(define-error 'magit-corrupt-git-config "Corrupt Git configuration") +(define-error 'magit-git-executable-not-found + (concat "Git executable cannot be found " + "(see https://magit.vc/goto/e6a78ed2)")) + +(defun magit--assert-usable-git () + (if (not (compat-call executable-find (magit-git-executable) t)) + (signal 'magit-git-executable-not-found (magit-git-executable)) + (let ((magit-git-debug + (lambda (err) + (signal 'magit-corrupt-git-config + (format "%s: %s" default-directory err))))) + ;; This should always succeed unless there's a corrupt config + ;; (or at least a similarly severe failing state). Note that + ;; git-config's --default is avoided because it's not available + ;; until Git 2.18. + (magit-git-string "config" "--get-color" "" "reset")) + nil)) + +(defun magit--not-inside-repository-error () + (magit--assert-usable-git) + (signal 'magit-outside-git-repo default-directory)) + +(defun magit-inside-gitdir-p (&optional noerror) + "Return t if `default-directory' is below the repository directory. +If it is below the working directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + ;; Below a repository directory that is not located below the + ;; working directory "git rev-parse --is-inside-git-dir" prints + ;; "false", which is wrong. + (let ((gitdir (magit-gitdir))) + (cond (gitdir (file-in-directory-p default-directory gitdir)) + (noerror nil) + ((signal 'magit-outside-git-repo default-directory)))))) + +(defun magit-inside-worktree-p (&optional noerror) + "Return t if `default-directory' is below the working directory. +If it is below the repository directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-inside-work-tree") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(cl-defgeneric magit-bare-repo-p (&optional noerror) + "Return t if the current repository is bare. +If it is non-bare, then return nil. If `default-directory' +isn't below a Git repository, then signal an error unless +NOERROR is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-bare-repository") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(defun magit--assert-default-directory (&optional noerror) + (or (file-directory-p default-directory) + (and (not noerror) + (let ((exists (file-exists-p default-directory))) + (signal (if exists 'file-error 'file-missing) + (list "Running git in directory" + (if exists + "Not a directory" + "No such file or directory") + default-directory)))))) + +(defun magit-git-repo-p (directory &optional non-bare) + "Return t if DIRECTORY is a Git repository. +When optional NON-BARE is non-nil also return nil if DIRECTORY is +a bare repository." + (and (file-directory-p directory) ; Avoid archives, see #3397. + (or (file-regular-p (expand-file-name ".git" directory)) + (file-directory-p (expand-file-name ".git" directory)) + (and (not non-bare) + (file-regular-p (expand-file-name "HEAD" directory)) + (file-directory-p (expand-file-name "refs" directory)) + (file-directory-p (expand-file-name "objects" directory)))))) + +(defun magit-file-relative-name (&optional file tracked) + "Return the path of FILE relative to the repository root. + +If optional FILE is nil or omitted, return the relative path of +the file being visited in the current buffer, if any, else nil. +If the file is not inside a Git repository, then return nil. + +If TRACKED is non-nil, return the path only if it matches a +tracked file." + (unless file + (with-current-buffer (or (buffer-base-buffer) + (current-buffer)) + (setq file (or magit-buffer-file-name buffer-file-name + (and (derived-mode-p 'dired-mode) default-directory))))) + (when (and file (or (not tracked) + (magit-file-tracked-p (file-relative-name file)))) + (and-let* ((dir (magit-toplevel + (magit--safe-default-directory + (directory-file-name (file-name-directory file)))))) + (file-relative-name file dir)))) + +(defun magit-file-ignored-p (file) + (magit-git-string-p "ls-files" "--others" "--ignored" "--exclude-standard" + "--" (magit-convert-filename-for-git file))) + +(defun magit-file-tracked-p (file) + (magit-git-success "ls-files" "--error-unmatch" + "--" (magit-convert-filename-for-git file))) + +(defun magit-list-files (&rest args) + (apply #'magit-git-items "ls-files" "-z" "--full-name" args)) + +(defun magit-tracked-files () + (magit-list-files "--cached")) + +(defun magit-untracked-files (&optional all files compact) + (if compact + (--mapcat (and (eq (aref it 0) ??) + (list (substring it 3))) + (magit-git-items "status" "-z" "--porcelain" + (magit-ignore-submodules-p t) + "--" files)) + (magit-list-files "--other" + (and (not all) "--exclude-standard") + "--" files))) + +(defun magit-modified-files (&optional nomodules files) + (magit-git-items "diff-index" "-z" "--name-only" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + (magit-headish) "--" files)) + +(defun magit-unstaged-files (&optional nomodules files) + (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=u" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + "--" files)) + +(defun magit-staged-files (&optional nomodules files) + (magit-git-items "diff-index" "-z" "--name-only" "--cached" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + (magit-headish) "--" files)) + +(defun magit-binary-files (&rest args) + (--mapcat (and (string-match "^-\t-\t\\(.+\\)" it) + (list (match-string 1 it))) + (apply #'magit-git-items + "diff" "-z" "--numstat" "--ignore-submodules" + args))) + +(defun magit-unmerged-files () + (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=U")) + +(defun magit-ignored-files () + (magit-git-items "ls-files" "-z" "--others" "--ignored" + "--exclude-standard" "--directory")) + +(defun magit-stashed-files (stash) + (magit-git-items "stash" "show" "-z" "--name-only" stash)) + +(defun magit-skip-worktree-files () + (--keep (and (= (aref it 0) ?S) + (substring it 2)) + (magit-list-files "-t"))) + +(defun magit-assume-unchanged-files () + (--keep (and (memq (aref it 0) '(?h ?s ?m ?r ?c ?k)) + (substring it 2)) + (magit-list-files "-v"))) + +(defun magit-revision-files (rev) + (magit-with-toplevel + (magit-git-items "ls-tree" "-z" "-r" "--name-only" rev))) + +(defun magit-revision-directories (rev) + "List directories that contain a tracked file in revision REV." + (magit-with-toplevel + (mapcar #'file-name-as-directory + (magit-git-items "ls-tree" "-z" "-r" "-d" "--name-only" rev)))) + +(defun magit-changed-files (rev-or-range &optional other-rev) + "Return list of files the have changed between two revisions. +If OTHER-REV is non-nil, REV-OR-RANGE should be a revision, not a +range. Otherwise, it can be any revision or range accepted by +\"git diff\" (i.e., <rev>, <revA>..<revB>, or <revA>...<revB>)." + (magit-with-toplevel + (magit-git-items "diff" "-z" "--name-only" rev-or-range other-rev))) + +(defun magit-renamed-files (revA revB) + (mapcar (pcase-lambda (`(,_status ,fileA ,fileB)) + (cons fileA fileB)) + (seq-partition (magit-git-items "diff" "-z" "--name-status" + "--find-renames" + "--diff-filter=R" revA revB) + 3))) + +(defun magit--rev-file-name (file rev other-rev) + "For FILE, potentially renamed between REV and OTHER-REV, return name in REV. +Return nil, if FILE appears neither in REV nor OTHER-REV, +or if no rename is detected." + (or (car (member file (magit-revision-files rev))) + (and-let* ((renamed (magit-renamed-files rev other-rev))) + (car (rassoc file renamed))))) + +(defun magit-file-status (&rest args) + (magit--with-temp-process-buffer + (save-excursion (magit-git-insert "status" "-z" args)) + (let ((pos (point)) status) + (while (> (skip-chars-forward "[:print:]") 0) + (let ((x (char-after pos)) + (y (char-after (1+ pos))) + (file (buffer-substring (+ pos 3) (point)))) + (forward-char) + (if (memq x '(?R ?C)) + (progn + (setq pos (point)) + (skip-chars-forward "[:print:]") + (push (list file (buffer-substring pos (point)) x y) status) + (forward-char)) + (push (list file nil x y) status))) + (setq pos (point))) + status))) + +(defcustom magit-cygwin-mount-points + (and (eq system-type 'windows-nt) + (cl-sort (--map (if (string-match "^\\(.*\\) on \\(.*\\) type" it) + (cons (file-name-as-directory (match-string 2 it)) + (file-name-as-directory (match-string 1 it))) + (lwarn '(magit) :error + "Failed to parse Cygwin mount: %S" it)) + ;; If --exec-path is not a native Windows path, + ;; then we probably have a cygwin git. + (let ((process-environment + (append magit-git-environment + process-environment))) + (and (not (string-match-p + "\\`[a-zA-Z]:" + (car (process-lines + magit-git-executable "--exec-path")))) + (ignore-errors (process-lines "mount"))))) + #'> :key (pcase-lambda (`(,cyg . ,_win)) (length cyg)))) + "Alist of (CYGWIN . WIN32) directory names. +Sorted from longest to shortest CYGWIN name." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(alist :key-type string :value-type directory)) + +(defun magit-expand-git-file-name (filename) + (unless (file-name-absolute-p filename) + (setq filename (expand-file-name filename))) + (if-let ((cyg:win (and (not (file-remote-p default-directory)) ; see #4976 + (cl-assoc filename magit-cygwin-mount-points + :test (lambda (f cyg) (string-prefix-p cyg f)))))) + (concat (cdr cyg:win) + (substring filename (length (car cyg:win)))) + filename)) + +(defun magit-convert-filename-for-git (filename) + "Convert FILENAME so that it can be passed to git. +1. If it is a absolute filename, then pass it through + `expand-file-name' to replace things such as \"~/\" that + Git does not understand. +2. If it is a remote filename, then remove the remote part. +3. Deal with an `windows-nt' Emacs vs. Cygwin Git incompatibility." + (if (file-name-absolute-p filename) + (if-let ((cyg:win (cl-rassoc filename magit-cygwin-mount-points + :test (lambda (f win) (string-prefix-p win f))))) + (concat (car cyg:win) + (substring filename (length (cdr cyg:win)))) + (let ((expanded (expand-file-name filename))) + (or (file-remote-p expanded 'localname) + expanded))) + filename)) + +(defun magit-decode-git-path (path) + (if (eq (aref path 0) ?\") + (decode-coding-string (read path) + (or magit-git-output-coding-system + (car default-process-coding-system)) + t) + path)) + +(defun magit-file-at-point (&optional expand assert) + (if-let ((file (magit-section-case + (file (oref it value)) + (hunk (magit-section-parent-value it))))) + (if expand + (expand-file-name file (magit-toplevel)) + file) + (when assert + (user-error "No file at point")))) + +(defun magit-current-file () + (or (magit-file-relative-name) + (magit-file-at-point) + (and (derived-mode-p 'magit-log-mode) + (car magit-buffer-log-files)))) + +;;; Predicates + +(defun magit-no-commit-p () + "Return t if there is no commit in the current Git repository." + (not (magit-rev-verify "HEAD"))) + +(defun magit-merge-commit-p (commit) + "Return t if COMMIT is a merge commit." + (length> (magit-commit-parents commit) 1)) + +(defun magit-anything-staged-p (&optional ignore-submodules &rest files) + "Return t if there are any staged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + ;; The "--submodule=short" is needed to work around a bug in Git v2.46.0 + ;; and v2.46.1. See #5212 and #5221. There are actually two related + ;; bugs, both of which are fixed in v2.46.2, with the following commits, + ;; but there is no workaround for the second bug. + ;; 11591850dd diff: report dirty submodules as changes in builtin_diff() + ;; 87cf96094a diff: report copies and renames as changes in run_diff_cmd() + (magit-git-failure "diff" "--quiet" "--cached" + (if ignore-submodules + "--ignore-submodules" + "--submodule=short") + "--" files)) + +(defun magit-anything-unstaged-p (&optional ignore-submodules &rest files) + "Return t if there are any unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (magit-git-failure "diff" "--quiet" + (if ignore-submodules + "--ignore-submodules" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + "--submodule=short") + "--" files)) + +(defun magit-anything-modified-p (&optional ignore-submodules &rest files) + "Return t if there are any staged or unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (or (apply #'magit-anything-staged-p ignore-submodules files) + (apply #'magit-anything-unstaged-p ignore-submodules files))) + +(defun magit-anything-unmerged-p (&rest files) + "Return t if there are any merge conflicts. +If optional FILES is non-nil, then only conflicts in those files +are considered." + (and (magit-git-string "ls-files" "--unmerged" files) t)) + +(defun magit-module-worktree-p (module) + (magit-with-toplevel + (file-exists-p (expand-file-name ".git" module)))) + +(defun magit-module-no-worktree-p (module) + (not (magit-module-worktree-p module))) + +(defun magit-ignore-submodules-p (&optional return-argument) + (or (cl-find-if (lambda (arg) + (string-prefix-p "--ignore-submodules" arg)) + magit-buffer-diff-args) + (and-let* ((value (magit-get "diff.ignoreSubmodules"))) + (if return-argument + (concat "--ignore-submodules=" value) + (concat "diff.ignoreSubmodules=" value))))) + +;;; Revisions and References + +(defun magit-rev-parse (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil." + (apply #'magit-git-string "rev-parse" args)) + +(defun magit-rev-parse-safe (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil. Like `magit-rev-parse' but +ignore `magit-git-debug'." + (apply #'magit-git-str "rev-parse" args)) + +(defun magit-rev-parse-true (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal an error." + (magit-git-true "rev-parse" args)) + +(defun magit-rev-parse-false (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal an error." + (magit-git-false "rev-parse" args)) + +(defun magit-rev-parse-p (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +Return t if the first (and usually only) output line is the +string \"true\", otherwise return nil." + (equal (magit-git-str "rev-parse" args) "true")) + +(defun magit-rev-verify (rev) + (magit-git-string-p "rev-parse" "--verify" rev)) + +(defun magit-commit-p (rev) + "Return full hash for REV if it names an existing commit." + (magit-rev-verify (magit--rev-dereference rev))) + +(defalias 'magit-rev-verify-commit #'magit-commit-p) + +(defalias 'magit-rev-hash #'magit-commit-p) + +(defun magit--rev-dereference (rev) + "Return a rev that forces Git to interpret REV as a commit. +If REV is nil or has the form \":/TEXT\", return REV itself." + (cond ((not rev) nil) + ((string-match-p "^:/" rev) rev) + ((concat rev "^{commit}")))) + +(defun magit-rev-equal (a b) + "Return t if there are no differences between the commits A and B." + (magit-git-success "diff" "--quiet" a b)) + +(defun magit-rev-eq (a b) + "Return t if A and B refer to the same commit." + (let ((a (magit-commit-p a)) + (b (magit-commit-p b))) + (and a b (equal a b)))) + +(defun magit-rev-ancestor-p (a b) + "Return non-nil if commit A is an ancestor of commit B." + (magit-git-success "merge-base" "--is-ancestor" a b)) + +(defun magit-rev-head-p (rev) + (or (equal rev "HEAD") + (and rev + (not (string-search ".." rev)) + (equal (magit-rev-parse rev) + (magit-rev-parse "HEAD"))))) + +(defun magit-rev-author-p (rev) + "Return t if the user is the author of REV. +More precisely return t if `user.name' is equal to the author +name of REV and/or `user.email' is equal to the author email +of REV." + (or (equal (magit-get "user.name") (magit-rev-format "%an" rev)) + (equal (magit-get "user.email") (magit-rev-format "%ae" rev)))) + +(defun magit-rev-name (rev &optional pattern not-anchored) + "Return a symbolic name for REV using `git-name-rev'. + +PATTERN can be used to limit the result to a matching ref. +Unless NOT-ANCHORED is non-nil, the beginning of the ref must +match PATTERN. + +An anchored lookup is done using the arguments +\"--exclude=*/<PATTERN> --exclude=*/HEAD\" in addition to +\"--refs=<PATTERN>\", provided at least version v2.13 of Git is +used. Older versions did not support the \"--exclude\" argument. +When \"--exclude\" cannot be used and `git-name-rev' returns a +ref that should have been excluded, then that is discarded and +this function returns nil instead. This is unfortunate because +there might be other refs that do match. To fix that, update +Git." + (if (magit-git-version< "2.13") + (and-let* + ((ref (magit-git-string "name-rev" "--name-only" "--no-undefined" + (and pattern (concat "--refs=" pattern)) + rev))) + (if (and pattern + (string-match-p "\\`refs/[^/]+/\\*\\'" pattern)) + (let ((namespace (substring pattern 0 -1))) + (and (not (or (string-suffix-p "HEAD" ref) + (and (string-match-p namespace ref) + (not (magit-rev-verify + (concat namespace ref)))))) + ref)) + ref)) + (magit-git-string "name-rev" "--name-only" "--no-undefined" + (and pattern (concat "--refs=" pattern)) + (and pattern + (not not-anchored) + (list "--exclude=*/HEAD" + (concat "--exclude=*/" pattern))) + rev))) + +(defun magit-rev-branch (rev) + (and-let* ((name (magit-rev-name rev "refs/heads/*"))) + (and (not (string-match-p "[~^]" name)) name))) + +(defun magit-rev-fixup-target (rev) + (let ((msg (magit-rev-format "%s" rev))) + (save-match-data + (and (string-match "\\`\\(fixup\\|squash\\)! \\(.+\\)" msg) + (magit-rev-format + "%h" (format "%s^{/^%s}" rev + (magit--ext-regexp-quote (match-string 2 msg)))))))) + +(defun magit-get-shortname (rev) + (let* ((fn (apply-partially #'magit-rev-name rev)) + (name (or (funcall fn "refs/tags/*") + (funcall fn "refs/heads/*") + (funcall fn "refs/remotes/*")))) + (cond ((not name) + (magit-rev-parse "--short" rev)) + ((string-match "^\\(?:tags\\|remotes\\)/\\(.+\\)" name) + (if (magit-ref-ambiguous-p (match-string 1 name)) + name + (match-string 1 name))) + ((magit-ref-maybe-qualify name))))) + +(defun magit-name-branch (rev &optional lax) + (or (magit-name-local-branch rev) + (magit-name-remote-branch rev) + (and lax (or (magit-name-local-branch rev t) + (magit-name-remote-branch rev t))))) + +(defun magit-name-local-branch (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/heads/*"))) + (and (or lax (not (string-match-p "[~^]" name))) name))) + +(defun magit-name-remote-branch (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/remotes/*"))) + (and (or lax (not (string-match-p "[~^]" name))) + (substring name 8)))) + +(defun magit-name-tag (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/tags/*"))) + ;; The progn is necessary to work around debbugs#31840. This, and all + ;; the other instances, can be removed once we require at least Emacs 27. + (progn + (when (string-suffix-p "^0" name) + (setq name (substring name 0 -2))) + (and (or lax (not (string-match-p "[~^]" name))) + (substring name 5))))) + +(defun magit-ref-abbrev (refname) + "Return an unambiguous abbreviation of REFNAME." + (magit-rev-parse "--verify" "--abbrev-ref" refname)) + +(defun magit-ref-fullname (refname) + "Return fully qualified refname for REFNAME. +If REFNAME is ambiguous, return nil." + (magit-rev-parse "--verify" "--symbolic-full-name" refname)) + +(defun magit-ref-ambiguous-p (refname) + (save-match-data + (if (string-match "\\`\\([^^~]+\\)\\(.*\\)" refname) + (not (magit-ref-fullname (match-string 1 refname))) + (error "%S has an unrecognized format" refname)))) + +(defun magit-ref-maybe-qualify (refname &optional prefix) + "If REFNAME is ambiguous, try to disambiguate it by prepend PREFIX to it. +Return an unambiguous refname, either REFNAME or that prefixed +with PREFIX, nil otherwise. If REFNAME has an offset suffix +such as \"~1\", then that is preserved. If optional PREFIX is +nil, then use \"heads/\". " + (if (magit-ref-ambiguous-p refname) + (let ((refname (concat (or prefix "heads/") refname))) + (and (not (magit-ref-ambiguous-p refname)) refname)) + refname)) + +(defun magit-ref-exists-p (ref) + (magit-git-success "show-ref" "--verify" ref)) + +(defun magit-ref-equal (a b) + "Return t if the refnames A and B are `equal'. +A symbolic-ref pointing to some ref, is `equal' to that ref, +as are two symbolic-refs pointing to the same ref. Refnames +may be abbreviated." + (let ((a (magit-ref-fullname a)) + (b (magit-ref-fullname b))) + (and a b (equal a b)))) + +(defun magit-ref-eq (a b) + "Return t if the refnames A and B are `eq'. +A symbolic-ref is `eq' to itself, but not to the ref it points +to, or to some other symbolic-ref that points to the same ref." + (let ((symbolic-a (magit-symbolic-ref-p a)) + (symbolic-b (magit-symbolic-ref-p b))) + (or (and symbolic-a + symbolic-b + (equal a b)) + (and (not symbolic-a) + (not symbolic-b) + (magit-ref-equal a b))))) + +(defun magit-headish () + "Return the `HEAD' or if that doesn't exist the hash of the empty tree." + (if (magit-no-commit-p) + (magit-git-string "mktree") + "HEAD")) + +(defun magit-branch-at-point () + (magit-section-case + (branch (oref it value)) + (commit (or (magit--painted-branch-at-point) + (magit-name-branch (oref it value)))))) + +(defun magit--painted-branch-at-point (&optional type) + (or (and (not (eq type 'remote)) + (memq (get-text-property (magit-point) 'font-lock-face) + (list 'magit-branch-local + 'magit-branch-current)) + (and-let* ((branch (magit-thing-at-point 'git-revision t))) + (cdr (magit-split-branch-name branch)))) + (and (not (eq type 'local)) + (memq (get-text-property (magit-point) 'font-lock-face) + (list 'magit-branch-remote + 'magit-branch-remote-head)) + (thing-at-point 'git-revision t)))) + +(defun magit-local-branch-at-point () + (magit-section-case + (branch (let ((branch (magit-ref-maybe-qualify (oref it value)))) + (when (member branch (magit-list-local-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'local) + (magit-name-local-branch (oref it value)))))) + +(defun magit-remote-branch-at-point () + (magit-section-case + (branch (let ((branch (oref it value))) + (when (member branch (magit-list-remote-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'remote) + (magit-name-remote-branch (oref it value)))))) + +(defun magit-commit-at-point () + (or (magit-section-value-if 'commit) + (magit-thing-at-point 'git-revision t) + (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk) + (magit-current-blame-chunk)))) + (oref chunk orig-rev)) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-branch-or-commit-at-point () + (or (magit-section-case + (branch (magit-ref-maybe-qualify (oref it value))) + (commit (or (magit--painted-branch-at-point) + (let ((rev (oref it value))) + (or (magit-name-branch rev) rev)))) + (tag (magit-ref-maybe-qualify (oref it value) "tags/")) + (pullreq (or (and (fboundp 'forge--pullreq-branch) + (magit-branch-p + (forge--pullreq-branch (oref it value)))) + (magit-ref-p (format "refs/pullreqs/%s" + (oref (oref it value) number))))) + ((unpulled unpushed) + (magit-ref-abbrev + (replace-regexp-in-string "\\.\\.\\.?" "" (oref it value))))) + (magit-thing-at-point 'git-revision t) + (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk) + (magit-current-blame-chunk)))) + (oref chunk orig-rev)) + (and magit-buffer-file-name + magit-buffer-refname) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-tag-at-point () + (magit-section-case + (tag (oref it value)) + (commit (magit-name-tag (oref it value))))) + +(defun magit-stash-at-point () + (magit-section-value-if 'stash)) + +(defun magit-remote-at-point () + (magit-section-case + (remote (oref it value)) + ([branch remote] (magit-section-parent-value it)))) + +(defun magit-module-at-point (&optional predicate) + (when (magit-section-match 'module) + (let ((module (oref (magit-current-section) value))) + (and (or (not predicate) + (funcall predicate module)) + module)))) + +(defun magit-get-current-branch () + "Return the refname of the currently checked out branch. +Return nil if no branch is currently checked out." + (magit-git-string "symbolic-ref" "--short" "HEAD")) + +(defvar magit-get-previous-branch-timeout 0.5 + "Maximum time to spend in `magit-get-previous-branch'. +Given as a number of seconds.") + +(defun magit-get-previous-branch () + "Return the refname of the previously checked out branch. +Return nil if no branch can be found in the `HEAD' reflog +which is different from the current branch and still exists. +The amount of time spent searching is limited by +`magit-get-previous-branch-timeout'." + (let ((t0 (float-time)) + (current (magit-get-current-branch)) + (i 1) prev) + (while (if (> (- (float-time) t0) magit-get-previous-branch-timeout) + (setq prev nil) ;; Timed out. + (and (setq prev (magit-rev-verify (format "@{-%d}" i))) + (or (not (setq prev (magit-rev-branch prev))) + (equal prev current)))) + (cl-incf i)) + prev)) + +(defun magit--set-default-branch (newname oldname) + (let ((remote (or (magit-primary-remote) + (user-error "Cannot determine primary remote"))) + (branches (mapcar (lambda (line) (split-string line "\t")) + (magit-git-lines + "for-each-ref" "refs/heads" + "--format=%(refname:short)\t%(upstream:short)")))) + (when-let ((old (assoc oldname branches)) + ((not (assoc newname branches)))) + (magit-call-git "branch" "-m" oldname newname) + (setcar old newname)) + (let ((new (if (magit-branch-p newname) + newname + (concat remote "/" newname)))) + (pcase-dolist (`(,branch ,upstream) branches) + (cond + ((equal upstream oldname) + (magit-set-upstream-branch branch new)) + ((equal upstream (concat remote "/" oldname)) + (magit-set-upstream-branch branch (concat remote "/" newname)))))))) + +(defun magit--get-default-branch (&optional update) + (let ((remote (magit-primary-remote))) + (when update + (if (not remote) + (user-error "Cannot determine primary remote") + (message "Determining default branch...") + (magit-git "fetch" "--prune") + (magit-git "remote" "set-head" "--auto" remote) + (message "Determining default branch...done"))) + (let ((branch (magit-git-string "symbolic-ref" "--short" + (format "refs/remotes/%s/HEAD" remote)))) + (when (and update (not branch)) + (error "Cannot determine new default branch")) + (list remote (and branch (cdr (magit-split-branch-name branch))))))) + +(defun magit-set-upstream-branch (branch upstream) + "Set UPSTREAM as the upstream of BRANCH. +If UPSTREAM is nil, then unset BRANCH's upstream. +Otherwise UPSTREAM has to be an existing branch." + (if upstream + (magit-call-git "branch" "--set-upstream-to" upstream branch) + (magit-call-git "branch" "--unset-upstream" branch))) + +(defun magit-get-upstream-ref (&optional branch) + "Return the upstream branch of BRANCH as a fully qualified ref. +It BRANCH is nil, then return the upstream of the current branch, +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e., return an existing local or +remote-tracking branch ref." + (and-let* ((branch (or branch (magit-get-current-branch)))) + (magit-ref-fullname (concat branch "@{upstream}")))) + +(defun magit-get-upstream-branch (&optional branch) + "Return the name of the upstream branch of BRANCH. +It BRANCH is nil, then return the upstream of the current branch +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e., return the name of an existing local or +remote-tracking branch. The returned string is colorized +according to the branch type." + (magit--with-refresh-cache + (list default-directory 'magit-get-upstream-branch branch) + (and-let* ((branch (or branch (magit-get-current-branch))) + (upstream (magit-ref-abbrev (concat branch "@{upstream}")))) + (magit--propertize-face + upstream (if (equal (magit-get "branch" branch "remote") ".") + 'magit-branch-local + 'magit-branch-remote))))) + +(defun magit-get-indirect-upstream-branch (branch &optional force) + (let ((remote (magit-get "branch" branch "remote"))) + (and remote (not (equal remote ".")) + ;; The user has opted in... + (or force + (--some (if (magit-git-success "check-ref-format" "--branch" it) + (equal it branch) + (string-match-p it branch)) + magit-branch-prefer-remote-upstream)) + ;; and local BRANCH tracks a remote branch... + (let ((upstream (magit-get-upstream-branch branch))) + ;; whose upstream... + (and upstream + ;; has the same name as BRANCH... + (equal (substring upstream (1+ (length remote))) branch) + ;; and can be fast-forwarded to BRANCH. + (magit-rev-ancestor-p upstream branch) + upstream))))) + +(defun magit-get-upstream-remote (&optional branch allow-unnamed) + (and-let* ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote"))) + (and (not (equal remote ".")) + (cond ((member remote (magit-list-remotes)) + (magit--propertize-face remote 'magit-branch-remote)) + ((and allow-unnamed + (string-match-p "\\(\\`.\\{0,2\\}/\\|[:@]\\)" remote)) + (magit--propertize-face remote 'bold)))))) + +(defun magit-get-unnamed-upstream (&optional branch) + (and-let* ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (and (magit--unnamed-upstream-p remote merge) + (list (magit--propertize-face remote 'bold) + (magit--propertize-face merge 'magit-branch-remote))))) + +(defun magit--unnamed-upstream-p (remote merge) + (and remote (string-match-p "\\(\\`\\.\\{0,2\\}/\\|[:@]\\)" remote) + merge (string-prefix-p "refs/" merge))) + +(defun magit--valid-upstream-p (remote merge) + (and (or (equal remote ".") + (member remote (magit-list-remotes))) + (string-prefix-p "refs/" merge))) + +(defun magit-get-current-remote (&optional allow-unnamed) + (or (magit-get-upstream-remote nil allow-unnamed) + (and-let* ((remotes (magit-list-remotes)) + (remote (if (length= remotes 1) + (car remotes) + (magit-primary-remote)))) + (magit--propertize-face remote 'magit-branch-remote)))) + +(defun magit-get-push-remote (&optional branch) + (and-let* ((remote + (or (and (or branch (setq branch (magit-get-current-branch))) + (magit-get "branch" branch "pushRemote")) + (magit-get "remote.pushDefault")))) + (magit--propertize-face remote 'magit-branch-remote))) + +(defun magit-get-push-branch (&optional branch verify) + (magit--with-refresh-cache + (list default-directory 'magit-get-push-branch branch verify) + (and-let* ((branch (or branch (setq branch (magit-get-current-branch)))) + (remote (magit-get-push-remote branch)) + (target (concat remote "/" branch))) + (and (or (not verify) + (magit-rev-verify target)) + (magit--propertize-face target 'magit-branch-remote))))) + +(defun magit-get-@{push}-branch (&optional branch) + (let ((ref (magit-rev-parse "--symbolic-full-name" + (concat branch "@{push}")))) + (and ref + (string-prefix-p "refs/remotes/" ref) + (substring ref 13)))) + +(defun magit-get-remote (&optional branch) + (and (or branch (setq branch (magit-get-current-branch))) + (let ((remote (magit-get "branch" branch "remote"))) + (and (not (equal remote ".")) + remote)))) + +(defun magit-get-some-remote (&optional branch) + (or (magit-get-remote branch) + (and-let* ((main (magit-main-branch))) + (magit-get-remote main)) + (magit-primary-remote) + (car (magit-list-remotes)))) + +(defvar magit-primary-remote-names + '("upstream" "origin")) + +(defun magit-primary-remote () + "Return the primary remote. + +The primary remote is the remote that tracks the repository that +other repositories are forked from. It often is called \"origin\" +but because many people name their own fork \"origin\", using that +term would be ambiguous. Likewise we avoid the term \"upstream\" +because a branch's @{upstream} branch may be a local branch or a +branch from a remote other than the primary remote. + +If a remote exists whose name matches `magit.primaryRemote', then +that is considered the primary remote. If no remote by that name +exists, then remotes in `magit-primary-remote-names' are tried in +order and the first remote from that list that actually exists in +the current repository is considered its primary remote." + (let ((remotes (magit-list-remotes))) + (seq-find (lambda (name) + (member name remotes)) + (delete-dups + (delq nil + (cons (magit-get "magit.primaryRemote") + magit-primary-remote-names)))))) + +(defun magit-branch-merged-p (branch &optional target) + "Return non-nil if BRANCH is merged into its upstream and TARGET. + +TARGET defaults to the current branch. If `HEAD' is detached and +TARGET is nil, then always return nil. As a special case, if +TARGET is t, then return non-nil if BRANCH is merged into any one +of the other local branches. + +If, and only if, BRANCH has an upstream, then only return non-nil +if BRANCH is merged into both TARGET (as described above) as well +as into its upstream." + (and (if-let ((upstream (and (magit-branch-p branch) + (magit-get-upstream-branch branch)))) + (magit-rev-ancestor-p branch upstream) + t) + (if (eq target t) + (delete (magit-name-local-branch branch) + (magit-list-containing-branches branch)) + (and-let* ((target (or target (magit-get-current-branch)))) + (magit-rev-ancestor-p branch target))))) + +(defun magit-get-tracked (refname) + "Return the remote branch tracked by the remote-tracking branch REFNAME. +The returned value has the form (REMOTE . REF), where REMOTE is +the name of a remote and REF is the ref local to the remote." + (and-let* ((ref (magit-ref-fullname refname))) + (save-match-data + (seq-some (lambda (line) + (and (string-match "\ +\\`remote\\.\\([^.]+\\)\\.fetch=\\+?\\([^:]+\\):\\(.+\\)" line) + (let ((rmt (match-string 1 line)) + (src (match-string 2 line)) + (dst (match-string 3 line))) + (and (string-match (format "\\`%s\\'" + (string-replace + "*" "\\(.+\\)" dst)) + ref) + (cons rmt (string-replace + "*" (match-string 1 ref) src)))))) + (magit-git-lines "config" "--local" "--list"))))) + +(defun magit-split-branch-name (branch) + (cond ((member branch (magit-list-local-branch-names)) + (cons "." branch)) + ((string-match "/" branch) + (or (seq-some (lambda (remote) + (and (string-match + (format "\\`\\(%s\\)/\\(.+\\)\\'" remote) + branch) + (cons (match-string 1 branch) + (match-string 2 branch)))) + (magit-list-remotes)) + (error "Invalid branch name %s" branch))))) + +(defun magit-get-current-tag (&optional rev with-distance) + "Return the closest tag reachable from REV. + +If optional REV is nil, then default to `HEAD'. +If optional WITH-DISTANCE is non-nil then return (TAG COMMITS), +if it is `dirty' return (TAG COMMIT DIRTY). COMMITS is the number +of commits in `HEAD' but not in TAG and DIRTY is t if there are +uncommitted changes, nil otherwise." + (and-let* ((str (magit-git-str "describe" "--long" "--tags" + (and (eq with-distance 'dirty) "--dirty") + rev))) + (save-match-data + (string-match + "\\(.+\\)-\\(?:0[0-9]*\\|\\([0-9]+\\)\\)-g[0-9a-z]+\\(-dirty\\)?$" str) + (if with-distance + `(,(match-string 1 str) + ,(string-to-number (or (match-string 2 str) "0")) + ,@(and (match-string 3 str) (list t))) + (match-string 1 str))))) + +(defun magit-get-next-tag (&optional rev with-distance) + "Return the closest tag from which REV is reachable. + +If optional REV is nil, then default to `HEAD'. +If no such tag can be found or if the distance is 0 (in which +case it is the current tag, not the next), return nil instead. +If optional WITH-DISTANCE is non-nil, then return (TAG COMMITS) +where COMMITS is the number of commits in TAG but not in REV." + (and-let* ((str (magit-git-str "describe" "--contains" (or rev "HEAD")))) + (save-match-data + (when (string-match "^[^^~]+" str) + (setq str (match-string 0 str)) + (unless (equal str (magit-get-current-tag rev)) + (if with-distance + (list str (car (magit-rev-diff-count str rev))) + str)))))) + +(defun magit-list-refs (&optional namespaces format sortby) + "Return list of references, excluding symbolic references. + +When NAMESPACES is non-nil, list refs from these namespaces +rather than those from `magit-list-refs-namespaces'. + +FORMAT is passed to the `--format' flag of `git for-each-ref' +and defaults to \"%(refname)\". + +SORTBY is a key or list of keys to pass to the `--sort' flag of +`git for-each-ref'. When nil, use `magit-list-refs-sortby'" + (unless format + (setq format "%(refname)")) + (seq-keep (lambda (line) + (pcase-let* ((`(,symrefp ,value) + (split-string line " ")) + (symrefp (not (equal symrefp "")))) + (and (not symrefp) value))) + (magit-git-lines "for-each-ref" + (concat "--format=%(symref) " format) + (--map (concat "--sort=" it) + (pcase (or sortby magit-list-refs-sortby) + ((and val (pred stringp)) (list val)) + ((and val (pred listp)) val))) + (or namespaces magit-list-refs-namespaces)))) + +(defun magit-list-branches () + (magit-list-refs (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branches () + (magit-list-refs "refs/heads")) + +(defun magit-list-remote-branches (&optional remote) + (magit-list-refs (concat "refs/remotes/" remote))) + +(defun magit-list-related-branches (relation &optional commit &rest args) + (--remove (string-match-p "\\(\\`(HEAD\\|HEAD -> \\)" it) + (--map (substring it 2) + (magit-git-lines "branch" args relation commit)))) + +(defun magit-list-containing-branches (&optional commit &rest args) + (magit-list-related-branches "--contains" commit args)) + +(defun magit-list-publishing-branches (&optional commit) + (--filter (magit-rev-ancestor-p (or commit "HEAD") it) + magit-published-branches)) + +(defun magit-list-merged-branches (&optional commit &rest args) + (magit-list-related-branches "--merged" commit args)) + +(defun magit-list-unmerged-branches (&optional commit &rest args) + (magit-list-related-branches "--no-merged" commit args)) + +(defun magit-list-unmerged-to-upstream-branches () + (--filter (and-let* ((upstream (magit-get-upstream-branch it))) + (member it (magit-list-unmerged-branches upstream))) + (magit-list-local-branch-names))) + +(defun magit-list-branches-pointing-at (commit) + (let ((re (format "\\`%s refs/\\(heads\\|remotes\\)/\\(.*\\)\\'" + (magit-rev-verify commit)))) + (--keep (and (string-match re it) + (let ((name (match-string 2 it))) + (and (not (string-suffix-p "HEAD" name)) + name))) + (magit-git-lines "show-ref")))) + +(defun magit-list-refnames (&optional namespaces include-special) + (nconc (magit-list-refs namespaces "%(refname:short)") + (and include-special + (magit-list-special-refnames)))) + +(defvar magit-special-refnames + '("HEAD" "ORIG_HEAD" "FETCH_HEAD" "MERGE_HEAD" "CHERRY_PICK_HEAD")) + +(defun magit-list-special-refnames () + (let ((gitdir (magit-gitdir))) + (cl-mapcan (lambda (name) + (and (file-exists-p (expand-file-name name gitdir)) + (list name))) + magit-special-refnames))) + +(defun magit-list-branch-names () + (magit-list-refnames (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branch-names () + (magit-list-refnames "refs/heads")) + +(defun magit-list-remote-branch-names (&optional remote relative) + (if (and remote relative) + (let ((regexp (format "^refs/remotes/%s/\\(.+\\)" remote))) + (--mapcat (when (string-match regexp it) + (list (match-string 1 it))) + (magit-list-remote-branches remote))) + (magit-list-refnames (concat "refs/remotes/" remote)))) + +(defun magit-format-refs (format &rest args) + (let ((lines (magit-git-lines + "for-each-ref" (concat "--format=" format) + (or args (list "refs/heads" "refs/remotes" "refs/tags"))))) + (if (string-search "\f" format) + (--map (split-string it "\f") lines) + lines))) + +(defun magit-list-remotes () + (magit-git-lines "remote")) + +(defun magit-list-tags () + (magit-git-lines "tag")) + +(defun magit-list-stashes (&optional format) + (magit-git-lines "stash" "list" (concat "--format=" (or format "%gd")))) + +(defun magit-list-active-notes-refs () + "Return notes refs according to `core.notesRef' and `notes.displayRef'." + (magit-git-lines "for-each-ref" "--format=%(refname)" + (or (magit-get "core.notesRef") "refs/notes/commits") + (magit-get-all "notes.displayRef"))) + +(defun magit-list-notes-refnames () + (--map (substring it 6) (magit-list-refnames "refs/notes"))) + +(defun magit-remote-list-tags (remote) + (--keep (and (not (string-suffix-p "^{}" it)) + (substring it 51)) + (magit-git-lines "ls-remote" "--tags" remote))) + +(defun magit-remote-list-branches (remote) + (--keep (and (not (string-suffix-p "^{}" it)) + (substring it 52)) + (magit-git-lines "ls-remote" "--heads" remote))) + +(defun magit-remote-list-refs (remote) + (--keep (and (not (string-suffix-p "^{}" it)) + (substring it 41)) + (magit-git-lines "ls-remote" remote))) + +(defun magit-remote-head (remote) + (and-let* ((line (cl-find-if + (lambda (line) + (string-match + "\\`ref: refs/heads/\\([^\s\t]+\\)[\s\t]HEAD\\'" line)) + (magit-git-lines "ls-remote" "--symref" remote "HEAD")))) + (match-string 1 line))) + +(defun magit-list-modified-modules () + (--keep (and (string-match "\\`\\+\\([^ ]+\\) \\(.+\\) (.+)\\'" it) + (match-string 2 it)) + (magit-git-lines "submodule" "status"))) + +(defun magit-list-module-paths () + (magit-with-toplevel + (--mapcat (and (string-match "^160000 [0-9a-z]\\{40,\\} 0\t\\(.+\\)$" it) + (list (match-string 1 it))) + (magit-git-items "ls-files" "-z" "--stage")))) + +(defun magit-list-module-names () + (mapcar #'magit-get-submodule-name (magit-list-module-paths))) + +(defun magit-get-submodule-name (path) + "Return the name of the submodule at PATH. +PATH has to be relative to the super-repository." + (if (magit-git-version>= "2.38.0") + ;; "git submodule--helper name" was removed, + ;; but might still come back in another form. + (substring + (car (split-string + (car (or (magit-git-items + "config" "-z" + "-f" (expand-file-name ".gitmodules" (magit-toplevel)) + "--get-regexp" "^submodule\\..*\\.path$" + (concat "^" (regexp-quote (directory-file-name path)) "$")) + (error "No such submodule `%s'" path))) + "\n")) + 10 -5) + (magit-git-string "submodule--helper" "name" path))) + +(defun magit-list-worktrees () + "Return list of the worktrees of this repository. + +The returned list has the form (PATH COMMIT BRANCH BARE DETACHED +LOCKED PRUNABLE). The last four elements are booleans, with the +exception of LOCKED and PRUNABLE, which may also be strings. +See git-worktree(1) manpage for the meaning of the various parts. + +This function corrects a situation where \"git worktree list\" +would claim a worktree is bare, even though the working tree is +specified using `core.worktree'." + (let ((remote (file-remote-p default-directory)) + worktrees worktree) + (dolist (line (let ((magit-git-global-arguments + ;; KLUDGE At least in Git v2.8.3 this argument + ;; would trigger a segfault. + (remove "--no-pager" magit-git-global-arguments))) + (if (magit-git-version>= "2.36") + (magit-git-items "worktree" "list" "--porcelain" "-z") + (magit-git-lines "worktree" "list" "--porcelain")))) + (cond ((string-prefix-p "worktree" line) + (let ((path (substring line 9))) + (when remote + (setq path (concat remote path))) + ;; If the git directory is separate from the main + ;; worktree, then "git worktree" returns the git + ;; directory instead of the worktree, which isn't + ;; what it is supposed to do and not what we want. + ;; However, if the worktree has been removed, then + ;; we want to return it anyway; instead of nil. + (setq path (or (magit-toplevel path) path)) + (setq worktree (list path nil nil nil nil nil nil)) + (push worktree worktrees))) + ((string-prefix-p "HEAD" line) + (setf (nth 1 worktree) (substring line 5))) + ((string-prefix-p "branch" line) + (setf (nth 2 worktree) (substring line 18))) + ((string-equal line "bare") + (let* ((default-directory (car worktree)) + (wt (and (not (magit-get-boolean "core.bare")) + (magit-get "core.worktree")))) + (if (and wt (file-exists-p (expand-file-name wt))) + (progn (setf (nth 0 worktree) (expand-file-name wt)) + (setf (nth 2 worktree) (magit-rev-parse "HEAD")) + (setf (nth 3 worktree) (magit-get-current-branch))) + (setf (nth 3 worktree) t)))) + ((string-equal line "detached") + (setf (nth 4 worktree) t)) + ((string-prefix-p line "locked") + (setf (nth 5 worktree) + (if (> (length line) 6) (substring line 7) t))) + ((string-prefix-p line "prunable") + (setf (nth 6 worktree) + (if (> (length line) 8) (substring line 9) t))))) + (nreverse worktrees))) + +(defun magit-symbolic-ref-p (name) + (magit-git-success "symbolic-ref" "--quiet" name)) + +(defun magit-ref-p (rev) + (or (car (member rev (magit-list-refs "refs/"))) + (car (member rev (magit-list-refnames "refs/"))))) + +(defun magit-branch-p (rev) + (or (car (member rev (magit-list-branches))) + (car (member rev (magit-list-branch-names))))) + +(defun magit-local-branch-p (rev) + (or (car (member rev (magit-list-local-branches))) + (car (member rev (magit-list-local-branch-names))))) + +(defun magit-remote-branch-p (rev) + (or (car (member rev (magit-list-remote-branches))) + (car (member rev (magit-list-remote-branch-names))))) + +(defun magit-branch-set-face (branch) + (magit--propertize-face branch (if (magit-local-branch-p branch) + 'magit-branch-local + 'magit-branch-remote))) + +(defun magit-tag-p (rev) + (car (member rev (magit-list-tags)))) + +(defun magit-remote-p (string) + (car (member string (magit-list-remotes)))) + +(defvar magit-main-branch-names + '("main" "master" "trunk" "development") + "Branch names reserved for use by the primary branch. +Use function `magit-main-branch' to get the name actually used in +the current repository.") + +(defvar magit-long-lived-branches + (append magit-main-branch-names (list "maint" "next")) + "Branch names reserved for use by long lived branches.") + +(defun magit-main-branch () + "Return the main branch. + +If a branch exists whose name matches `init.defaultBranch', then +that is considered the main branch. If no branch by that name +exists, then the branch names in `magit-main-branch-names' are +tried in order. The first branch from that list that actually +exists in the current repository is considered its main branch." + (let ((branches (magit-list-local-branch-names))) + (seq-find (lambda (name) + (member name branches)) + (delete-dups + (delq nil + (cons (magit-get "init.defaultBranch") + magit-main-branch-names)))))) + +(defun magit-rev-diff-count (a b &optional first-parent) + "Return the commits in A but not B and vice versa. +Return a list of two integers: (A>B B>A). + +If `first-parent' is set, traverse only first parents." + (mapcar #'string-to-number + (split-string (magit-git-string "rev-list" + "--count" "--left-right" + (and first-parent "--first-parent") + (concat a "..." b)) + "\t"))) + +(defun magit-abbrev-length () + (let ((abbrev (magit-get "core.abbrev"))) + (if (and abbrev (not (equal abbrev "auto"))) + (string-to-number abbrev) + ;; Guess the length git will be using based on an example + ;; abbreviation. Actually HEAD's abbreviation might be an + ;; outlier, so use the shorter of the abbreviations for two + ;; commits. See #3034. + (if-let ((head (magit-rev-parse "--short" "HEAD")) + (head-len (length head))) + (min head-len + (if-let ((rev (magit-rev-parse "--short" "HEAD~"))) + (length rev) + head-len)) + ;; We're on an unborn branch, but perhaps the repository has + ;; other commits. See #4123. + (if-let ((commits (magit-git-lines "rev-list" "-n2" "--all" + "--abbrev-commit"))) + (apply #'min (mapcar #'length commits)) + ;; A commit does not exist. Fall back to the default of 7. + 7))))) + +(defun magit-abbrev-arg (&optional arg) + (format "--%s=%d" (or arg "abbrev") (magit-abbrev-length))) + +(defun magit-rev-abbrev (rev) + (magit-rev-parse (magit-abbrev-arg "short") rev)) + +(defun magit-commit-children (commit &optional args) + (mapcar #'car + (--filter (member commit (cdr it)) + (--map (split-string it " ") + (magit-git-lines + "log" "--format=%H %P" + (or args (list "--branches" "--tags" "--remotes")) + "--not" commit))))) + +(defun magit-commit-parents (commit) + (and-let* ((str (magit-git-string "rev-list" "-1" "--parents" commit))) + (cdr (split-string str)))) + +(defun magit-patch-id (rev) + (magit--with-connection-local-variables + (magit--with-temp-process-buffer + (magit-process-file + shell-file-name nil '(t nil) nil shell-command-switch + (let ((exec (shell-quote-argument (magit-git-executable)))) + (format "%s diff-tree -u %s | %s patch-id" exec rev exec))) + (car (split-string (buffer-string)))))) + +(defun magit-rev-format (format &optional rev args) + ;; Prefer `git log --no-walk' to `git show --no-patch' because it + ;; performs better in some scenarios. + (let ((str (magit-git-string "log" "--no-walk" + (concat "--format=" format) args + (if rev (magit--rev-dereference rev) "HEAD") + "--"))) + (and (not (string-equal str "")) + str))) + +(defun magit-rev-insert-format (format &optional rev args) + ;; Prefer `git log --no-walk' to `git show --no-patch' because it + ;; performs better in some scenarios. + (magit-git-insert "log" "--no-walk" + (concat "--format=" format) args + (if rev (magit--rev-dereference rev) "HEAD") + "--")) + +(defun magit-format-rev-summary (rev) + (and-let* ((str (magit-rev-format "%h %s" rev))) + (progn + (magit--put-face 0 (string-match " " str) 'magit-hash str) + str))) + +(defvar magit-ref-namespaces + '(("\\`HEAD\\'" . magit-head) + ("\\`refs/tags/\\(.+\\)" . magit-tag) + ("\\`refs/heads/\\(.+\\)" . magit-branch-local) + ("\\`refs/remotes/\\(.+\\)" . magit-branch-remote) + ("\\`refs/bisect/\\(bad\\)" . magit-bisect-bad) + ("\\`refs/bisect/\\(skip.*\\)" . magit-bisect-skip) + ("\\`refs/bisect/\\(good.*\\)" . magit-bisect-good) + ("\\`refs/stash$" . magit-refname-stash) + ("\\`refs/wip/\\(.+\\)" . magit-refname-wip) + ("\\`refs/pullreqs/\\(.+\\)" . magit-refname-pullreq) + ("\\`\\(bad\\):" . magit-bisect-bad) + ("\\`\\(skip\\):" . magit-bisect-skip) + ("\\`\\(good\\):" . magit-bisect-good) + ("\\`\\(.+\\)" . magit-refname)) + "How refs are formatted for display. + +Each entry controls how a certain type of ref is displayed, and +has the form (REGEXP . FACE). REGEXP is a regular expression +used to match full refs. The first entry whose REGEXP matches +the reference is used. + +In log and revision buffers the first regexp submatch becomes the +\"label\" that represents the ref and is propertized with FONT. +In refs buffers the displayed text is controlled by other means +and this option only controls what face is used.") + +(defun magit-format-ref-labels (string) + (save-match-data + (let ((regexp "\\(, \\|tag: \\|HEAD -> \\)") + names) + (if (and (derived-mode-p 'magit-log-mode) + (member "--simplify-by-decoration" magit-buffer-log-args)) + (let ((branches (magit-list-local-branch-names)) + (re (format "^%s/.+" (regexp-opt (magit-list-remotes))))) + (setq names + (--map (cond ((string-equal it "HEAD") it) + ((string-prefix-p "refs/" it) it) + ((member it branches) (concat "refs/heads/" it)) + ((string-match re it) (concat "refs/remotes/" it)) + (t (concat "refs/" it))) + (split-string + (string-replace "tag: " "refs/tags/" string) + regexp t)))) + (setq names (split-string string regexp t))) + (let (state head upstream tags branches remotes other combined) + (dolist (ref names) + (let* ((face (cdr (--first (string-match (car it) ref) + magit-ref-namespaces))) + (name (magit--propertize-face + (or (match-string 1 ref) ref) face))) + (cl-case face + ((magit-bisect-bad magit-bisect-skip magit-bisect-good) + (setq state name)) + (magit-head + (setq head (magit--propertize-face "@" 'magit-head))) + (magit-tag (push name tags)) + (magit-branch-local (push name branches)) + (magit-branch-remote (push name remotes)) + (t (push name other))))) + (setq remotes + (seq-keep + (lambda (name) + (if (string-match "\\`\\([^/]*\\)/\\(.*\\)\\'" name) + (let ((r (match-string 1 name)) + (b (match-string 2 name))) + (and (not (equal b "HEAD")) + (if (equal (concat "refs/remotes/" name) + (magit-git-string + "symbolic-ref" + (format "refs/remotes/%s/HEAD" r))) + (magit--propertize-face + name 'magit-branch-remote-head) + name))) + name)) + remotes)) + (let* ((current (magit-get-current-branch)) + (target (magit-get-upstream-branch current))) + (dolist (name branches) + (let ((push (car (member (magit-get-push-branch name) remotes)))) + (when push + (setq remotes (delete push remotes)) + (string-match "^[^/]*/" push) + (setq push (substring push 0 (match-end 0)))) + (cond + ((equal name current) + (setq head + (concat push + (magit--propertize-face + name 'magit-branch-current)))) + ((equal name target) + (setq upstream + (concat push + (magit--propertize-face + name '(magit-branch-upstream + magit-branch-local))))) + (t + (push (concat push name) combined))))) + (when (and target (not upstream)) + (if (member target remotes) + (progn + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq remotes (delete target remotes))) + (when-let ((target (car (member target combined)))) + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq combined (delete target combined)))))) + (string-join (flatten-tree `(,state + ,head + ,upstream + ,@(nreverse tags) + ,@(nreverse combined) + ,@(nreverse remotes) + ,@other)) + " "))))) + +(defun magit-object-type (object) + (magit-git-string "cat-file" "-t" object)) + +(defmacro magit-with-blob (commit file &rest body) + (declare (indent 2) + (debug (form form body))) + `(magit--with-temp-process-buffer + (let ((buffer-file-name ,file)) + (save-excursion + (magit-git-insert "cat-file" "-p" + (concat ,commit ":" buffer-file-name))) + (decode-coding-inserted-region + (point-min) (point-max) buffer-file-name t nil nil t) + ,@body))) + +(defmacro magit-with-temp-index (tree arg &rest body) + (declare (indent 2) (debug (form form body))) + (let ((file (cl-gensym "file"))) + `(let ((magit--refresh-cache nil) + (,file (magit-convert-filename-for-git + (make-temp-name + (expand-file-name "index.magit." (magit-gitdir)))))) + (unwind-protect + (magit-with-toplevel + (when-let* ((tree ,tree) + ((not (magit-git-success + "read-tree" ,arg tree + (concat "--index-output=" ,file))))) + (error "Cannot read tree %s" tree)) + (with-environment-variables (("GIT_INDEX_FILE" ,file)) + ,@body)) + (ignore-errors + (delete-file (concat (file-remote-p default-directory) ,file))))))) + +(defun magit-commit-tree (message &optional tree &rest parents) + (magit-git-string "commit-tree" "--no-gpg-sign" "-m" message + (--mapcat (list "-p" it) (delq nil parents)) + (or tree + (magit-git-string "write-tree") + (error "Cannot write tree")))) + +(defun magit-commit-worktree (message &optional arg &rest other-parents) + (magit-with-temp-index "HEAD" arg + (and (magit-update-files (magit-unstaged-files)) + (apply #'magit-commit-tree message nil "HEAD" other-parents)))) + +(defun magit-update-files (files) + (magit-git-success "update-index" "--add" "--remove" "--" files)) + +(defun magit-update-ref (ref message rev &optional stashish) + (let ((magit--refresh-cache nil)) + (or (if (magit-git-version>= "2.6.0") + (zerop (magit-call-git "update-ref" "--create-reflog" + "-m" message ref rev + (or (magit-rev-verify ref) ""))) + ;; `--create-reflog' didn't exist before v2.6.0 + (let ((oldrev (magit-rev-verify ref)) + (logfile (expand-file-name (concat "logs/" ref) + (magit-gitdir)))) + (unless (file-exists-p logfile) + (when oldrev + (magit-git-success "update-ref" "-d" ref oldrev)) + (make-directory (file-name-directory logfile) t) + (with-temp-file logfile) + (when (and oldrev (not stashish)) + (magit-git-success "update-ref" "-m" "enable reflog" + ref oldrev "")))) + (magit-git-success "update-ref" "-m" message ref rev + (or (magit-rev-verify ref) ""))) + (error "Cannot update %s with %s" ref rev)))) + +(defconst magit-range-re + (concat "\\`\\([^ \t]*[^.]\\)?" ; revA + "\\(\\.\\.\\.?\\)" ; range marker + "\\([^.][^ \t]*\\)?\\'")) ; revB + +(defun magit-split-range (range) + (pcase-let ((`(,beg ,end ,sep) (magit--split-range-raw range))) + (and sep + (let ((beg (or beg "HEAD")) + (end (or end "HEAD"))) + (if (string-equal (match-string 2 range) "...") + (and-let* ((base (magit-git-string "merge-base" beg end))) + (cons base end)) + (cons beg end)))))) + +(defun magit--split-range-raw (range) + (and (string-match magit-range-re range) + (let ((beg (match-string 1 range)) + (end (match-string 3 range))) + (and (or beg end) + (list beg end (match-string 2 range)))))) + +(defun magit-hash-range (range) + (if (string-match magit-range-re range) + (let ((beg (match-string 1 range)) + (end (match-string 3 range))) + (and (or beg end) + (let ((beg-hash (and beg (magit-rev-hash (match-string 1 range)))) + (end-hash (and end (magit-rev-hash (match-string 3 range))))) + (and (or (not beg) beg-hash) + (or (not end) end-hash) + (concat beg-hash (match-string 2 range) end-hash))))) + (magit-rev-hash range))) + +(defvar magit-revision-faces + '(magit-hash + magit-tag + magit-branch-remote + magit-branch-remote-head + magit-branch-local + magit-branch-current + magit-branch-upstream + magit-branch-warning + magit-head + magit-refname + magit-refname-stash + magit-refname-wip + magit-refname-pullreq)) + +(put 'git-revision 'thing-at-point #'magit-thingatpt--git-revision) +(defun magit-thingatpt--git-revision (&optional disallow) + ;; Support hashes and references. + (and-let* ((bounds + (let ((c (concat "\s\n\t~^:?*[\\" disallow))) + (cl-letf + (((get 'git-revision 'beginning-op) + (lambda () + (if (re-search-backward (format "[%s]" c) nil t) + (forward-char) + (goto-char (point-min))))) + ((get 'git-revision 'end-op) + (lambda () + (re-search-forward (format "\\=[^%s]*" c) nil t)))) + (bounds-of-thing-at-point 'git-revision)))) + (string (buffer-substring-no-properties (car bounds) (cdr bounds))) + ;; References are allowed to contain most parentheses and + ;; most punctuation, but if those characters appear at the + ;; edges of a possible reference in arbitrary text, then + ;; they are much more likely to be intended as just that: + ;; punctuation and delimiters. + (string (thread-first string + (string-trim-left "[(</]") + (string-trim-right "[])>/.,;!]")))) + (let (disallow) + (when (or (string-match-p "\\.\\." string) + (string-match-p "/\\." string)) + (setq disallow (concat disallow "."))) + (when (string-match-p "@{" string) + (setq disallow (concat disallow "@{"))) + (if disallow + ;; These additional restrictions overcompensate, + ;; but that only matters in rare cases. + (magit-thingatpt--git-revision disallow) + (and (not (equal string "@")) + (or (and (>= (length string) 7) + (string-match-p "[a-z]" string) + (magit-commit-p string)) + (and (magit-ref-p string) + (let ((face (get-text-property (point) 'face))) + (or (not face) + (member face magit-revision-faces))))) + string))))) + +(put 'git-revision-range 'thing-at-point #'magit-thingatpt--git-revision-range) +(defun magit-thingatpt--git-revision-range () + ;; Support hashes but no references. + (and-let* ((bounds + (cl-letf (((get 'git-revision 'beginning-op) + (lambda () + (if (re-search-backward "[^a-z0-9.]" nil t) + (forward-char) + (goto-char (point-min))))) + ((get 'git-revision 'end-op) + (lambda () + (and (re-search-forward "[^a-z0-9.]" nil t) + (backward-char))))) + (bounds-of-thing-at-point 'git-revision))) + (range (buffer-substring-no-properties (car bounds) (cdr bounds)))) + ;; Validate but return as-is. + (and (magit-hash-range range) range))) + +;;; Completion + +(defvar magit-revision-history nil) + +(defun magit--minibuf-default-add-commit () + (let ((fn minibuffer-default-add-function)) + (setq-local + minibuffer-default-add-function + (lambda () + (let ((rest (and (functionp fn) (funcall fn)))) + (if-let ((commit (with-selected-window (minibuffer-selected-window) + (or (magit-thing-at-point 'git-revision-range t) + (magit-commit-at-point))))) + (let ((rest (cons commit (delete commit rest))) + (def minibuffer-default)) + (if (listp def) + (append def rest) + (cons def (delete def rest)))) + rest)))))) + +(defun magit-read-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-branch-or-commit (prompt &optional secondary-default exclude) + (let ((current (magit-get-current-branch)) + (branch-at-point (magit-branch-at-point)) + (commit-at-point (magit-commit-at-point)) + (choices (delete exclude (magit-list-refnames nil t)))) + (when (equal current exclude) + (setq current nil)) + (when (equal branch-at-point exclude) + (setq branch-at-point nil)) + (when (and commit-at-point (not branch-at-point)) + (setq choices (cons commit-at-point choices))) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read + prompt choices nil nil nil 'magit-revision-history + (or branch-at-point commit-at-point secondary-default current)) + (user-error "Nothing selected"))))) + +(defun magit-read-range-or-commit (prompt &optional secondary-default) + (magit-read-range + prompt + (or (and-let* ((revs (magit-region-values '(commit branch) t))) + (progn + (deactivate-mark) + (concat (car (last revs)) ".." (car revs)))) + (magit-branch-or-commit-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-range (prompt &optional default) + (minibuffer-with-setup-hook + (lambda () + (magit--minibuf-default-add-commit) + (setq-local crm-separator "\\.\\.\\.?")) + (magit-completing-read-multiple + (concat prompt ": ") + (magit-list-refnames) + nil nil nil 'magit-revision-history default nil t))) + +(defun magit-read-remote-branch + (prompt &optional remote default local-branch require-match) + (let ((choice (magit-completing-read + prompt + (cl-union (and local-branch + (if remote + (list local-branch) + (--map (concat it "/" local-branch) + (magit-list-remotes)))) + (magit-list-remote-branch-names remote t) + :test #'equal) + nil require-match nil 'magit-revision-history default))) + (if (or remote (string-match "\\`\\([^/]+\\)/\\(.+\\)" choice)) + choice + (user-error "`%s' doesn't have the form REMOTE/BRANCH" choice)))) + +(defun magit-read-refspec (prompt remote) + (magit-completing-read prompt + (prog2 (message "Determining available refs...") + (magit-remote-list-refs remote) + (message "Determining available refs...done")))) + +(defun magit-read-local-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-local-branch-names) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-local-branch-or-commit (prompt) + (let ((choices (nconc (magit-list-local-branch-names) + (magit-list-special-refnames))) + (commit (magit-commit-at-point))) + (when commit + (push commit choices)) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read prompt choices + nil nil nil 'magit-revision-history + (or (magit-local-branch-at-point) commit)) + (user-error "Nothing selected"))))) + +(defun magit-read-local-branch-or-ref (prompt &optional secondary-default) + (magit-completing-read prompt (nconc (magit-list-local-branch-names) + (magit-list-refs "refs/")) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-other-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt (delete exclude (magit-list-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-other-branch-or-commit + (prompt &optional exclude secondary-default) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-or-commit-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) + (not (and (not current) + (magit-rev-equal atpoint "HEAD"))) + atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read prompt (delete exclude (magit-list-refnames)) + nil nil nil 'magit-revision-history default) + (user-error "Nothing selected"))))) + +(defun magit-read-other-local-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-local-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt + (delete exclude (magit-list-local-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-branch-prefer-other (prompt) + (let* ((current (magit-get-current-branch)) + (commit (magit-commit-at-point)) + (atrev (and commit (magit-list-branches-pointing-at commit))) + (atpoint (magit--painted-branch-at-point))) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-section-value-if 'branch) + atpoint + (and (not (cdr atrev)) (car atrev)) + (--first (not (equal it current)) atrev) + (magit-get-previous-branch) + (car atrev))))) + +(defun magit-read-upstream-branch (&optional branch prompt) + "Read the upstream for BRANCH using PROMPT. +If optional BRANCH is nil, then read the upstream for the +current branch, or raise an error if no branch is checked +out. Only existing branches can be selected." + (unless branch + (setq branch (or (magit-get-current-branch) + (error "Need a branch to set its upstream")))) + (let ((branches (delete branch (magit-list-branch-names)))) + (magit-completing-read + (or prompt (format "Change upstream of %s to" branch)) + branches nil t nil 'magit-revision-history + (or (let ((r (car (member (magit-remote-branch-at-point) branches))) + (l (car (member (magit-local-branch-at-point) branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (and-let* ((main (magit-main-branch))) + (let ((r (car (member (concat "origin/" main) branches))) + (l (car (member main branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r)))) + (car (member (magit-get-previous-branch) branches)))))) + +(defun magit-read-starting-point (prompt &optional branch default) + (or (magit-completing-read + (concat prompt + (and branch + (if (bound-and-true-p ivy-mode) + ;; Ivy-mode strips faces from prompt. + (format " `%s'" branch) + (concat " " (magit--propertize-face + branch 'magit-branch-local)))) + " starting at") + (nconc (list "HEAD") + (magit-list-refnames) + (directory-files (magit-gitdir) nil "_HEAD\\'")) + nil nil nil 'magit-revision-history + (or default (magit--default-starting-point))) + (user-error "Nothing selected"))) + +(defun magit--default-starting-point () + (or (let ((r (magit-remote-branch-at-point)) + (l (magit-local-branch-at-point))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (magit-commit-at-point) + (magit-stash-at-point) + (magit-get-current-branch))) + +(defun magit-read-tag (prompt &optional require-match) + (magit-completing-read prompt (magit-list-tags) nil + require-match nil 'magit-revision-history + (magit-tag-at-point))) + +(defun magit-read-stash (prompt) + (let* ((atpoint (magit-stash-at-point)) + (default (and atpoint + (concat atpoint (magit-rev-format " %s" atpoint)))) + (choices (mapcar (lambda (c) + (pcase-let ((`(,rev ,msg) (split-string c "\0"))) + (concat (propertize rev 'face 'magit-hash) + " " msg))) + (magit-list-stashes "%gd%x00%s"))) + (choice (magit-completing-read prompt choices + nil t nil nil + default + (car choices)))) + (and choice + (string-match "^\\([^ ]+\\) \\(.+\\)" choice) + (substring-no-properties (match-string 1 choice))))) + +(defun magit-read-remote (prompt &optional default use-only) + (let ((remotes (magit-list-remotes))) + (if (and use-only (length= remotes 1)) + (car remotes) + (magit-completing-read prompt remotes + nil t nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))))) + +(defun magit-read-remote-or-url (prompt &optional default) + (magit-completing-read prompt + (nconc (magit-list-remotes) + (list "https://" "git://" "git@")) + nil nil nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))) + +(defun magit-read-module-path (prompt &optional predicate) + (magit-completing-read prompt (magit-list-module-paths) + predicate t nil nil + (magit-module-at-point predicate))) + +(defun magit-module-confirm (verb &optional predicate) + ;; Some predicates use the inefficient `magit-toplevel' + ;; and some repositories have thousands of submodules. + (let ((magit--refresh-cache (list (cons 0 0))) + (modules nil)) + (if current-prefix-arg + (progn + (setq modules (magit-list-module-paths)) + (when predicate + (setq modules (seq-filter predicate modules))) + (unless modules + (if predicate + (user-error "No modules satisfying %s available" predicate) + (user-error "No modules available")))) + (setq modules (magit-region-values 'module)) + (when modules + (when predicate + (setq modules (seq-filter predicate modules))) + (unless modules + (user-error "No modules satisfying %s selected" predicate)))) + (if (or (length> modules 1) current-prefix-arg) + (magit-confirm t nil (format "%s %%d modules" verb) nil modules) + (list (magit-read-module-path (format "%s module" verb) predicate))))) + +;;; _ +(provide 'magit-git) +;;; magit-git.el ends here diff --git a/emacs/elpa/magit-20241116.1557/magit-git.elc b/emacs/elpa/magit-20241116.1557/magit-git.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-gitignore.el b/emacs/elpa/magit-20241116.1557/magit-gitignore.el diff --git a/emacs/elpa/magit-20241106.1441/magit-gitignore.elc b/emacs/elpa/magit-20241116.1557/magit-gitignore.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-log.el b/emacs/elpa/magit-20241116.1557/magit-log.el diff --git a/emacs/elpa/magit-20241116.1557/magit-log.elc b/emacs/elpa/magit-20241116.1557/magit-log.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-margin.el b/emacs/elpa/magit-20241116.1557/magit-margin.el diff --git a/emacs/elpa/magit-20241106.1441/magit-margin.elc b/emacs/elpa/magit-20241116.1557/magit-margin.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-merge.el b/emacs/elpa/magit-20241116.1557/magit-merge.el diff --git a/emacs/elpa/magit-20241106.1441/magit-merge.elc b/emacs/elpa/magit-20241116.1557/magit-merge.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-mode.el b/emacs/elpa/magit-20241116.1557/magit-mode.el diff --git a/emacs/elpa/magit-20241106.1441/magit-mode.elc b/emacs/elpa/magit-20241116.1557/magit-mode.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-notes.el b/emacs/elpa/magit-20241116.1557/magit-notes.el diff --git a/emacs/elpa/magit-20241106.1441/magit-notes.elc b/emacs/elpa/magit-20241116.1557/magit-notes.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-patch.el b/emacs/elpa/magit-20241116.1557/magit-patch.el diff --git a/emacs/elpa/magit-20241106.1441/magit-patch.elc b/emacs/elpa/magit-20241116.1557/magit-patch.elc Binary files differ. diff --git a/emacs/elpa/magit-20241116.1557/magit-pkg.el b/emacs/elpa/magit-20241116.1557/magit-pkg.el @@ -0,0 +1,18 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "magit" "20241116.1557" + "A Git porcelain inside Emacs." + '((emacs "26.1") + (compat "30.0.0.0") + (dash "2.19.1") + (magit-section "4.1.2") + (seq "2.24") + (transient "0.7.8") + (with-editor "3.4.2")) + :url "https://github.com/magit/magit" + :commit "8cee789f7a61a491d23a78360cbd2d626eda0f06" + :revdesc "8cee789f7a61" + :keywords '("git" "tools" "vc") + :authors '(("Marius Vollmer" . "marius.vollmer@gmail.com") + ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) + :maintainers '(("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") + ("Kyle Meyer" . "kyle@kyleam.com"))) diff --git a/emacs/elpa/magit-20241106.1441/magit-process.el b/emacs/elpa/magit-20241116.1557/magit-process.el diff --git a/emacs/elpa/magit-20241106.1441/magit-process.elc b/emacs/elpa/magit-20241116.1557/magit-process.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-pull.el b/emacs/elpa/magit-20241116.1557/magit-pull.el diff --git a/emacs/elpa/magit-20241106.1441/magit-pull.elc b/emacs/elpa/magit-20241116.1557/magit-pull.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-push.el b/emacs/elpa/magit-20241116.1557/magit-push.el diff --git a/emacs/elpa/magit-20241106.1441/magit-push.elc b/emacs/elpa/magit-20241116.1557/magit-push.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-reflog.el b/emacs/elpa/magit-20241116.1557/magit-reflog.el diff --git a/emacs/elpa/magit-20241106.1441/magit-reflog.elc b/emacs/elpa/magit-20241116.1557/magit-reflog.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-refs.el b/emacs/elpa/magit-20241116.1557/magit-refs.el diff --git a/emacs/elpa/magit-20241106.1441/magit-refs.elc b/emacs/elpa/magit-20241116.1557/magit-refs.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-remote.el b/emacs/elpa/magit-20241116.1557/magit-remote.el diff --git a/emacs/elpa/magit-20241106.1441/magit-remote.elc b/emacs/elpa/magit-20241116.1557/magit-remote.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-repos.el b/emacs/elpa/magit-20241116.1557/magit-repos.el diff --git a/emacs/elpa/magit-20241106.1441/magit-repos.elc b/emacs/elpa/magit-20241116.1557/magit-repos.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-reset.el b/emacs/elpa/magit-20241116.1557/magit-reset.el diff --git a/emacs/elpa/magit-20241106.1441/magit-reset.elc b/emacs/elpa/magit-20241116.1557/magit-reset.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-sequence.el b/emacs/elpa/magit-20241116.1557/magit-sequence.el diff --git a/emacs/elpa/magit-20241106.1441/magit-sequence.elc b/emacs/elpa/magit-20241116.1557/magit-sequence.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-sparse-checkout.el b/emacs/elpa/magit-20241116.1557/magit-sparse-checkout.el diff --git a/emacs/elpa/magit-20241106.1441/magit-sparse-checkout.elc b/emacs/elpa/magit-20241116.1557/magit-sparse-checkout.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-stash.el b/emacs/elpa/magit-20241116.1557/magit-stash.el diff --git a/emacs/elpa/magit-20241116.1557/magit-stash.elc b/emacs/elpa/magit-20241116.1557/magit-stash.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-status.el b/emacs/elpa/magit-20241116.1557/magit-status.el diff --git a/emacs/elpa/magit-20241106.1441/magit-status.elc b/emacs/elpa/magit-20241116.1557/magit-status.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-submodule.el b/emacs/elpa/magit-20241116.1557/magit-submodule.el diff --git a/emacs/elpa/magit-20241106.1441/magit-submodule.elc b/emacs/elpa/magit-20241116.1557/magit-submodule.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-subtree.el b/emacs/elpa/magit-20241116.1557/magit-subtree.el diff --git a/emacs/elpa/magit-20241106.1441/magit-subtree.elc b/emacs/elpa/magit-20241116.1557/magit-subtree.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-tag.el b/emacs/elpa/magit-20241116.1557/magit-tag.el diff --git a/emacs/elpa/magit-20241106.1441/magit-tag.elc b/emacs/elpa/magit-20241116.1557/magit-tag.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-transient.el b/emacs/elpa/magit-20241116.1557/magit-transient.el diff --git a/emacs/elpa/magit-20241106.1441/magit-transient.elc b/emacs/elpa/magit-20241116.1557/magit-transient.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-wip.el b/emacs/elpa/magit-20241116.1557/magit-wip.el diff --git a/emacs/elpa/magit-20241106.1441/magit-wip.elc b/emacs/elpa/magit-20241116.1557/magit-wip.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit-worktree.el b/emacs/elpa/magit-20241116.1557/magit-worktree.el diff --git a/emacs/elpa/magit-20241106.1441/magit-worktree.elc b/emacs/elpa/magit-20241116.1557/magit-worktree.elc Binary files differ. diff --git a/emacs/elpa/magit-20241116.1557/magit.el b/emacs/elpa/magit-20241116.1557/magit.el @@ -0,0 +1,789 @@ +;;; magit.el --- A Git porcelain inside Emacs -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2024 The Magit Project Contributors + +;; Author: Marius Vollmer <marius.vollmer@gmail.com> +;; Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> +;; Maintainer: Jonas Bernoulli <emacs.magit@jonas.bernoulli.dev> +;; Kyle Meyer <kyle@kyleam.com> +;; Former-Maintainers: +;; Nicolas Dudebout <nicolas.dudebout@gatech.edu> +;; Noam Postavsky <npostavs@users.sourceforge.net> +;; Peter J. Weisberg <pj@irregularexpressions.net> +;; Phil Jackson <phil@shellarchive.co.uk> +;; Rémi Vanicat <vanicat@debian.org> +;; Yann Hodique <yann.hodique@gmail.com> + +;; Homepage: https://github.com/magit/magit +;; Keywords: git tools vc + +;; Package-Version: 20241116.1557 +;; Package-Revision: 8cee789f7a61 +;; Package-Requires: ( +;; (emacs "26.1") +;; (compat "30.0.0.0") +;; (dash "2.19.1") +;; (magit-section "4.1.2") +;; (seq "2.24") +;; (transient "0.7.8") +;; (with-editor "3.4.2")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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. +;; +;; Magit 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 Magit. If not, see <https://www.gnu.org/licenses/>. + +;; You should have received a copy of the AUTHORS.md file, which +;; lists all contributors. If not, see https://magit.vc/authors. + +;;; Commentary: + +;; Magit is a text-based Git user interface that puts an unmatched focus +;; on streamlining workflows. Commands are invoked using short mnemonic +;; key sequences that take the cursor’s position in the highly actionable +;; interface into account to provide context-sensitive behavior. + +;; With Magit you can do nearly everything that you can do when using Git +;; on the command-line, but at greater speed and while taking advantage +;; of advanced features that previously seemed too daunting to use on a +;; daily basis. Many users will find that by using Magit they can become +;; more effective Git user. + +;;; Code: + +(require 'magit-core) +(require 'magit-diff) +(require 'magit-log) +(require 'magit-wip) +(require 'magit-apply) +(require 'magit-repos) +(require 'git-commit) + +(require 'format-spec) +(require 'package nil t) ; used in `magit-version' +(require 'with-editor) + +;; For `magit:--gpg-sign' +(declare-function epg-list-keys "epg" (context &optional name mode)) +(declare-function epg-decode-dn "epg" (alist)) +(defvar epa-protocol) + +;;; Options + +(defcustom magit-openpgp-default-signing-key nil + "Fingerprint of your default Openpgp key used for signing. +If the specified primary key has signing capacity then it is used +as the value of the `--gpg-sign' argument without prompting, even +when other such keys exist. To be able to select another key you +must then use a prefix argument." + :package-version '(magit . "4.0.0") + :group 'magit-commands + :type 'string) + +;;; Faces + +(defface magit-header-line + '((t :inherit magit-section-heading)) + "Face for the `header-line' in some Magit modes. +Note that some modes, such as `magit-log-select-mode', have their +own faces for the `header-line', or for parts of the +`header-line'." + :group 'magit-faces) + +(defface magit-header-line-key + '((t :inherit font-lock-builtin-face)) + "Face for keys in the `header-line'." + :group 'magit-faces) + +(defface magit-dimmed + '((((class color) (background light)) :foreground "grey50") + (((class color) (background dark)) :foreground "grey50")) + "Face for text that shouldn't stand out." + :group 'magit-faces) + +(defface magit-hash + '((((class color) (background light)) :foreground "grey60") + (((class color) (background dark)) :foreground "grey40")) + "Face for the commit object name in the log output." + :group 'magit-faces) + +(defface magit-tag + '((((class color) (background light)) :foreground "Goldenrod4") + (((class color) (background dark)) :foreground "LightGoldenrod2")) + "Face for tag labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote + '((((class color) (background light)) :foreground "DarkOliveGreen4") + (((class color) (background dark)) :foreground "DarkSeaGreen2")) + "Face for remote branch head labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote-head + '((((supports (:box t))) :inherit magit-branch-remote :box t) + (t :inherit magit-branch-remote :inverse-video t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-local + '((((class color) (background light)) :foreground "SkyBlue4") + (((class color) (background dark)) :foreground "LightSkyBlue1")) + "Face for local branches." + :group 'magit-faces) + +(defface magit-branch-current + '((((supports (:box t))) :inherit magit-branch-local :box t) + (t :inherit magit-branch-local :inverse-video t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-upstream + '((t :slant italic)) + "Face for upstream branch. +This face is only used in logs and it gets combined + with `magit-branch-local', `magit-branch-remote' +and/or `magit-branch-remote-head'." + :group 'magit-faces) + +(defface magit-branch-warning + '((t :inherit warning)) + "Face for warning about (missing) branch." + :group 'magit-faces) + +(defface magit-head + '((((class color) (background light)) :inherit magit-branch-local) + (((class color) (background dark)) :inherit magit-branch-local)) + "Face for the symbolic ref `HEAD'." + :group 'magit-faces) + +(defface magit-refname + '((((class color) (background light)) :foreground "grey30") + (((class color) (background dark)) :foreground "grey80")) + "Face for refnames without a dedicated face." + :group 'magit-faces) + +(defface magit-refname-stash + '((t :inherit magit-refname)) + "Face for stash refnames." + :group 'magit-faces) + +(defface magit-refname-wip + '((t :inherit magit-refname)) + "Face for wip refnames." + :group 'magit-faces) + +(defface magit-refname-pullreq + '((t :inherit magit-refname)) + "Face for pullreq refnames." + :group 'magit-faces) + +(defface magit-keyword + '((t :inherit font-lock-string-face)) + "Face for parts of commit messages inside brackets." + :group 'magit-faces) + +(defface magit-keyword-squash + '((t :inherit font-lock-warning-face)) + "Face for squash! and fixup! keywords in commit messages." + :group 'magit-faces) + +(defface magit-signature-good + '((t :foreground "green")) + "Face for good signatures." + :group 'magit-faces) + +(defface magit-signature-bad + '((t :foreground "red" :weight bold)) + "Face for bad signatures." + :group 'magit-faces) + +(defface magit-signature-untrusted + '((t :foreground "medium aquamarine")) + "Face for good untrusted signatures." + :group 'magit-faces) + +(defface magit-signature-expired + '((t :foreground "orange")) + "Face for signatures that have expired." + :group 'magit-faces) + +(defface magit-signature-expired-key + '((t :inherit magit-signature-expired)) + "Face for signatures made by an expired key." + :group 'magit-faces) + +(defface magit-signature-revoked + '((t :foreground "violet red")) + "Face for signatures made by a revoked key." + :group 'magit-faces) + +(defface magit-signature-error + '((t :foreground "light blue")) + "Face for signatures that cannot be checked (e.g., missing key)." + :group 'magit-faces) + +(defface magit-cherry-unmatched + '((t :foreground "cyan")) + "Face for unmatched cherry commits." + :group 'magit-faces) + +(defface magit-cherry-equivalent + '((t :foreground "magenta")) + "Face for equivalent cherry commits." + :group 'magit-faces) + +(defface magit-filename + '((t :weight normal)) + "Face for filenames." + :group 'magit-faces) + +;;; Global Bindings + +;;;###autoload +(defcustom magit-define-global-key-bindings 'default + "Which set of key bindings to add to the global keymap, if any. + +This option controls which set of Magit key bindings, if any, may +be added to the global keymap, even before Magit is first used in +the current Emacs session. + +If the value is nil, no bindings are added. + +If `default', maybe add: + + C-x g `magit-status' + C-x M-g `magit-dispatch' + C-c M-g `magit-file-dispatch' + +If `recommended', maybe add: + + C-x g `magit-status' + C-c g `magit-dispatch' + C-c f `magit-file-dispatch' + + These bindings are strongly recommended, but we cannot use + them by default, because the \"C-c <LETTER>\" namespace is + strictly reserved for bindings added by the user. + +The bindings in the chosen set may be added when +`after-init-hook' is run. Each binding is added if, and only +if, at that time no other key is bound to the same command, +and no other command is bound to the same key. In other words +we try to avoid adding bindings that are unnecessary, as well +as bindings that conflict with other bindings. + +Adding these bindings is delayed until `after-init-hook' is +run to allow users to set the variable anywhere in their init +file (without having to make sure to do so before `magit' is +loaded or autoloaded) and to increase the likelihood that all +the potentially conflicting user bindings have already been +added. + +To set this variable use either `setq' or the Custom interface. +Do not use the function `customize-set-variable' because doing +that would cause Magit to be loaded immediately, when that form +is evaluated (this differs from `custom-set-variables', which +doesn't load the libraries that define the customized variables). + +Setting this variable has no effect if `after-init-hook' has +already been run." + :package-version '(magit . "4.0.0") + :group 'magit-essentials + :type '(choice (const :tag "Add no binding" nil) + (const :tag "Use default bindings" default) + (const :tag "Use recommended bindings" recommended))) + +;;;###autoload +(progn + (defun magit-maybe-define-global-key-bindings (&optional force) + "See variable `magit-define-global-key-bindings'." + (when magit-define-global-key-bindings + (let ((map (current-global-map))) + (pcase-dolist (`(,key . ,def) + (cond ((eq magit-define-global-key-bindings 'recommended) + '(("C-x g" . magit-status) + ("C-c g" . magit-dispatch) + ("C-c f" . magit-file-dispatch))) + ('(("C-x g" . magit-status) + ("C-x M-g" . magit-dispatch) + ("C-c M-g" . magit-file-dispatch))))) + ;; This is autoloaded and thus is used before `compat' is + ;; loaded, so we cannot use `keymap-lookup' and `keymap-set'. + (when (or force + (not (or (lookup-key map (kbd key)) + (where-is-internal def (make-sparse-keymap) t)))) + (define-key map (kbd key) def)))))) + (if after-init-time + (magit-maybe-define-global-key-bindings) + (add-hook 'after-init-hook #'magit-maybe-define-global-key-bindings t))) + +;;; Dispatch Popup + +;;;###autoload (autoload 'magit-dispatch "magit" nil t) +(transient-define-prefix magit-dispatch () + "Invoke a Magit command from a list of available commands." + :info-manual "(magit)Top" + ["Transient and dwim commands" + ;; → bound in magit-mode-map or magit-section-mode-map + ;; ↓ bound below + [("A" "Apply" magit-cherry-pick) + ;; a ↓ + ("b" "Branch" magit-branch) + ("B" "Bisect" magit-bisect) + ("c" "Commit" magit-commit) + ("C" "Clone" magit-clone) + ("d" "Diff" magit-diff) + ("D" "Diff (change)" magit-diff-refresh) + ("e" "Ediff (dwim)" magit-ediff-dwim) + ("E" "Ediff" magit-ediff) + ("f" "Fetch" magit-fetch) + ("F" "Pull" magit-pull) + ;; g ↓ + ;; G → magit-refresh-all + ("h" "Help" magit-info) + ("H" "Section info" magit-describe-section :if-derived magit-mode)] + [("i" "Ignore" magit-gitignore) + ("I" "Init" magit-init) + ("j" "Jump to section"magit-status-jump :if-mode magit-status-mode) + ("j" "Display status" magit-status-quick :if-not-mode magit-status-mode) + ("J" "Display buffer" magit-display-repository-buffer) + ;; k ↓ + ;; K → magit-file-untrack + ("l" "Log" magit-log) + ("L" "Log (change)" magit-log-refresh) + ("m" "Merge" magit-merge) + ("M" "Remote" magit-remote) + ;; n → magit-section-forward + ;; N reserved → forge-dispatch + ("o" "Submodule" magit-submodule) + ("O" "Subtree" magit-subtree) + ;; p → magit-section-backward + ("P" "Push" magit-push) + ;; q → magit-mode-bury-buffer + ("Q" "Command" magit-git-command)] + [("r" "Rebase" magit-rebase) + ;; R → magit-file-rename + ;; s ↓ + ;; S ↓ + ("t" "Tag" magit-tag) + ("T" "Note" magit-notes) + ;; u ↓ + ;; U ↓ + ;; v ↓ + ("V" "Revert" magit-revert) + ("w" "Apply patches" magit-am) + ("W" "Format patches" magit-patch) + ;; x → magit-reset-quickly + ("X" "Reset" magit-reset) + ("y" "Show Refs" magit-show-refs) + ("Y" "Cherries" magit-cherry) + ("z" "Stash" magit-stash) + ("Z" "Worktree" magit-worktree) + ("!" "Run" magit-run)]] + ["Applying changes" + :if-derived magit-mode + [("a" "Apply" magit-apply) + ("v" "Reverse" magit-reverse) + ("k" "Discard" magit-discard)] + [("s" "Stage" magit-stage) + ("u" "Unstage" magit-unstage)] + [("S" "Stage all" magit-stage-modified) + ("U" "Unstage all" magit-unstage-all)]] + ["Essential commands" + :if-derived magit-mode + [("g" " Refresh current buffer" magit-refresh) + ("q" " Bury current buffer" magit-mode-bury-buffer) + ("<tab>" " Toggle section at point" magit-section-toggle) + ("<return>" "Visit thing at point" magit-visit-thing)] + [("C-x m" "Show all key bindings" describe-mode) + ("C-x i" "Show Info manual" magit-info)]]) + +;;; Git Popup + +(defcustom magit-shell-command-verbose-prompt t + "Whether to show the working directory when reading a command. +This affects `magit-git-command', `magit-git-command-topdir', +`magit-shell-command', and `magit-shell-command-topdir'." + :package-version '(magit . "2.11.0") + :group 'magit-commands + :type 'boolean) + +(defvar magit-git-command-history nil) + +;;;###autoload (autoload 'magit-run "magit" nil t) +(transient-define-prefix magit-run () + "Run git or another command, or launch a graphical utility." + [["Run git subcommand" + ("!" "in repository root" magit-git-command-topdir) + ("p" "in working directory" magit-git-command)] + ["Run shell command" + ("s" "in repository root" magit-shell-command-topdir) + ("S" "in working directory" magit-shell-command)] + ["Launch" + ("k" "gitk" magit-run-gitk) + ("a" "gitk --all" magit-run-gitk-all) + ("b" "gitk --branches" magit-run-gitk-branches) + ("g" "git gui" magit-run-git-gui) + ("m" "git mergetool --gui" magit-git-mergetool)]]) + +;;;###autoload +(defun magit-git-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +With a prefix argument COMMAND is run in the top-level directory +of the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command nil "git "))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-git-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +COMMAND is run in the top-level directory of the current +working tree." + (interactive (list (magit-read-shell-command t "git "))) + (magit--shell-command command (magit-toplevel))) + +;;;###autoload +(defun magit-shell-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. With a +prefix argument COMMAND is run in the top-level directory of +the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-shell-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. COMMAND +is run in the top-level directory of the current working tree." + (interactive (list (magit-read-shell-command t))) + (magit--shell-command command (magit-toplevel))) + +(defun magit--shell-command (command &optional directory) + (let ((default-directory (or directory default-directory))) + (with-environment-variables (("GIT_PAGER" "cat")) + (magit--with-connection-local-variables + (magit-with-editor + (magit-start-process shell-file-name nil + shell-command-switch command))))) + (magit-process-buffer)) + +(defun magit-read-shell-command (&optional toplevel initial-input) + (let ((default-directory + (if (or toplevel current-prefix-arg) + (or (magit-toplevel) + (magit--not-inside-repository-error)) + default-directory))) + (read-shell-command (if magit-shell-command-verbose-prompt + (format "Async shell command in %s: " + (abbreviate-file-name default-directory)) + "Async shell command: ") + initial-input 'magit-git-command-history))) + +;;; Shared Infix Arguments + +(transient-define-argument magit:--gpg-sign () + :description "Sign using gpg" + :class 'transient-option + :shortarg "-S" + :argument "--gpg-sign=" + :allow-empty t + :reader #'magit-read-gpg-signing-key) + +(defvar magit-gpg-secret-key-hist nil) + +(defun magit-read-gpg-secret-key + (prompt &optional initial-input history predicate default) + (require 'epa) + (let* ((keys (cl-mapcan + (lambda (cert) + (and (or (not predicate) + (funcall predicate cert)) + (let* ((key (car (epg-key-sub-key-list cert))) + (fpr (epg-sub-key-fingerprint key)) + (id (epg-sub-key-id key)) + (author + (and-let* ((id-obj + (car (epg-key-user-id-list cert)))) + (let ((id-str (epg-user-id-string id-obj))) + (if (stringp id-str) + id-str + (epg-decode-dn id-obj)))))) + (list + (propertize fpr 'display + (concat (substring fpr 0 (- (length id))) + (propertize id 'face 'highlight) + " " author)))))) + (epg-list-keys (epg-make-context epa-protocol) nil t))) + (choice (or (and (not current-prefix-arg) + (or (and (length= keys 1) (car keys)) + (and default (car (member default keys))))) + (completing-read prompt keys nil nil nil + history nil initial-input)))) + (set-text-properties 0 (length choice) nil choice) + choice)) + +(defun magit-read-gpg-signing-key (prompt &optional initial-input history) + (magit-read-gpg-secret-key + prompt initial-input history + (lambda (cert) + (cl-some (lambda (key) + (memq 'sign (epg-sub-key-capability key))) + (epg-key-sub-key-list cert))) + magit-openpgp-default-signing-key)) + +;;; Font-Lock Keywords + +(defconst magit-font-lock-keywords + (eval-when-compile + `((,(concat "(\\(magit-define-section-jumper\\)\\_>" + "[ \t'(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face nil t)) + (,(concat "(" (regexp-opt '("magit-insert-section" + "magit-section-case" + "magit-bind-match-strings" + "magit-with-temp-index" + "magit-with-blob" + "magit-with-toplevel") + t) + "\\_>") + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode magit-font-lock-keywords) + +;;; Version + +(defvar magit-version #'undefined + "The version of Magit that you're using. +Use the function by the same name instead of this variable.") + +;;;###autoload +(defun magit-version (&optional print-dest interactive nowarn) + "Return the version of Magit currently in use. + +If optional argument PRINT-DEST is non-nil, also print the used +versions of Magit, Transient, Git and Emacs to the output stream +selected by that argument. Interactively use the echo area, or +with a prefix argument use the current buffer. Additionally put +the output in the kill ring. +\n(fn &optional PRINT-DEST)" + (interactive (list (if current-prefix-arg (current-buffer) t) t)) + (let ((magit-git-global-arguments nil) + (toplib (or load-file-name buffer-file-name)) + debug) + (unless (and toplib + (member (file-name-nondirectory toplib) + '("magit.el" "magit.el.gz"))) + (let ((load-suffixes (reverse load-suffixes))) ; prefer .el than .elc + (setq toplib (locate-library "magit")))) + (setq toplib (and toplib (magit--chase-links toplib))) + (push toplib debug) + (when toplib + (let* ((topdir (file-name-directory toplib)) + (gitdir (expand-file-name + ".git" (file-name-directory + (directory-file-name topdir)))) + (static (locate-library "magit-version.el" nil (list topdir))) + (static (and static (magit--chase-links static)))) + (or (progn + (push 'repo debug) + (when (and (file-exists-p gitdir) + ;; It is a repo, but is it the Magit repo? + (file-exists-p + (expand-file-name "../lisp/magit.el" gitdir))) + (push t debug) + ;; Inside the repo the version file should only exist + ;; while running make. + (when (and static (not noninteractive)) + (ignore-errors (delete-file static))) + (setq magit-version + (let ((default-directory topdir)) + (magit-git-string "describe" + "--tags" "--dirty" "--always"))))) + (progn + (push 'static debug) + (when (and static (file-exists-p static)) + (push t debug) + (load-file static) + magit-version)) + (when (featurep 'package) + (push 'elpa debug) + (ignore-errors + (when-let ((version (cadr (assq 'magit package-alist)))) + (push t debug) + (setq magit-version + (and (fboundp 'package-desc-version) + (package-version-join + (package-desc-version version))))))) + (progn + (push 'dirname debug) + (let ((dirname (file-name-nondirectory + (directory-file-name topdir)))) + (when (string-match "\\`magit-\\([0-9].*\\)" dirname) + (setq magit-version (match-string 1 dirname))))) + ;; If all else fails, just report the commit hash. It's + ;; better than nothing and we cannot do better in the case + ;; of e.g., a shallow clone. + (progn + (push 'hash debug) + ;; Same check as above to see if it's really the Magit repo. + (when (and (file-exists-p gitdir) + (file-exists-p + (expand-file-name "../lisp/magit.el" gitdir))) + (setq magit-version + (let ((default-directory topdir)) + (magit-git-string "rev-parse" "HEAD")))))))) + (if (stringp magit-version) + (when print-dest + (let ((str (format + "Magit %s%s, Transient %s,%s Git %s, Emacs %s, %s" + (or magit-version "(unknown)") + (or (and (ignore-errors + (magit--version>= magit-version "2008")) + (ignore-errors + (require 'lisp-mnt) + (and (fboundp 'lm-header) + (format + " [>= %s]" + (with-temp-buffer + (insert-file-contents + (locate-library "magit.el" t)) + (lm-header "Package-Version")))))) + "") + (or (ignore-errors + (require 'lisp-mnt) + (and (fboundp 'lm-header) + (with-temp-buffer + (insert-file-contents + (locate-library "transient.el" t)) + (lm-header "Package-Version")))) + "(unknown)") + (let ((lib (locate-library "forge.el" t))) + (or (and lib + (format + " Forge %s," + (or (ignore-errors + (require 'lisp-mnt) + (with-temp-buffer + (insert-file-contents lib) + (and (fboundp 'lm-header) + (lm-header "Package-Version")))) + "(unknown)"))) + "")) + (magit--safe-git-version) + emacs-version + system-type))) + (when interactive + (kill-new str)) + (princ str print-dest))) + (setq debug (reverse debug)) + (setq magit-version 'error) + (when magit-version + (push magit-version debug)) + (unless (or nowarn (equal (getenv "CI") "true")) + (message "Cannot determine Magit's version %S" debug))) + magit-version)) + +;;; Startup Asserts + +(defun magit-startup-asserts () + (when-let ((val (getenv "GIT_DIR"))) + (setenv "GIT_DIR") + (message + "Magit unset $GIT_DIR (was %S). See %s" val + ;; Note: Pass URL as argument rather than embedding in the format + ;; string to prevent the single quote from being rendered + ;; according to `text-quoting-style'. + "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) + (when-let ((val (getenv "GIT_WORK_TREE"))) + (setenv "GIT_WORK_TREE") + (message + "Magit unset $GIT_WORK_TREE (was %S). See %s" val + ;; See comment above. + "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) + ;; Git isn't required while building Magit. + (unless (bound-and-true-p byte-compile-current-file) + (magit-git-version-assert)) + (when (version< emacs-version magit--minimal-emacs) + (display-warning 'magit (format "\ +Magit requires Emacs >= %s, you are using %s. + +If this comes as a surprise to you, because you do actually have +a newer version installed, then that probably means that the +older version happens to appear earlier on the `$PATH'. If you +always start Emacs from a shell, then that can be fixed in the +shell's init file. If you start Emacs by clicking on an icon, +or using some sort of application launcher, then you probably +have to adjust the environment as seen by graphical interface. +For X11 something like ~/.xinitrc should work.\n" + magit--minimal-emacs emacs-version) + :error))) + +;;; Loading Libraries + +(provide 'magit) + +(cl-eval-when (load eval) + (require 'magit-status) + (require 'magit-refs) + (require 'magit-files) + (require 'magit-reset) + (require 'magit-branch) + (require 'magit-merge) + (require 'magit-tag) + (require 'magit-worktree) + (require 'magit-notes) + (require 'magit-sequence) + (require 'magit-commit) + (require 'magit-remote) + (require 'magit-clone) + (require 'magit-fetch) + (require 'magit-pull) + (require 'magit-push) + (require 'magit-bisect) + (require 'magit-stash) + (require 'magit-blame) + (require 'magit-submodule) + (unless (load "magit-autoloads" t t) + (require 'magit-patch) + (require 'magit-subtree) + (require 'magit-ediff) + (require 'magit-gitignore) + (require 'magit-sparse-checkout) + (require 'magit-extras) + (require 'git-rebase) + (require 'magit-bookmark))) + +(with-eval-after-load 'bookmark + (require 'magit-bookmark)) + +(unless (bound-and-true-p byte-compile-current-file) + (if after-init-time + (progn (magit-startup-asserts) + (magit-version nil nil t)) + (add-hook 'after-init-hook #'magit-startup-asserts t) + (add-hook 'after-init-hook #'magit-version t))) + +;;; magit.el ends here diff --git a/emacs/elpa/magit-20241106.1441/magit.elc b/emacs/elpa/magit-20241116.1557/magit.elc Binary files differ. diff --git a/emacs/elpa/magit-20241106.1441/magit.info b/emacs/elpa/magit-20241116.1557/magit.info diff --git a/emacs/elpa/markdown-mode-20241107.349/markdown-mode-pkg.el b/emacs/elpa/markdown-mode-20241107.349/markdown-mode-pkg.el @@ -1,10 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "markdown-mode" "20241107.349" - "Major mode for Markdown-formatted text." - '((emacs "27.1")) - :url "https://github.com/jrblevin/markdown-mode" - :commit "6f59f72ca040f0199aa72f1ae4f6c364de61cac0" - :revdesc "6f59f72ca040" - :keywords '("markdown" "github flavored markdown" "itex") - :authors '(("Jason R. Blevins" . "jblevins@xbeta.org")) - :maintainers '(("Jason R. Blevins" . "jblevins@xbeta.org"))) diff --git a/emacs/elpa/markdown-mode-20241107.349/markdown-mode.el b/emacs/elpa/markdown-mode-20241107.349/markdown-mode.el @@ -1,10400 +0,0 @@ -;;; markdown-mode.el --- Major mode for Markdown-formatted text -*- lexical-binding: t; -*- - -;; Copyright (C) 2007-2023 Jason R. Blevins and markdown-mode -;; contributors (see the commit log for details). - -;; Author: Jason R. Blevins <jblevins@xbeta.org> -;; Maintainer: Jason R. Blevins <jblevins@xbeta.org> -;; Created: May 24, 2007 -;; Package-Version: 20241107.349 -;; Package-Revision: 6f59f72ca040 -;; Package-Requires: ((emacs "27.1")) -;; Keywords: Markdown, GitHub Flavored Markdown, itex -;; URL: https://jblevins.org/projects/markdown-mode/ - -;; This file is not part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; See the README.md file for details. - - -;;; Code: - -(require 'easymenu) -(require 'outline) -(require 'thingatpt) -(require 'cl-lib) -(require 'url-parse) -(require 'button) -(require 'color) -(require 'rx) -(require 'subr-x) - -(defvar jit-lock-start) -(defvar jit-lock-end) -(defvar flyspell-generic-check-word-predicate) -(defvar electric-pair-pairs) -(defvar sh-ancestor-alist) - -(declare-function project-roots "project") -(declare-function sh-set-shell "sh-script") -(declare-function mailcap-file-name-to-mime-type "mailcap") -(declare-function dnd-get-local-file-name "dnd") - -;; for older emacs<29 -(declare-function mailcap-mime-type-to-extension "mailcap") -(declare-function file-name-with-extension "files") -(declare-function yank-media-handler "yank-media") - - -;;; Constants ================================================================= - -(defconst markdown-mode-version "2.7-alpha" - "Markdown mode version number.") - -(defconst markdown-output-buffer-name "*markdown-output*" - "Name of temporary buffer for markdown command output.") - - -;;; Global Variables ========================================================== - -(defvar markdown-reference-label-history nil - "History of used reference labels.") - -(defvar markdown-live-preview-mode nil - "Sentinel variable for command `markdown-live-preview-mode'.") - -(defvar markdown-gfm-language-history nil - "History list of languages used in the current buffer in GFM code blocks.") - -(defvar markdown-follow-link-functions nil - "Functions used to follow a link. -Each function is called with one argument, the link's URL. It -should return non-nil if it followed the link, or nil if not. -Functions are called in order until one of them returns non-nil; -otherwise the default link-following function is used.") - - -;;; Customizable Variables ==================================================== - -(defvar markdown-mode-hook nil - "Hook run when entering Markdown mode.") - -(defvar markdown-before-export-hook nil - "Hook run before running Markdown to export XHTML output. -The hook may modify the buffer, which will be restored to it's -original state after exporting is complete.") - -(defvar markdown-after-export-hook nil - "Hook run after XHTML output has been saved. -Any changes to the output buffer made by this hook will be saved.") - -(defgroup markdown nil - "Major mode for editing text files in Markdown format." - :prefix "markdown-" - :group 'text - :link '(url-link "https://jblevins.org/projects/markdown-mode/")) - -(defcustom markdown-command (let ((command (cl-loop for cmd in '("markdown" "pandoc" "markdown_py") - when (executable-find cmd) - return (file-name-nondirectory it)))) - (or command "markdown")) - "Command to run markdown." - :group 'markdown - :type '(choice (string :tag "Shell command") (repeat (string)) function)) - -(defcustom markdown-command-needs-filename nil - "Set to non-nil if `markdown-command' does not accept input from stdin. -Instead, it will be passed a filename as the final command line -option. As a result, you will only be able to run Markdown from -buffers which are visiting a file." - :group 'markdown - :type 'boolean) - -(defcustom markdown-open-command nil - "Command used for opening Markdown files directly. -For example, a standalone Markdown previewer. This command will -be called with a single argument: the filename of the current -buffer. It can also be a function, which will be called without -arguments." - :group 'markdown - :type '(choice file function (const :tag "None" nil))) - -(defcustom markdown-open-image-command nil - "Command used for opening image files directly. -This is used at `markdown-follow-link-at-point'." - :group 'markdown - :type '(choice file function (const :tag "None" nil))) - -(defcustom markdown-hr-strings - '("-------------------------------------------------------------------------------" - "* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" - "---------------------------------------" - "* * * * * * * * * * * * * * * * * * * *" - "---------" - "* * * * *") - "Strings to use when inserting horizontal rules. -The first string in the list will be the default when inserting a -horizontal rule. Strings should be listed in decreasing order of -prominence (as in headings from level one to six) for use with -promotion and demotion functions." - :group 'markdown - :type '(repeat string)) - -(defcustom markdown-bold-underscore nil - "Use two underscores when inserting bold text instead of two asterisks." - :group 'markdown - :type 'boolean) - -(defcustom markdown-italic-underscore nil - "Use underscores when inserting italic text instead of asterisks." - :group 'markdown - :type 'boolean) - -(defcustom markdown-marginalize-headers nil - "When non-nil, put opening atx header markup in a left margin. - -This setting goes well with `markdown-asymmetric-header'. But -sadly it conflicts with `linum-mode' since they both use the -same margin." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-marginalize-headers-margin-width 6 - "Character width of margin used for marginalized headers. -The default value is based on there being six heading levels -defined by Markdown and HTML. Increasing this produces extra -whitespace on the left. Decreasing it may be preferred when -fewer than six nested heading levels are used." - :group 'markdown - :type 'integer - :safe 'natnump - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-asymmetric-header nil - "Determines if atx header style will be asymmetric. -Set to a non-nil value to use asymmetric header styling, placing -header markup only at the beginning of the line. By default, -balanced markup will be inserted at the beginning and end of the -line around the header title." - :group 'markdown - :type 'boolean) - -(defcustom markdown-indent-function 'markdown-indent-line - "Function to use to indent." - :group 'markdown - :type 'function) - -(defcustom markdown-indent-on-enter t - "Determines indentation behavior when pressing \\[newline]. -Possible settings are nil, t, and \\='indent-and-new-item. - -When non-nil, pressing \\[newline] will call `newline-and-indent' -to indent the following line according to the context using -`markdown-indent-function'. In this case, note that -\\[electric-newline-and-maybe-indent] can still be used to insert -a newline without indentation. - -When set to \\='indent-and-new-item and the point is in a list item -when \\[newline] is pressed, the list will be continued on the next -line, where a new item will be inserted. - -When set to nil, simply call `newline' as usual. In this case, -you can still indent lines using \\[markdown-cycle] and continue -lists with \\[markdown-insert-list-item]. - -Note that this assumes the variable `electric-indent-mode' is -non-nil (enabled). When it is *disabled*, the behavior of -\\[newline] and `\\[electric-newline-and-maybe-indent]' are -reversed." - :group 'markdown - :type '(choice (const :tag "Don't automatically indent" nil) - (const :tag "Automatically indent" t) - (const :tag "Automatically indent and insert new list items" indent-and-new-item))) - -(defcustom markdown-enable-wiki-links nil - "Syntax highlighting for wiki links. -Set this to a non-nil value to turn on wiki link support by default. -Support can be toggled later using the `markdown-toggle-wiki-links' -function or \\[markdown-toggle-wiki-links]." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-wiki-link-alias-first t - "When non-nil, treat aliased wiki links like [[alias text|PageName]]. -Otherwise, they will be treated as [[PageName|alias text]]." - :group 'markdown - :type 'boolean - :safe 'booleanp) - -(defcustom markdown-wiki-link-search-subdirectories nil - "When non-nil, search for wiki link targets in subdirectories. -This is the default search behavior for GitHub and is -automatically set to t in `gfm-mode'." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-wiki-link-search-parent-directories nil - "When non-nil, search for wiki link targets in parent directories. -This is the default search behavior of Ikiwiki." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-wiki-link-search-type nil - "Searching type for markdown wiki link. - -sub-directories: search for wiki link targets in sub directories -parent-directories: search for wiki link targets in parent directories -project: search for wiki link targets under project root" - :group 'markdown - :type '(set - (const :tag "search wiki link from subdirectories" sub-directories) - (const :tag "search wiki link from parent directories" parent-directories) - (const :tag "search wiki link under project root" project)) - :package-version '(markdown-mode . "2.5")) - -(make-obsolete-variable 'markdown-wiki-link-search-subdirectories 'markdown-wiki-link-search-type "2.5") -(make-obsolete-variable 'markdown-wiki-link-search-parent-directories 'markdown-wiki-link-search-type "2.5") - -(defcustom markdown-wiki-link-fontify-missing nil - "When non-nil, change wiki link face according to existence of target files. -This is expensive because it requires checking for the file each time the buffer -changes or the user switches windows. It is disabled by default because it may -cause lag when typing on slower machines." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-uri-types - '("acap" "cid" "data" "dav" "fax" "file" "ftp" - "geo" "gopher" "http" "https" "imap" "ldap" "mailto" - "mid" "message" "modem" "news" "nfs" "nntp" - "pop" "prospero" "rtsp" "service" "sip" "tel" - "telnet" "tip" "urn" "vemmi" "wais") - "Link types for syntax highlighting of URIs." - :group 'markdown - :type '(repeat (string :tag "URI scheme"))) - -(defcustom markdown-url-compose-char - '(?∞ ?… ?⋯ ?# ?★ ?⚓) - "Placeholder character for hidden URLs. -This may be a single character or a list of characters. In case -of a list, the first one that satisfies `char-displayable-p' will -be used." - :type '(choice - (character :tag "Single URL replacement character") - (repeat :tag "List of possible URL replacement characters" - character)) - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-blockquote-display-char - '("▌" "┃" ">") - "String to display when hiding blockquote markup. -This may be a single string or a list of string. In case of a -list, the first one that satisfies `char-displayable-p' will be -used." - :type '(choice - (string :tag "Single blockquote display string") - (repeat :tag "List of possible blockquote display strings" string)) - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-hr-display-char - '(?─ ?━ ?-) - "Character for hiding horizontal rule markup. -This may be a single character or a list of characters. In case -of a list, the first one that satisfies `char-displayable-p' will -be used." - :group 'markdown - :type '(choice - (character :tag "Single HR display character") - (repeat :tag "List of possible HR display characters" character)) - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-definition-display-char - '(?⁘ ?⁙ ?≡ ?⌑ ?◊ ?:) - "Character for replacing definition list markup. -This may be a single character or a list of characters. In case -of a list, the first one that satisfies `char-displayable-p' will -be used." - :type '(choice - (character :tag "Single definition list character") - (repeat :tag "List of possible definition list characters" character)) - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-enable-math nil - "Syntax highlighting for inline LaTeX and itex expressions. -Set this to a non-nil value to turn on math support by default. -Math support can be enabled, disabled, or toggled later using -`markdown-toggle-math' or \\[markdown-toggle-math]." - :group 'markdown - :type 'boolean - :safe 'booleanp) -(make-variable-buffer-local 'markdown-enable-math) - -(defcustom markdown-enable-html t - "Enable font-lock support for HTML tags and attributes." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-enable-highlighting-syntax nil - "Enable highlighting syntax." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-css-paths nil - "List of URLs of CSS files to link to in the output XHTML." - :group 'markdown - :type '(repeat (string :tag "CSS File Path"))) - -(defcustom markdown-content-type "text/html" - "Content type string for the http-equiv header in XHTML output. -When set to an empty string, this attribute is omitted. Defaults to -`text/html'." - :group 'markdown - :type 'string) - -(defcustom markdown-coding-system nil - "Character set string for the http-equiv header in XHTML output. -Defaults to `buffer-file-coding-system' (and falling back to -`utf-8' when not available). Common settings are `iso-8859-1' -and `iso-latin-1'. Use `list-coding-systems' for more choices." - :group 'markdown - :type 'coding-system) - -(defcustom markdown-export-kill-buffer t - "Kill output buffer after HTML export. -When non-nil, kill the HTML output buffer after -exporting with `markdown-export'." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-xhtml-header-content "" - "Additional content to include in the XHTML <head> block." - :group 'markdown - :type 'string) - -(defcustom markdown-xhtml-body-preamble "" - "Content to include in the XHTML <body> block, before the output." - :group 'markdown - :type 'string - :safe 'stringp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-xhtml-body-epilogue "" - "Content to include in the XHTML <body> block, after the output." - :group 'markdown - :type 'string - :safe 'stringp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-xhtml-standalone-regexp - "^\\(<\\?xml\\|<!DOCTYPE\\|<html\\)" - "Regexp indicating whether `markdown-command' output is standalone XHTML." - :group 'markdown - :type 'regexp) - -(defcustom markdown-link-space-sub-char "_" - "Character to use instead of spaces when mapping wiki links to filenames." - :group 'markdown - :type 'string) - -(defcustom markdown-reference-location 'header - "Position where new reference definitions are inserted in the document." - :group 'markdown - :type '(choice (const :tag "At the end of the document" end) - (const :tag "Immediately after the current block" immediately) - (const :tag "At the end of the subtree" subtree) - (const :tag "Before next header" header))) - -(defcustom markdown-footnote-location 'end - "Position where new footnotes are inserted in the document." - :group 'markdown - :type '(choice (const :tag "At the end of the document" end) - (const :tag "Immediately after the current block" immediately) - (const :tag "At the end of the subtree" subtree) - (const :tag "Before next header" header))) - -(defcustom markdown-footnote-display '((raise 0.2) (height 0.8)) - "Display specification for footnote markers and inline footnotes. -By default, footnote text is reduced in size and raised. Set to -nil to disable this." - :group 'markdown - :type '(choice (sexp :tag "Display specification") - (const :tag "Don't set display property" nil)) - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-sub-superscript-display - '(((raise -0.3) (height 0.7)) . ((raise 0.3) (height 0.7))) - "Display specification for subscript and superscripts. -The car is used for subscript, the cdr is used for superscripts." - :group 'markdown - :type '(cons (choice (sexp :tag "Subscript form") - (const :tag "No lowering" nil)) - (choice (sexp :tag "Superscript form") - (const :tag "No raising" nil))) - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-unordered-list-item-prefix " * " - "String inserted before unordered list items." - :group 'markdown - :type 'string) - -(defcustom markdown-ordered-list-enumeration t - "When non-nil, use enumerated numbers(1. 2. 3. etc.) for ordered list marker. -While nil, always uses '1.' for the marker" - :group 'markdown - :type 'boolean - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-nested-imenu-heading-index t - "Use nested or flat imenu heading index. -A nested index may provide more natural browsing from the menu, -but a flat list may allow for faster keyboard navigation via tab -completion." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-add-footnotes-to-imenu t - "Add footnotes to end of imenu heading index." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-make-gfm-checkboxes-buttons t - "When non-nil, make GFM checkboxes into buttons." - :group 'markdown - :type 'boolean) - -(defcustom markdown-use-pandoc-style-yaml-metadata nil - "When non-nil, allow YAML metadata anywhere in the document." - :group 'markdown - :type 'boolean) - -(defcustom markdown-split-window-direction 'any - "Preference for splitting windows for static and live preview. -The default value is \\='any, which instructs Emacs to use -`split-window-sensibly' to automatically choose how to split -windows based on the values of `split-width-threshold' and -`split-height-threshold' and the available windows. To force -vertically split (left and right) windows, set this to \\='vertical -or \\='right. To force horizontally split (top and bottom) windows, -set this to \\='horizontal or \\='below. - -If this value is \\='any and `display-buffer-alist' is set then -`display-buffer' is used for open buffer function" - :group 'markdown - :type '(choice (const :tag "Automatic" any) - (const :tag "Right (vertical)" right) - (const :tag "Below (horizontal)" below)) - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-live-preview-window-function - #'markdown-live-preview-window-eww - "Function to display preview of Markdown output within Emacs. -Function must update the buffer containing the preview and return -the buffer." - :group 'markdown - :type 'function) - -(defcustom markdown-live-preview-delete-export 'delete-on-destroy - "Delete exported HTML file when using `markdown-live-preview-export'. -If set to \\='delete-on-export, delete on every export. When set to -\\='delete-on-destroy delete when quitting from command -`markdown-live-preview-mode'. Never delete if set to nil." - :group 'markdown - :type '(choice - (const :tag "Delete on every export" delete-on-export) - (const :tag "Delete when quitting live preview" delete-on-destroy) - (const :tag "Never delete" nil))) - -(defcustom markdown-list-indent-width 4 - "Depth of indentation for markdown lists. -Used in `markdown-demote-list-item' and -`markdown-promote-list-item'." - :group 'markdown - :type 'integer) - -(defcustom markdown-enable-prefix-prompts t - "Display prompts for certain prefix commands. -Set to nil to disable these prompts." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-gfm-additional-languages nil - "Extra languages made available when inserting GFM code blocks. -Language strings must have be trimmed of whitespace and not -contain any curly braces. They may be of arbitrary -capitalization, though." - :group 'markdown - :type '(repeat (string :validate markdown-validate-language-string))) - -(defcustom markdown-gfm-use-electric-backquote t - "Use `markdown-electric-backquote' when backquote is hit three times." - :group 'markdown - :type 'boolean) - -(defcustom markdown-gfm-downcase-languages t - "If non-nil, downcase suggested languages. -This applies to insertions done with -`markdown-electric-backquote'." - :group 'markdown - :type 'boolean) - -(defcustom markdown-edit-code-block-default-mode 'normal-mode - "Default mode to use for editing code blocks. -This mode is used when automatic detection fails, such as for GFM -code blocks with no language specified." - :group 'markdown - :type '(choice function (const :tag "None" nil)) - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-gfm-uppercase-checkbox nil - "If non-nil, use [X] for completed checkboxes, [x] otherwise." - :group 'markdown - :type 'boolean - :safe 'booleanp) - -(defcustom markdown-hide-urls nil - "Hide URLs of inline links and reference tags of reference links. -Such URLs will be replaced by a single customizable -character, defined by `markdown-url-compose-char', but are still part -of the buffer. Links can be edited interactively with -\\[markdown-insert-link] or, for example, by deleting the final -parenthesis to remove the invisibility property. You can also -hover your mouse pointer over the link text to see the URL. -Set this to a non-nil value to turn this feature on by default. -You can interactively set the value of this variable by calling -`markdown-toggle-url-hiding', pressing \\[markdown-toggle-url-hiding], -or from the menu Markdown > Links & Images menu." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.3")) -(make-variable-buffer-local 'markdown-hide-urls) - -(defcustom markdown-translate-filename-function #'identity - "Function to use to translate filenames when following links. -\\<markdown-mode-map>\\[markdown-follow-thing-at-point] and \\[markdown-follow-link-at-point] -call this function with the filename as only argument whenever -they encounter a filename (instead of a URL) to be visited and -use its return value instead of the filename in the link. For -example, if absolute filenames are actually relative to a server -root directory, you can set -`markdown-translate-filename-function' to a function that -prepends the root directory to the given filename." - :group 'markdown - :type 'function - :risky t - :package-version '(markdown-mode . "2.4")) - -(defcustom markdown-max-image-size nil - "Maximum width and height for displayed inline images. -This variable may be nil or a cons cell (MAX-WIDTH . MAX-HEIGHT). -When nil, use the actual size. Otherwise, use ImageMagick to -resize larger images to be of the given maximum dimensions. This -requires Emacs to be built with ImageMagick support." - :group 'markdown - :package-version '(markdown-mode . "2.4") - :type '(choice - (const :tag "Use actual image width" nil) - (cons (choice (sexp :tag "Maximum width in pixels") - (const :tag "No maximum width" nil)) - (choice (sexp :tag "Maximum height in pixels") - (const :tag "No maximum height" nil))))) - -(defcustom markdown-mouse-follow-link t - "Non-nil means mouse on a link will follow the link. -This variable must be set before loading markdown-mode." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-table-align-p t - "Non-nil means that table is aligned after table operation." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-fontify-whole-heading-line nil - "Non-nil means fontify the whole line for headings. -This is useful when setting a background color for the -markdown-header-face-* faces." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-special-ctrl-a/e nil - "Non-nil means `C-a' and `C-e' behave specially in headlines and items. - -When t, `C-a' will bring back the cursor to the beginning of the -headline text. In an item, this will be the position after bullet -and check-box, if any. When the cursor is already at that -position, another `C-a' will bring it to the beginning of the -line. - -`C-e' will jump to the end of the headline, ignoring the presence -of closing tags in the headline. A second `C-e' will then jump to -the true end of the line, after closing tags. This also means -that, when this variable is non-nil, `C-e' also will never jump -beyond the end of the heading of a folded section, i.e. not after -the ellipses. - -When set to the symbol `reversed', the first `C-a' or `C-e' works -normally, going to the true line boundary first. Only a directly -following, identical keypress will bring the cursor to the -special positions. - -This may also be a cons cell where the behavior for `C-a' and -`C-e' is set separately." - :group 'markdown - :type '(choice - (const :tag "off" nil) - (const :tag "on: after hashes/bullet and before closing tags first" t) - (const :tag "reversed: true line boundary first" reversed) - (cons :tag "Set C-a and C-e separately" - (choice :tag "Special C-a" - (const :tag "off" nil) - (const :tag "on: after hashes/bullet first" t) - (const :tag "reversed: before hashes/bullet first" reversed)) - (choice :tag "Special C-e" - (const :tag "off" nil) - (const :tag "on: before closing tags first" t) - (const :tag "reversed: after closing tags first" reversed)))) - :package-version '(markdown-mode . "2.7")) - -;;; Markdown-Specific `rx' Macro ============================================== - -;; Based on python-rx from python.el. -(defmacro markdown-rx (&rest regexps) - "Markdown mode specialized rx macro. -This variant of `rx' supports common Markdown named REGEXPS." - `(rx-let ((newline "\n") - ;; Note: #405 not consider markdown-list-indent-width however this is never used - (indent (or (repeat 4 " ") "\t")) - (block-end (and (or (one-or-more (zero-or-more blank) "\n") line-end))) - (numeral (and (one-or-more (any "0-9#")) ".")) - (bullet (any "*+:-")) - (list-marker (or (and (one-or-more (any "0-9#")) ".") - (any "*+:-"))) - (checkbox (seq "[" (any " xX") "]"))) - (rx ,@regexps))) - - -;;; Regular Expressions ======================================================= - -(defconst markdown-regex-comment-start - "<!--" - "Regular expression matches HTML comment opening.") - -(defconst markdown-regex-comment-end - "--[ \t]*>" - "Regular expression matches HTML comment closing.") - -(defconst markdown-regex-link-inline - "\\(?1:!\\)?\\(?2:\\[\\)\\(?3:\\^?\\(?:\\\\\\]\\|[^]]\\)*\\|\\)\\(?4:\\]\\)\\(?5:(\\)\\s-*\\(?6:[^)]*?\\)\\(?:\\s-+\\(?7:\"[^\"]*\"\\)\\)?\\s-*\\(?8:)\\)" - "Regular expression for a [text](file) or an image link . -Group 1 matches the leading exclamation point (optional). -Group 2 matches the opening square bracket. -Group 3 matches the text inside the square brackets. -Group 4 matches the closing square bracket. -Group 5 matches the opening parenthesis. -Group 6 matches the URL. -Group 7 matches the title (optional). -Group 8 matches the closing parenthesis.") - -(defconst markdown-regex-link-reference - "\\(?1:!\\)?\\(?2:\\[\\)\\(?3:[^]^][^]]*\\|\\)\\(?4:\\]\\)\\(?5:\\[\\)\\(?6:[^]]*?\\)\\(?7:\\]\\)" - "Regular expression for a reference link [text][id]. -Group 1 matches the leading exclamation point (optional). -Group 2 matches the opening square bracket for the link text. -Group 3 matches the text inside the square brackets. -Group 4 matches the closing square bracket for the link text. -Group 5 matches the opening square bracket for the reference label. -Group 6 matches the reference label. -Group 7 matches the closing square bracket for the reference label.") - -(defconst markdown-regex-reference-definition - "^ \\{0,3\\}\\(?1:\\[\\)\\(?2:[^]\n]+?\\)\\(?3:\\]\\)\\(?4::\\)\\s *\\(?5:.*?\\)\\s *\\(?6: \"[^\"]*\"$\\|$\\)" - "Regular expression for a reference definition. -Group 1 matches the opening square bracket. -Group 2 matches the reference label. -Group 3 matches the closing square bracket. -Group 4 matches the colon. -Group 5 matches the URL. -Group 6 matches the title attribute (optional).") - -(defconst markdown-regex-footnote - "\\(?1:\\[\\^\\)\\(?2:.+?\\)\\(?3:\\]\\)" - "Regular expression for a footnote marker [^fn]. -Group 1 matches the opening square bracket and carat. -Group 2 matches only the label, without the surrounding markup. -Group 3 matches the closing square bracket.") - -(defconst markdown-regex-header - "^\\(?:\\(?1:[^\r\n\t -].*\\)\n\\(?:\\(?2:=+\\)\\|\\(?3:-+\\)\\)\\|\\(?4:#+[ \t]+\\)\\(?5:.*?\\)\\(?6:[ \t]+#+\\)?\\)$" - "Regexp identifying Markdown headings. -Group 1 matches the text of a setext heading. -Group 2 matches the underline of a level-1 setext heading. -Group 3 matches the underline of a level-2 setext heading. -Group 4 matches the opening hash marks of an atx heading and whitespace. -Group 5 matches the text, without surrounding whitespace, of an atx heading. -Group 6 matches the closing whitespace and hash marks of an atx heading.") - -(defconst markdown-regex-header-setext - "^\\([^\r\n\t -].*\\)\n\\(=+\\|-+\\)$" - "Regular expression for generic setext-style (underline) headers.") - -(defconst markdown-regex-header-atx - "^\\(#+\\)[ \t]+\\(.*?\\)[ \t]*\\(#*\\)$" - "Regular expression for generic atx-style (hash mark) headers.") - -(defconst markdown-regex-hr - (rx line-start - (group (or (and (repeat 3 (and "*" (? " "))) (* (any "* "))) - (and (repeat 3 (and "-" (? " "))) (* (any "- "))) - (and (repeat 3 (and "_" (? " "))) (* (any "_ "))))) - line-end) - "Regular expression for matching Markdown horizontal rules.") - -(defconst markdown-regex-code - "\\(?:\\`\\|[^\\]\\)\\(?1:\\(?2:`+\\)\\(?3:\\(?:.\\|\n[^\n]\\)*?[^`]\\)\\(?4:\\2\\)\\)\\(?:[^`]\\|\\'\\)" - "Regular expression for matching inline code fragments. - -Group 1 matches the entire code fragment including the backquotes. -Group 2 matches the opening backquotes. -Group 3 matches the code fragment itself, without backquotes. -Group 4 matches the closing backquotes. - -The leading, unnumbered group ensures that the leading backquote -character is not escaped. -The last group, also unnumbered, requires that the character -following the code fragment is not a backquote. -Note that \\(?:.\\|\n[^\n]\\) matches any character, including newlines, -but not two newlines in a row.") - -(defconst markdown-regex-kbd - "\\(?1:<kbd>\\)\\(?2:\\(?:.\\|\n[^\n]\\)*?\\)\\(?3:</kbd>\\)" - "Regular expression for matching <kbd> tags. -Groups 1 and 3 match the opening and closing tags. -Group 2 matches the key sequence.") - -(defconst markdown-regex-gfm-code-block-open - "^[[:blank:]]*\\(?1:```\\)\\(?2:[[:blank:]]*{?[[:blank:]]*\\)\\(?3:[^`[:space:]]+?\\)?\\(?:[[:blank:]]+\\(?4:.+?\\)\\)?\\(?5:[[:blank:]]*}?[[:blank:]]*\\)$" - "Regular expression matching opening of GFM code blocks. -Group 1 matches the opening three backquotes and any following whitespace. -Group 2 matches the opening brace (optional) and surrounding whitespace. -Group 3 matches the language identifier (optional). -Group 4 matches the info string (optional). -Group 5 matches the closing brace (optional), whitespace, and newline. -Groups need to agree with `markdown-regex-tilde-fence-begin'.") - -(defconst markdown-regex-gfm-code-block-close - "^[[:blank:]]*\\(?1:```\\)\\(?2:\\s *?\\)$" - "Regular expression matching closing of GFM code blocks. -Group 1 matches the closing three backquotes. -Group 2 matches any whitespace and the final newline.") - -(defconst markdown-regex-pre - "^\\( \\|\t\\).*$" - "Regular expression for matching preformatted text sections.") - -(defconst markdown-regex-list - (markdown-rx line-start - ;; 1. Leading whitespace - (group (* blank)) - ;; 2. List marker: a numeral, bullet, or colon - (group list-marker) - ;; 3. Trailing whitespace - (group (+ blank)) - ;; 4. Optional checkbox for GFM task list items - (opt (group (and checkbox (* blank))))) - "Regular expression for matching list items.") - -(defconst markdown-regex-bold - "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:\\*\\*\\|__\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:\\3\\)\\)" - "Regular expression for matching bold text. -Group 1 matches the character before the opening asterisk or -underscore, if any, ensuring that it is not a backslash escape. -Group 2 matches the entire expression, including delimiters. -Groups 3 and 5 matches the opening and closing delimiters. -Group 4 matches the text inside the delimiters.") - -(defconst markdown-regex-italic - "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:[*_]\\)\\(?3:[^ \n\t\\]\\|[^ \n\t*]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?4:\\2\\)\\)" - "Regular expression for matching italic text. -The leading unnumbered matches the character before the opening -asterisk or underscore, if any, ensuring that it is not a -backslash escape. -Group 1 matches the entire expression, including delimiters. -Groups 2 and 4 matches the opening and closing delimiters. -Group 3 matches the text inside the delimiters.") - -(defconst markdown-regex-strike-through - "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:~~\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:~~\\)\\)" - "Regular expression for matching strike-through text. -Group 1 matches the character before the opening tilde, if any, -ensuring that it is not a backslash escape. -Group 2 matches the entire expression, including delimiters. -Groups 3 and 5 matches the opening and closing delimiters. -Group 4 matches the text inside the delimiters.") - -(defconst markdown-regex-gfm-italic - "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:[*_]\\)\\(?3:[^ \\]\\2\\|[^ ]\\(?:.\\|\n[^\n]\\)*?\\)\\(?4:\\2\\)\\)" - "Regular expression for matching italic text in GitHub Flavored Markdown. -Underscores in words are not treated as special. -Group 1 matches the entire expression, including delimiters. -Groups 2 and 4 matches the opening and closing delimiters. -Group 3 matches the text inside the delimiters.") - -(defconst markdown-regex-blockquote - "^[ \t]*\\(?1:[A-Z]?>\\)\\(?2:[ \t]*\\)\\(?3:.*\\)$" - "Regular expression for matching blockquote lines. -Also accounts for a potential capital letter preceding the angle -bracket, for use with Leanpub blocks (asides, warnings, info -blocks, etc.). -Group 1 matches the leading angle bracket. -Group 2 matches the separating whitespace. -Group 3 matches the text.") - -(defconst markdown-regex-line-break - "[^ \n\t][ \t]*\\( \\)\n" - "Regular expression for matching line breaks.") - -(defconst markdown-regex-escape - "\\(\\\\\\)." - "Regular expression for matching escape sequences.") - -(defconst markdown-regex-wiki-link - "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:\\[\\[\\)\\(?3:[^]|]+\\)\\(?:\\(?4:|\\)\\(?5:[^]]+\\)\\)?\\(?6:\\]\\]\\)\\)" - "Regular expression for matching wiki links. -This matches typical bracketed [[WikiLinks]] as well as \\='aliased -wiki links of the form [[PageName|link text]]. -The meanings of the first and second components depend -on the value of `markdown-wiki-link-alias-first'. - -Group 1 matches the entire link. -Group 2 matches the opening square brackets. -Group 3 matches the first component of the wiki link. -Group 4 matches the pipe separator, when present. -Group 5 matches the second component of the wiki link, when present. -Group 6 matches the closing square brackets.") - -(defconst markdown-regex-uri - (concat "\\(" (regexp-opt markdown-uri-types) ":[^]\t\n\r<>; ]+\\)") - "Regular expression for matching inline URIs.") - -;; CommanMark specification says scheme length is 2-32 characters -(defconst markdown-regex-angle-uri - (concat "\\(<\\)\\([a-z][a-z0-9.+-]\\{1,31\\}:[^]\t\n\r<>,;()]+\\)\\(>\\)") - "Regular expression for matching inline URIs in angle brackets.") - -(defconst markdown-regex-email - "<\\(\\(?:\\sw\\|\\s_\\|\\s.\\)+@\\(?:\\sw\\|\\s_\\|\\s.\\)+\\)>" - "Regular expression for matching inline email addresses.") - -(defsubst markdown-make-regex-link-generic () - "Make regular expression for matching any recognized link." - (concat "\\(?:" markdown-regex-link-inline - (when markdown-enable-wiki-links - (concat "\\|" markdown-regex-wiki-link)) - "\\|" markdown-regex-link-reference - "\\|" markdown-regex-angle-uri "\\)")) - -(defconst markdown-regex-gfm-checkbox - " \\(\\[[ xX]\\]\\) " - "Regular expression for matching GFM checkboxes. -Group 1 matches the text to become a button.") - -(defconst markdown-regex-blank-line - "^[[:blank:]]*$" - "Regular expression that matches a blank line.") - -(defconst markdown-regex-block-separator - "\n[\n\t\f ]*\n" - "Regular expression for matching block boundaries.") - -(defconst markdown-regex-block-separator-noindent - (concat "\\(\\`\\|\\(" markdown-regex-block-separator "\\)[^\n\t\f ]\\)") - "Regexp for block separators before lines with no indentation.") - -(defconst markdown-regex-math-inline-single - "\\(?:^\\|[^\\]\\)\\(?1:\\$\\)\\(?2:\\(?:[^\\$]\\|\\\\.\\)*\\)\\(?3:\\$\\)" - "Regular expression for itex $..$ math mode expressions. -Groups 1 and 3 match the opening and closing dollar signs. -Group 2 matches the mathematical expression contained within.") - -(defconst markdown-regex-math-inline-double - "\\(?:^\\|[^\\]\\)\\(?1:\\$\\$\\)\\(?2:\\(?:[^\\$]\\|\\\\.\\)*\\)\\(?3:\\$\\$\\)" - "Regular expression for itex $$..$$ math mode expressions. -Groups 1 and 3 match opening and closing dollar signs. -Group 2 matches the mathematical expression contained within.") - -(defconst markdown-regex-math-display - (rx line-start (* blank) - (group (group (repeat 1 2 "\\")) "[") - (group (*? anything)) - (group (backref 2) "]") - line-end) - "Regular expression for \[..\] or \\[..\\] display math. -Groups 1 and 4 match the opening and closing markup. -Group 3 matches the mathematical expression contained within. -Group 2 matches the opening slashes, and is used internally to -match the closing slashes.") - -(defsubst markdown-make-tilde-fence-regex (num-tildes &optional end-of-line) - "Return regexp matching a tilde code fence at least NUM-TILDES long. -END-OF-LINE is the regexp construct to indicate end of line; $ if -missing." - (format "%s%d%s%s" "^[[:blank:]]*\\([~]\\{" num-tildes ",\\}\\)" - (or end-of-line "$"))) - -(defconst markdown-regex-tilde-fence-begin - (markdown-make-tilde-fence-regex - 3 "\\([[:blank:]]*{?\\)[[:blank:]]*\\([^[:space:]]+?\\)?\\(?:[[:blank:]]+\\(.+?\\)\\)?\\([[:blank:]]*}?[[:blank:]]*\\)$") - "Regular expression for matching tilde-fenced code blocks. -Group 1 matches the opening tildes. -Group 2 matches (optional) opening brace and surrounding whitespace. -Group 3 matches the language identifier (optional). -Group 4 matches the info string (optional). -Group 5 matches the closing brace (optional) and any surrounding whitespace. -Groups need to agree with `markdown-regex-gfm-code-block-open'.") - -(defconst markdown-regex-declarative-metadata - "^[ \t]*\\(?:-[ \t]*\\)?\\([[:alpha:]][[:alpha:] _-]*?\\)\\([:=][ \t]*\\)\\(.*\\)$" - "Regular expression for matching declarative metadata statements. -This matches MultiMarkdown metadata as well as YAML and TOML -assignments such as the following: - - variable: value - -or - - variable = value") - -(defconst markdown-regex-pandoc-metadata - "^\\(%\\)\\([ \t]*\\)\\(.*\\(?:\n[ \t]+.*\\)*\\)" - "Regular expression for matching Pandoc metadata.") - -(defconst markdown-regex-yaml-metadata-border - "\\(-\\{3\\}\\)$" - "Regular expression for matching YAML metadata.") - -(defconst markdown-regex-yaml-pandoc-metadata-end-border - "^\\(\\.\\{3\\}\\|\\-\\{3\\}\\)$" - "Regular expression for matching YAML metadata end borders.") - -(defsubst markdown-get-yaml-metadata-start-border () - "Return YAML metadata start border depending upon whether Pandoc is used." - (concat - (if markdown-use-pandoc-style-yaml-metadata "^" "\\`") - markdown-regex-yaml-metadata-border)) - -(defsubst markdown-get-yaml-metadata-end-border (_) - "Return YAML metadata end border depending upon whether Pandoc is used." - (if markdown-use-pandoc-style-yaml-metadata - markdown-regex-yaml-pandoc-metadata-end-border - markdown-regex-yaml-metadata-border)) - -(defconst markdown-regex-inline-attributes - "[ \t]*\\(?:{:?\\)[ \t]*\\(?:\\(?:#[[:alpha:]_.:-]+\\|\\.[[:alpha:]_.:-]+\\|\\w+=['\"]?[^\n'\"}]*['\"]?\\),?[ \t]*\\)+\\(?:}\\)[ \t]*$" - "Regular expression for matching inline identifiers or attribute lists. -Compatible with Pandoc, Python Markdown, PHP Markdown Extra, and Leanpub.") - -(defconst markdown-regex-leanpub-sections - (concat - "^\\({\\)\\(" - (regexp-opt '("frontmatter" "mainmatter" "backmatter" "appendix" "pagebreak")) - "\\)\\(}\\)[ \t]*\n") - "Regular expression for Leanpub section markers and related syntax.") - -(defconst markdown-regex-sub-superscript - "\\(?:^\\|[^\\~^]\\)\\(?1:\\(?2:[~^]\\)\\(?3:[+-\u2212]?[[:alnum:]]+\\)\\(?4:\\2\\)\\)" - "The regular expression matching a sub- or superscript. -The leading un-numbered group matches the character before the -opening tilde or carat, if any, ensuring that it is not a -backslash escape, carat, or tilde. -Group 1 matches the entire expression, including markup. -Group 2 matches the opening markup--a tilde or carat. -Group 3 matches the text inside the delimiters. -Group 4 matches the closing markup--a tilde or carat.") - -(defconst markdown-regex-include - "^\\(?1:<<\\)\\(?:\\(?2:\\[\\)\\(?3:.*\\)\\(?4:\\]\\)\\)?\\(?:\\(?5:(\\)\\(?6:.*\\)\\(?7:)\\)\\)?\\(?:\\(?8:{\\)\\(?9:.*\\)\\(?10:}\\)\\)?$" - "Regular expression matching common forms of include syntax. -Marked 2, Leanpub, and other processors support some of these forms: - -<<[sections/section1.md] -<<(folder/filename) -<<[Code title](folder/filename) -<<{folder/raw_file.html} - -Group 1 matches the opening two angle brackets. -Groups 2-4 match the opening square bracket, the text inside, -and the closing square bracket, respectively. -Groups 5-7 match the opening parenthesis, the text inside, and -the closing parenthesis. -Groups 8-10 match the opening brace, the text inside, and the brace.") - -(defconst markdown-regex-pandoc-inline-footnote - "\\(?1:\\^\\)\\(?2:\\[\\)\\(?3:\\(?:.\\|\n[^\n]\\)*?\\)\\(?4:\\]\\)" - "Regular expression for Pandoc inline footnote^[footnote text]. -Group 1 matches the opening caret. -Group 2 matches the opening square bracket. -Group 3 matches the footnote text, without the surrounding markup. -Group 4 matches the closing square bracket.") - -(defconst markdown-regex-html-attr - "\\(\\<[[:alpha:]:-]+\\>\\)\\(\\s-*\\(=\\)\\s-*\\(\".*?\"\\|'.*?'\\|[^'\">[:space:]]+\\)?\\)?" - "Regular expression for matching HTML attributes and values. -Group 1 matches the attribute name. -Group 2 matches the following whitespace, equals sign, and value, if any. -Group 3 matches the equals sign, if any. -Group 4 matches single-, double-, or un-quoted attribute values.") - -(defconst markdown-regex-html-tag - (concat "\\(</?\\)\\(\\w+\\)\\(\\(\\s-+" markdown-regex-html-attr - "\\)+\\s-*\\|\\s-*\\)\\(/?>\\)") - "Regular expression for matching HTML tags. -Groups 1 and 9 match the beginning and ending angle brackets and slashes. -Group 2 matches the tag name. -Group 3 matches all attributes and whitespace following the tag name.") - -(defconst markdown-regex-html-entity - "\\(&#?[[:alnum:]]+;\\)" - "Regular expression for matching HTML entities.") - -(defconst markdown-regex-highlighting - "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:==\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:==\\)\\)" -"Regular expression for matching highlighting text. -Group 1 matches the character before the opening equal, if any, -ensuring that it is not a backslash escape. -Group 2 matches the entire expression, including delimiters. -Groups 3 and 5 matches the opening and closing delimiters. -Group 4 matches the text inside the delimiters.") - - -;;; Syntax ==================================================================== - -(defvar markdown--syntax-properties - (list 'markdown-tilde-fence-begin nil - 'markdown-tilde-fence-end nil - 'markdown-fenced-code nil - 'markdown-yaml-metadata-begin nil - 'markdown-yaml-metadata-end nil - 'markdown-yaml-metadata-section nil - 'markdown-gfm-block-begin nil - 'markdown-gfm-block-end nil - 'markdown-gfm-code nil - 'markdown-list-item nil - 'markdown-pre nil - 'markdown-blockquote nil - 'markdown-hr nil - 'markdown-comment nil - 'markdown-heading nil - 'markdown-heading-1-setext nil - 'markdown-heading-2-setext nil - 'markdown-heading-1-atx nil - 'markdown-heading-2-atx nil - 'markdown-heading-3-atx nil - 'markdown-heading-4-atx nil - 'markdown-heading-5-atx nil - 'markdown-heading-6-atx nil - 'markdown-metadata-key nil - 'markdown-metadata-value nil - 'markdown-metadata-markup nil) - "Property list of all Markdown syntactic properties.") - -(defvar markdown-literal-faces - '(markdown-code-face - markdown-inline-code-face - markdown-pre-face - markdown-math-face - markdown-url-face - markdown-plain-url-face - markdown-language-keyword-face - markdown-language-info-face - markdown-metadata-key-face - markdown-metadata-value-face - markdown-html-entity-face - markdown-html-tag-name-face - markdown-html-tag-delimiter-face - markdown-html-attr-name-face - markdown-html-attr-value-face - markdown-reference-face - markdown-footnote-marker-face - markdown-line-break-face - markdown-comment-face) - "A list of markdown-mode faces that contain literal text. -Literal text treats backslashes literally, rather than as an -escape character (see `markdown-match-escape').") - -(defsubst markdown-in-comment-p (&optional pos) - "Return non-nil if POS is in a comment. -If POS is not given, use point instead." - (get-text-property (or pos (point)) 'markdown-comment)) - -(defun markdown--face-p (pos faces) - "Return non-nil if face of POS contain FACES." - (let ((face-prop (get-text-property pos 'face))) - (if (listp face-prop) - (cl-loop for face in face-prop - thereis (memq face faces)) - (memq face-prop faces)))) - -(defsubst markdown--math-block-p (&optional pos) - (when markdown-enable-math - (markdown--face-p (or pos (point)) '(markdown-math-face)))) - -(defun markdown-syntax-propertize-extend-region (start end) - "Extend START to END region to include an entire block of text. -This helps improve syntax analysis for block constructs. -Returns a cons (NEW-START . NEW-END) or nil if no adjustment should be made. -Function is called repeatedly until it returns nil. For details, see -`syntax-propertize-extend-region-functions'." - (save-match-data - (save-excursion - (let* ((new-start (progn (goto-char start) - (skip-chars-forward "\n") - (if (re-search-backward "\n\n" nil t) - (min start (match-end 0)) - (point-min)))) - (new-end (progn (goto-char end) - (skip-chars-backward "\n") - (if (re-search-forward "\n\n" nil t) - (max end (match-beginning 0)) - (point-max)))) - (code-match (markdown-code-block-at-pos new-start)) - ;; FIXME: The `code-match' can return bogus values - ;; when text has been inserted/deleted! - (new-start (min (or (and code-match (cl-first code-match)) - (point-max)) - new-start)) - (code-match (and (< end (point-max)) - (markdown-code-block-at-pos end))) - (new-end (max (or (and code-match (cl-second code-match)) 0) - new-end))) - - (unless (and (eq new-start start) (eq new-end end)) - (cons new-start (min new-end (point-max)))))))) - -(defun markdown-font-lock-extend-region-function (start end _) - "Used in `jit-lock-after-change-extend-region-functions'. -Delegates to `markdown-syntax-propertize-extend-region'. START -and END are the previous region to refontify." - (let ((res (markdown-syntax-propertize-extend-region start end))) - (when res - ;; syntax-propertize-function is not called when character at - ;; (point-max) is deleted, but font-lock-extend-region-functions - ;; are called. Force a syntax property update in that case. - (when (= end (point-max)) - ;; This function is called in a buffer modification hook. - ;; `markdown-syntax-propertize' doesn't save the match data, - ;; so we have to do it here. - (save-match-data - (markdown-syntax-propertize (car res) (cdr res)))) - (setq jit-lock-start (car res) - jit-lock-end (cdr res))))) - -(defun markdown--cur-list-item-bounds () - "Return a list describing the list item at point. -Assumes that match data is set for `markdown-regex-list'. See the -documentation for `markdown-cur-list-item-bounds' for the format of -the returned list." - (save-excursion - (let* ((begin (match-beginning 0)) - (indent (length (match-string-no-properties 1))) - (nonlist-indent (- (match-end 3) (match-beginning 0))) - (marker (buffer-substring-no-properties - (match-beginning 2) (match-end 3))) - (checkbox (match-string-no-properties 4)) - (match (butlast (match-data t))) - (end (markdown-cur-list-item-end nonlist-indent))) - (list begin end indent nonlist-indent marker checkbox match)))) - -(defun markdown--append-list-item-bounds (marker indent cur-bounds bounds) - "Update list item BOUNDS given list MARKER, block INDENT, and CUR-BOUNDS. -Here, MARKER is a string representing the type of list and INDENT -is an integer giving the indentation, in spaces, of the current -block. CUR-BOUNDS is a list of the form returned by -`markdown-cur-list-item-bounds' and BOUNDS is a list of bounds -values for parent list items. When BOUNDS is nil, it means we are -at baseline (not inside of a nested list)." - (let ((prev-indent (or (cl-third (car bounds)) 0))) - (cond - ;; New list item at baseline. - ((and marker (null bounds)) - (list cur-bounds)) - ;; List item with greater indentation (four or more spaces). - ;; Increase list level by consing CUR-BOUNDS onto BOUNDS. - ((and marker (>= indent (+ prev-indent markdown-list-indent-width))) - (cons cur-bounds bounds)) - ;; List item with greater or equal indentation (less than four spaces). - ;; Keep list level the same by replacing the car of BOUNDS. - ((and marker (>= indent prev-indent)) - (cons cur-bounds (cdr bounds))) - ;; Lesser indentation level. - ;; Pop appropriate number of elements off BOUNDS list (e.g., lesser - ;; indentation could move back more than one list level). Note - ;; that this block need not be the beginning of list item. - ((< indent prev-indent) - (while (and (> (length bounds) 1) - (setq prev-indent (cl-third (cadr bounds))) - (< indent (+ prev-indent markdown-list-indent-width))) - (setq bounds (cdr bounds))) - (cons cur-bounds bounds)) - ;; Otherwise, do nothing. - (t bounds)))) - -(defun markdown-syntax-propertize-list-items (start end) - "Propertize list items from START to END. -Stores nested list item information in the `markdown-list-item' -text property to make later syntax analysis easier. The value of -this property is a list with elements of the form (begin . end) -giving the bounds of the current and parent list items." - (save-excursion - (goto-char start) - (let ((prev-list-line -100) - bounds level pre-regexp) - ;; Find a baseline point with zero list indentation - (markdown-search-backward-baseline) - ;; Search for all list items between baseline and END - (while (and (< (point) end) - (re-search-forward markdown-regex-list end 'limit)) - ;; Level of list nesting - (setq level (length bounds)) - ;; Pre blocks need to be indented one level past the list level - (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" (1+ level))) - (beginning-of-line) - (cond - ;; Reset at headings, horizontal rules, and top-level blank lines. - ;; Propertize baseline when in range. - ((markdown-new-baseline) - (setq bounds nil)) - ;; Make sure this is not a line from a pre block - ((and (looking-at-p pre-regexp) - ;; too indented line is also treated as list if previous line is list - (>= (- (line-number-at-pos) prev-list-line) 2))) - ;; If not, then update levels and propertize list item when in range. - (t - (let* ((indent (current-indentation)) - (cur-bounds (markdown--cur-list-item-bounds)) - (first (cl-first cur-bounds)) - (last (cl-second cur-bounds)) - (marker (cl-fifth cur-bounds))) - (setq bounds (markdown--append-list-item-bounds - marker indent cur-bounds bounds)) - (when (and (<= start (point)) (<= (point) end)) - (setq prev-list-line (line-number-at-pos first)) - (put-text-property first last 'markdown-list-item bounds))))) - (end-of-line))))) - -(defun markdown-syntax-propertize-pre-blocks (start end) - "Match preformatted text blocks from START to END." - (save-excursion - (goto-char start) - (let (finish) - ;; Use loop for avoiding too many recursive calls - ;; https://github.com/jrblevin/markdown-mode/issues/512 - (while (not finish) - (let ((levels (markdown-calculate-list-levels)) - indent pre-regexp close-regexp open close) - (while (and (< (point) end) (not close)) - ;; Search for a region with sufficient indentation - (if (null levels) - (setq indent 1) - (setq indent (1+ (length levels)))) - (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" indent)) - (setq close-regexp (format "^\\( \\|\t\\)\\{0,%d\\}\\([^ \t]\\)" (1- indent))) - - (cond - ;; If not at the beginning of a line, move forward - ((not (bolp)) (forward-line)) - ;; Move past blank lines - ((markdown-cur-line-blank-p) (forward-line)) - ;; At headers and horizontal rules, reset levels - ((markdown-new-baseline) (forward-line) (setq levels nil)) - ;; If the current line has sufficient indentation, mark out pre block - ;; The opening should be preceded by a blank line. - ((and (markdown-prev-line-blank) (looking-at pre-regexp)) - (setq open (match-beginning 0)) - (while (and (or (looking-at-p pre-regexp) (markdown-cur-line-blank-p)) - (not (eobp))) - (forward-line)) - (skip-syntax-backward "-") - (forward-line) - (setq close (point))) - ;; If current line has a list marker, update levels, move to end of block - ((looking-at markdown-regex-list) - (setq levels (markdown-update-list-levels - (match-string 2) (current-indentation) levels)) - (markdown-end-of-text-block)) - ;; If this is the end of the indentation level, adjust levels accordingly. - ;; Only match end of indentation level if levels is not the empty list. - ((and (car levels) (looking-at-p close-regexp)) - (setq levels (markdown-update-list-levels - nil (current-indentation) levels)) - (markdown-end-of-text-block)) - (t (markdown-end-of-text-block)))) - - (if (and open close) - ;; Set text property data and continue to search - (put-text-property open close 'markdown-pre (list open close)) - (setq finish t)))) - nil))) - -(defconst markdown-fenced-block-pairs - `(((,markdown-regex-tilde-fence-begin markdown-tilde-fence-begin) - (markdown-make-tilde-fence-regex markdown-tilde-fence-end) - markdown-fenced-code) - ((markdown-get-yaml-metadata-start-border markdown-yaml-metadata-begin) - (markdown-get-yaml-metadata-end-border markdown-yaml-metadata-end) - markdown-yaml-metadata-section) - ((,markdown-regex-gfm-code-block-open markdown-gfm-block-begin) - (,markdown-regex-gfm-code-block-close markdown-gfm-block-end) - markdown-gfm-code)) - "Mapping of regular expressions to \"fenced-block\" constructs. -These constructs are distinguished by having a distinctive start -and end pattern, both of which take up an entire line of text, -but no special pattern to identify text within the fenced -blocks (unlike blockquotes and indented-code sections). - -Each element within this list takes the form: - - ((START-REGEX-OR-FUN START-PROPERTY) - (END-REGEX-OR-FUN END-PROPERTY) - MIDDLE-PROPERTY) - -Each *-REGEX-OR-FUN element can be a regular expression as a string, or a -function which evaluates to same. Functions for START-REGEX-OR-FUN accept no -arguments, but functions for END-REGEX-OR-FUN accept a single numerical argument -which is the length of the first group of the START-REGEX-OR-FUN match, which -can be ignored if unnecessary. `markdown-maybe-funcall-regexp' is used to -evaluate these into \"real\" regexps. - -The *-PROPERTY elements are the text properties applied to each part of the -block construct when it is matched using -`markdown-syntax-propertize-fenced-block-constructs'. START-PROPERTY is applied -to the text matching START-REGEX-OR-FUN, END-PROPERTY to END-REGEX-OR-FUN, and -MIDDLE-PROPERTY to the text in between the two. The value of *-PROPERTY is the -`match-data' when the regexp was matched to the text. In the case of -MIDDLE-PROPERTY, the value is a false match data of the form \\='(begin end), with -begin and end set to the edges of the \"middle\" text. This makes fontification -easier.") - -(defun markdown-text-property-at-point (prop) - (get-text-property (point) prop)) - -(defsubst markdown-maybe-funcall-regexp (object &optional arg) - (cond ((functionp object) - (if arg (funcall object arg) (funcall object))) - ((stringp object) object) - (t (error "Object cannot be turned into regex")))) - -(defsubst markdown-get-start-fence-regexp () - "Return regexp to find all \"start\" sections of fenced block constructs. -Which construct is actually contained in the match must be found separately." - (mapconcat - #'identity - (mapcar (lambda (entry) (markdown-maybe-funcall-regexp (caar entry))) - markdown-fenced-block-pairs) - "\\|")) - -(defun markdown-get-fenced-block-begin-properties () - (cl-mapcar (lambda (entry) (cl-cadar entry)) markdown-fenced-block-pairs)) - -(defun markdown-get-fenced-block-end-properties () - (cl-mapcar (lambda (entry) (cl-cadadr entry)) markdown-fenced-block-pairs)) - -(defun markdown-get-fenced-block-middle-properties () - (cl-mapcar #'cl-third markdown-fenced-block-pairs)) - -(defun markdown-find-previous-prop (prop &optional lim) - "Find previous place where property PROP is non-nil, up to LIM. -Return a cons of (pos . property). pos is point if point contains -non-nil PROP." - (let ((res - (if (get-text-property (point) prop) (point) - (previous-single-property-change - (point) prop nil (or lim (point-min)))))) - (when (and (not (get-text-property res prop)) - (> res (point-min)) - (get-text-property (1- res) prop)) - (cl-decf res)) - (when (and res (get-text-property res prop)) (cons res prop)))) - -(defun markdown-find-next-prop (prop &optional lim) - "Find next place where property PROP is non-nil, up to LIM. -Return a cons of (POS . PROPERTY) where POS is point if point -contains non-nil PROP." - (let ((res - (if (get-text-property (point) prop) (point) - (next-single-property-change - (point) prop nil (or lim (point-max)))))) - (when (and res (get-text-property res prop)) (cons res prop)))) - -(defun markdown-min-of-seq (map-fn seq) - "Apply MAP-FN to SEQ and return element of SEQ with minimum value of MAP-FN." - (cl-loop for el in seq - with min = 1.0e+INF ; infinity - with min-el = nil - do (let ((res (funcall map-fn el))) - (when (< res min) - (setq min res) - (setq min-el el))) - finally return min-el)) - -(defun markdown-max-of-seq (map-fn seq) - "Apply MAP-FN to SEQ and return element of SEQ with maximum value of MAP-FN." - (cl-loop for el in seq - with max = -1.0e+INF ; negative infinity - with max-el = nil - do (let ((res (funcall map-fn el))) - (when (and res (> res max)) - (setq max res) - (setq max-el el))) - finally return max-el)) - -(defun markdown-find-previous-block () - "Find previous block. -Detect whether `markdown-syntax-propertize-fenced-block-constructs' was -unable to propertize the entire block, but was able to propertize the beginning -of the block. If so, return a cons of (pos . property) where the beginning of -the block was propertized." - (let ((start-pt (point)) - (closest-open - (markdown-max-of-seq - #'car - (cl-remove-if - #'null - (cl-mapcar - #'markdown-find-previous-prop - (markdown-get-fenced-block-begin-properties)))))) - (when closest-open - (let* ((length-of-open-match - (let ((match-d - (get-text-property (car closest-open) (cdr closest-open)))) - (- (cl-fourth match-d) (cl-third match-d)))) - (end-regexp - (markdown-maybe-funcall-regexp - (cl-caadr - (cl-find-if - (lambda (entry) (eq (cl-cadar entry) (cdr closest-open))) - markdown-fenced-block-pairs)) - length-of-open-match)) - (end-prop-loc - (save-excursion - (save-match-data - (goto-char (car closest-open)) - (and (re-search-forward end-regexp start-pt t) - (match-beginning 0)))))) - (and (not end-prop-loc) closest-open))))) - -(defun markdown-get-fenced-block-from-start (prop) - "Return limits of an enclosing fenced block from its start, using PROP. -Return value is a list usable as `match-data'." - (catch 'no-rest-of-block - (let* ((correct-entry - (cl-find-if - (lambda (entry) (eq (cl-cadar entry) prop)) - markdown-fenced-block-pairs)) - (begin-of-begin (cl-first (markdown-text-property-at-point prop))) - (middle-prop (cl-third correct-entry)) - (end-prop (cl-cadadr correct-entry)) - (end-of-end - (save-excursion - (goto-char (match-end 0)) ; end of begin - (unless (eobp) (forward-char)) - (let ((mid-prop-v (markdown-text-property-at-point middle-prop))) - (if (not mid-prop-v) ; no middle - (progn - ;; try to find end by advancing one - (let ((end-prop-v - (markdown-text-property-at-point end-prop))) - (if end-prop-v (cl-second end-prop-v) - (throw 'no-rest-of-block nil)))) - (set-match-data mid-prop-v) - (goto-char (match-end 0)) ; end of middle - (beginning-of-line) ; into end - (cl-second (markdown-text-property-at-point end-prop))))))) - (list begin-of-begin end-of-end)))) - -(defun markdown-get-fenced-block-from-middle (prop) - "Return limits of an enclosing fenced block from its middle, using PROP. -Return value is a list usable as `match-data'." - (let* ((correct-entry - (cl-find-if - (lambda (entry) (eq (cl-third entry) prop)) - markdown-fenced-block-pairs)) - (begin-prop (cl-cadar correct-entry)) - (begin-of-begin - (save-excursion - (goto-char (match-beginning 0)) - (unless (bobp) (forward-line -1)) - (beginning-of-line) - (cl-first (markdown-text-property-at-point begin-prop)))) - (end-prop (cl-cadadr correct-entry)) - (end-of-end - (save-excursion - (goto-char (match-end 0)) - (beginning-of-line) - (cl-second (markdown-text-property-at-point end-prop))))) - (list begin-of-begin end-of-end))) - -(defun markdown-get-fenced-block-from-end (prop) - "Return limits of an enclosing fenced block from its end, using PROP. -Return value is a list usable as `match-data'." - (let* ((correct-entry - (cl-find-if - (lambda (entry) (eq (cl-cadadr entry) prop)) - markdown-fenced-block-pairs)) - (end-of-end (cl-second (markdown-text-property-at-point prop))) - (middle-prop (cl-third correct-entry)) - (begin-prop (cl-cadar correct-entry)) - (begin-of-begin - (save-excursion - (goto-char (match-beginning 0)) ; beginning of end - (unless (bobp) (backward-char)) ; into middle - (let ((mid-prop-v (markdown-text-property-at-point middle-prop))) - (if (not mid-prop-v) - (progn - (beginning-of-line) - (cl-first (markdown-text-property-at-point begin-prop))) - (set-match-data mid-prop-v) - (goto-char (match-beginning 0)) ; beginning of middle - (unless (bobp) (forward-line -1)) ; into beginning - (beginning-of-line) - (cl-first (markdown-text-property-at-point begin-prop))))))) - (list begin-of-begin end-of-end))) - -(defun markdown-get-enclosing-fenced-block-construct (&optional pos) - "Get \"fake\" match data for block enclosing POS. -Returns fake match data which encloses the start, middle, and end -of the block construct enclosing POS, if it exists. Used in -`markdown-code-block-at-pos'." - (save-excursion - (when pos (goto-char pos)) - (beginning-of-line) - (car - (cl-remove-if - #'null - (cl-mapcar - (lambda (fun-and-prop) - (cl-destructuring-bind (fun prop) fun-and-prop - (when prop - (save-match-data - (set-match-data (markdown-text-property-at-point prop)) - (funcall fun prop))))) - `((markdown-get-fenced-block-from-start - ,(cl-find-if - #'markdown-text-property-at-point - (markdown-get-fenced-block-begin-properties))) - (markdown-get-fenced-block-from-middle - ,(cl-find-if - #'markdown-text-property-at-point - (markdown-get-fenced-block-middle-properties))) - (markdown-get-fenced-block-from-end - ,(cl-find-if - #'markdown-text-property-at-point - (markdown-get-fenced-block-end-properties))))))))) - -(defun markdown-propertize-end-match (reg end fence-spec middle-begin) - "Get match for REG up to END, if exists, and propertize appropriately. -FENCE-SPEC is an entry in `markdown-fenced-block-pairs' and -MIDDLE-BEGIN is the start of the \"middle\" section of the block." - (when (re-search-forward reg end t) - (let ((close-begin (match-beginning 0)) ; Start of closing line. - (close-end (match-end 0)) ; End of closing line. - (close-data (match-data t))) ; Match data for closing line. - ;; Propertize middle section of fenced block. - (put-text-property middle-begin close-begin - (cl-third fence-spec) - (list middle-begin close-begin)) - ;; If the block is a YAML block, propertize the declarations inside - (when (< middle-begin close-begin) ;; workaround #634 - (markdown-syntax-propertize-yaml-metadata middle-begin close-begin)) - ;; Propertize closing line of fenced block. - (put-text-property close-begin close-end - (cl-cadadr fence-spec) close-data)))) - -(defun markdown--triple-quote-single-line-p (begin) - (save-excursion - (goto-char begin) - (save-match-data - (and (search-forward "```" nil t) - (search-forward "```" (line-end-position) t))))) - -(defun markdown-syntax-propertize-fenced-block-constructs (start end) - "Propertize according to `markdown-fenced-block-pairs' from START to END. -If unable to propertize an entire block (if the start of a block is within START -and END, but the end of the block is not), propertize the start section of a -block, then in a subsequent call propertize both middle and end by finding the -start which was previously propertized." - (let ((start-reg (markdown-get-start-fence-regexp))) - (save-excursion - (goto-char start) - ;; start from previous unclosed block, if exists - (let ((prev-begin-block (markdown-find-previous-block))) - (when prev-begin-block - (let* ((correct-entry - (cl-find-if (lambda (entry) - (eq (cdr prev-begin-block) (cl-cadar entry))) - markdown-fenced-block-pairs)) - (enclosed-text-start (1+ (car prev-begin-block))) - (start-length - (save-excursion - (goto-char (car prev-begin-block)) - (string-match - (markdown-maybe-funcall-regexp - (caar correct-entry)) - (buffer-substring - (line-beginning-position) (line-end-position))) - (- (match-end 1) (match-beginning 1)))) - (end-reg (markdown-maybe-funcall-regexp - (cl-caadr correct-entry) start-length))) - (markdown-propertize-end-match - end-reg end correct-entry enclosed-text-start)))) - ;; find all new blocks within region - (while (re-search-forward start-reg end t) - ;; we assume the opening constructs take up (only) an entire line, - ;; so we re-check the current line - (let* ((block-start (match-beginning 0)) - (cur-line (buffer-substring (line-beginning-position) (line-end-position))) - ;; find entry in `markdown-fenced-block-pairs' corresponding - ;; to regex which was matched - (correct-entry - (cl-find-if - (lambda (fenced-pair) - (string-match-p - (markdown-maybe-funcall-regexp (caar fenced-pair)) - cur-line)) - markdown-fenced-block-pairs)) - (enclosed-text-start - (save-excursion (1+ (line-end-position)))) - (end-reg - (markdown-maybe-funcall-regexp - (cl-caadr correct-entry) - (if (and (match-beginning 1) (match-end 1)) - (- (match-end 1) (match-beginning 1)) - 0))) - (prop (cl-cadar correct-entry))) - (when (or (not (eq prop 'markdown-gfm-block-begin)) - (not (markdown--triple-quote-single-line-p block-start))) - ;; get correct match data - (save-excursion - (beginning-of-line) - (re-search-forward - (markdown-maybe-funcall-regexp (caar correct-entry)) - (line-end-position))) - ;; mark starting, even if ending is outside of region - (put-text-property (match-beginning 0) (match-end 0) prop (match-data t)) - (markdown-propertize-end-match - end-reg end correct-entry enclosed-text-start))))))) - -(defun markdown-syntax-propertize-blockquotes (start end) - "Match blockquotes from START to END." - (save-excursion - (goto-char start) - (while (and (re-search-forward markdown-regex-blockquote end t) - (not (markdown-code-block-at-pos (match-beginning 0)))) - (put-text-property (match-beginning 0) (match-end 0) - 'markdown-blockquote - (match-data t))))) - -(defun markdown-syntax-propertize-hrs (start end) - "Match horizontal rules from START to END." - (save-excursion - (goto-char start) - (while (re-search-forward markdown-regex-hr end t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (goto-char beg) - (unless (or (markdown-on-heading-p) - (markdown-code-block-at-point-p)) - (put-text-property beg end 'markdown-hr (match-data t))) - (goto-char end))))) - -(defun markdown-syntax-propertize-yaml-metadata (start end) - "Propertize elements inside YAML metadata blocks from START to END. -Assumes region from START and END is already known to be the interior -region of a YAML metadata block as propertized by -`markdown-syntax-propertize-fenced-block-constructs'." - (save-excursion - (goto-char start) - (cl-loop - while (re-search-forward markdown-regex-declarative-metadata end t) - do (progn - (put-text-property (match-beginning 1) (match-end 1) - 'markdown-metadata-key (match-data t)) - (put-text-property (match-beginning 2) (match-end 2) - 'markdown-metadata-markup (match-data t)) - (put-text-property (match-beginning 3) (match-end 3) - 'markdown-metadata-value (match-data t)))))) - -(defun markdown-syntax-propertize-headings (start end) - "Match headings of type SYMBOL with REGEX from START to END." - (goto-char start) - (while (re-search-forward markdown-regex-header end t) - (unless (markdown-code-block-at-pos (match-beginning 0)) - (put-text-property - (match-beginning 0) (match-end 0) 'markdown-heading - (match-data t)) - (put-text-property - (match-beginning 0) (match-end 0) - (cond ((match-string-no-properties 2) 'markdown-heading-1-setext) - ((match-string-no-properties 3) 'markdown-heading-2-setext) - (t (let ((atx-level (length (markdown-trim-whitespace - (match-string-no-properties 4))))) - (intern (format "markdown-heading-%d-atx" atx-level))))) - (match-data t))))) - -(defun markdown-syntax-propertize-comments (start end) - "Match HTML comments from the START to END." - ;; Implement by loop instead of recursive call for avoiding - ;; exceed max-lisp-eval-depth issue - ;; https://github.com/jrblevin/markdown-mode/issues/536 - (let (finish) - (goto-char start) - (while (not finish) - (let* ((in-comment (nth 4 (syntax-ppss))) - (comment-begin (nth 8 (syntax-ppss)))) - (cond - ;; Comment start - ((and (not in-comment) - (re-search-forward markdown-regex-comment-start end t) - (not (markdown-inline-code-at-point-p)) - (not (markdown-code-block-at-point-p))) - (let ((open-beg (match-beginning 0))) - (put-text-property open-beg (1+ open-beg) - 'syntax-table (string-to-syntax "<")) - (goto-char (min (1+ (match-end 0)) end (point-max))))) - ;; Comment end - ((and in-comment comment-begin - (re-search-forward markdown-regex-comment-end end t)) - (let ((comment-end (match-end 0))) - (put-text-property (1- comment-end) comment-end - 'syntax-table (string-to-syntax ">")) - ;; Remove any other text properties inside the comment - (remove-text-properties comment-begin comment-end - markdown--syntax-properties) - (put-text-property comment-begin comment-end - 'markdown-comment (list comment-begin comment-end)) - (goto-char (min comment-end end (point-max))))) - ;; Nothing found - (t (setq finish t))))) - nil)) - -(defun markdown-syntax-propertize (start end) - "Function used as `syntax-propertize-function'. -START and END delimit region to propertize." - (with-silent-modifications - (save-excursion - (remove-text-properties start end markdown--syntax-properties) - (markdown-syntax-propertize-fenced-block-constructs start end) - (markdown-syntax-propertize-list-items start end) - (markdown-syntax-propertize-pre-blocks start end) - (markdown-syntax-propertize-blockquotes start end) - (markdown-syntax-propertize-headings start end) - (markdown-syntax-propertize-hrs start end) - (markdown-syntax-propertize-comments start end)))) - - -;;; Markup Hiding ============================================================= - -(defconst markdown-markup-properties - '(face markdown-markup-face invisible markdown-markup) - "List of properties and values to apply to markup.") - -(defconst markdown-line-break-properties - '(face markdown-line-break-face invisible markdown-markup) - "List of properties and values to apply to line break markup.") - -(defconst markdown-language-keyword-properties - '(face markdown-language-keyword-face invisible markdown-markup) - "List of properties and values to apply to code block language names.") - -(defconst markdown-language-info-properties - '(face markdown-language-info-face invisible markdown-markup) - "List of properties and values to apply to code block language info strings.") - -(defconst markdown-include-title-properties - '(face markdown-link-title-face invisible markdown-markup) - "List of properties and values to apply to included code titles.") - -(defcustom markdown-hide-markup nil - "Determines whether markup in the buffer will be hidden. -When set to nil, all markup is displayed in the buffer as it -appears in the file. An exception is when `markdown-hide-urls' -is non-nil. -Set this to a non-nil value to turn this feature on by default. -You can interactively toggle the value of this variable with -`markdown-toggle-markup-hiding', \\[markdown-toggle-markup-hiding], -or from the Markdown > Show & Hide menu. - -Markup hiding works by adding text properties to positions in the -buffer---either the `invisible' property or the `display' property -in cases where alternative glyphs are used (e.g., list bullets). -This does not, however, affect printing or other output. -Functions such as `htmlfontify-buffer' and `ps-print-buffer' will -not honor these text properties. For printing, it would be better -to first convert to HTML or PDF (e.g,. using Pandoc)." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.3")) -(make-variable-buffer-local 'markdown-hide-markup) - -(defun markdown-toggle-markup-hiding (&optional arg) - "Toggle the display or hiding of markup. -With a prefix argument ARG, enable markup hiding if ARG is positive, -and disable it otherwise. -See `markdown-hide-markup' for additional details." - (interactive (list (or current-prefix-arg 'toggle))) - (setq markdown-hide-markup - (if (eq arg 'toggle) - (not markdown-hide-markup) - (> (prefix-numeric-value arg) 0))) - (if markdown-hide-markup - (add-to-invisibility-spec 'markdown-markup) - (remove-from-invisibility-spec 'markdown-markup)) - (when (called-interactively-p 'interactive) - (message "markdown-mode markup hiding %s" (if markdown-hide-markup "enabled" "disabled"))) - (markdown-reload-extensions)) - - -;;; Font Lock ================================================================= - -(require 'font-lock) - -(defgroup markdown-faces nil - "Faces used in Markdown Mode." - :group 'markdown - :group 'faces) - -(defface markdown-italic-face - '((t (:inherit italic))) - "Face for italic text." - :group 'markdown-faces) - -(defface markdown-bold-face - '((t (:inherit bold))) - "Face for bold text." - :group 'markdown-faces) - -(defface markdown-strike-through-face - '((t (:strike-through t))) - "Face for strike-through text." - :group 'markdown-faces) - -(defface markdown-markup-face - '((t (:inherit shadow :slant normal :weight normal))) - "Face for markup elements." - :group 'markdown-faces) - -(defface markdown-header-rule-face - '((t (:inherit markdown-markup-face))) - "Base face for headers rules." - :group 'markdown-faces) - -(defface markdown-header-delimiter-face - '((t (:inherit markdown-markup-face))) - "Base face for headers hash delimiter." - :group 'markdown-faces) - -(defface markdown-list-face - '((t (:inherit markdown-markup-face))) - "Face for list item markers." - :group 'markdown-faces) - -(defface markdown-blockquote-face - '((t (:inherit font-lock-doc-face))) - "Face for blockquote sections." - :group 'markdown-faces) - -(defface markdown-code-face - '((t (:inherit fixed-pitch))) - "Face for inline code, pre blocks, and fenced code blocks. -This may be used, for example, to add a contrasting background to -inline code fragments and code blocks." - :group 'markdown-faces) - -(defface markdown-inline-code-face - '((t (:inherit (markdown-code-face font-lock-constant-face)))) - "Face for inline code." - :group 'markdown-faces) - -(defface markdown-pre-face - '((t (:inherit (markdown-code-face font-lock-constant-face)))) - "Face for preformatted text." - :group 'markdown-faces) - -(defface markdown-table-face - '((t (:inherit (markdown-code-face)))) - "Face for tables." - :group 'markdown-faces) - -(defface markdown-language-keyword-face - '((t (:inherit font-lock-type-face))) - "Face for programming language identifiers." - :group 'markdown-faces) - -(defface markdown-language-info-face - '((t (:inherit font-lock-string-face))) - "Face for programming language info strings." - :group 'markdown-faces) - -(defface markdown-link-face - '((t (:inherit link))) - "Face for links." - :group 'markdown-faces) - -(defface markdown-missing-link-face - '((t (:inherit font-lock-warning-face))) - "Face for missing links." - :group 'markdown-faces) - -(defface markdown-reference-face - '((t (:inherit markdown-markup-face))) - "Face for link references." - :group 'markdown-faces) - -(defface markdown-footnote-marker-face - '((t (:inherit markdown-markup-face))) - "Face for footnote markers." - :group 'markdown-faces) - -(defface markdown-footnote-text-face - '((t (:inherit font-lock-comment-face))) - "Face for footnote text." - :group 'markdown-faces) - -(defface markdown-url-face - '((t (:inherit font-lock-string-face))) - "Face for URLs that are part of markup. -For example, this applies to URLs in inline links: -[link text](http://example.com/)." - :group 'markdown-faces) - -(defface markdown-plain-url-face - '((t (:inherit markdown-link-face))) - "Face for URLs that are also links. -For example, this applies to plain angle bracket URLs: -<http://example.com/>." - :group 'markdown-faces) - -(defface markdown-link-title-face - '((t (:inherit font-lock-comment-face))) - "Face for reference link titles." - :group 'markdown-faces) - -(defface markdown-line-break-face - '((t (:inherit font-lock-constant-face :underline t))) - "Face for hard line breaks." - :group 'markdown-faces) - -(defface markdown-comment-face - '((t (:inherit font-lock-comment-face))) - "Face for HTML comments." - :group 'markdown-faces) - -(defface markdown-math-face - '((t (:inherit font-lock-string-face))) - "Face for LaTeX expressions." - :group 'markdown-faces) - -(defface markdown-metadata-key-face - '((t (:inherit font-lock-variable-name-face))) - "Face for metadata keys." - :group 'markdown-faces) - -(defface markdown-metadata-value-face - '((t (:inherit font-lock-string-face))) - "Face for metadata values." - :group 'markdown-faces) - -(defface markdown-gfm-checkbox-face - '((t (:inherit font-lock-builtin-face))) - "Face for GFM checkboxes." - :group 'markdown-faces) - -(defface markdown-highlight-face - '((t (:inherit highlight))) - "Face for mouse highlighting." - :group 'markdown-faces) - -(defface markdown-hr-face - '((t (:inherit markdown-markup-face))) - "Face for horizontal rules." - :group 'markdown-faces) - -(defface markdown-html-tag-name-face - '((t (:inherit font-lock-type-face))) - "Face for HTML tag names." - :group 'markdown-faces) - -(defface markdown-html-tag-delimiter-face - '((t (:inherit markdown-markup-face))) - "Face for HTML tag delimiters." - :group 'markdown-faces) - -(defface markdown-html-attr-name-face - '((t (:inherit font-lock-variable-name-face))) - "Face for HTML attribute names." - :group 'markdown-faces) - -(defface markdown-html-attr-value-face - '((t (:inherit font-lock-string-face))) - "Face for HTML attribute values." - :group 'markdown-faces) - -(defface markdown-html-entity-face - '((t (:inherit font-lock-variable-name-face))) - "Face for HTML entities." - :group 'markdown-faces) - -(defface markdown-highlighting-face - '((t (:background "yellow" :foreground "black"))) - "Face for highlighting." - :group 'markdown-faces) - -(defcustom markdown-header-scaling nil - "Whether to use variable-height faces for headers. -When non-nil, `markdown-header-face' will inherit from -`variable-pitch' and the scaling values in -`markdown-header-scaling-values' will be applied to -headers of levels one through six respectively." - :type 'boolean - :initialize #'custom-initialize-default - :set (lambda (symbol value) - (set-default symbol value) - (markdown-update-header-faces value)) - :group 'markdown-faces - :package-version '(markdown-mode . "2.2")) - -(defcustom markdown-header-scaling-values - '(2.0 1.7 1.4 1.1 1.0 1.0) - "List of scaling values for headers of level one through six. -Used when `markdown-header-scaling' is non-nil." - :type '(repeat float) - :initialize #'custom-initialize-default - :set (lambda (symbol value) - (set-default symbol value) - (markdown-update-header-faces markdown-header-scaling value))) - -(defmacro markdown--dotimes-when-compile (i-n body) - (declare (indent 1) (debug ((symbolp form) form))) - (let ((var (car i-n)) - (n (cadr i-n)) - (code ())) - (dotimes (i (eval n t)) - (push (eval body `((,var . ,i))) code)) - `(progn ,@(nreverse code)))) - -(defface markdown-header-face - `((t (:inherit (,@(when markdown-header-scaling '(variable-pitch)) - font-lock-function-name-face) - :weight bold))) - "Base face for headers.") - -(markdown--dotimes-when-compile (num 6) - (let* ((num1 (1+ num)) - (face-name (intern (format "markdown-header-face-%s" num1)))) - `(defface ,face-name - (,'\` ((t (:inherit markdown-header-face - :height - (,'\, (if markdown-header-scaling - (float (nth ,num markdown-header-scaling-values)) - 1.0)))))) - (format "Face for level %s headers. -You probably don't want to customize this face directly. Instead -you can customize the base face `markdown-header-face' or the -variable-height variable `markdown-header-scaling'." ,num1)))) - -(defun markdown-update-header-faces (&optional scaling scaling-values) - "Update header faces, depending on if header SCALING is desired. -If so, use given list of SCALING-VALUES relative to the baseline -size of `markdown-header-face'." - (dotimes (num 6) - (let* ((face-name (intern (format "markdown-header-face-%s" (1+ num)))) - (scale (cond ((not scaling) 1.0) - (scaling-values (float (nth num scaling-values))) - (t (float (nth num markdown-header-scaling-values)))))) - (unless (get face-name 'saved-face) ; Don't update customized faces - (set-face-attribute face-name nil :height scale))))) - -(defun markdown-syntactic-face (state) - "Return font-lock face for characters with given STATE. -See `font-lock-syntactic-face-function' for details." - (let ((in-comment (nth 4 state))) - (cond - (in-comment 'markdown-comment-face) - (t nil)))) - -(defcustom markdown-list-item-bullets - '("●" "◎" "○" "◆" "◇" "►" "•") - "List of bullets to use for unordered lists. -It can contain any number of symbols, which will be repeated. -Depending on your font, some reasonable choices are: -♥ ● ◇ ✚ ✜ ☯ ◆ ♠ ♣ ♦ ❀ ◆ ◖ ▶ ► • ★ ▸." - :group 'markdown - :type '(repeat (string :tag "Bullet character")) - :package-version '(markdown-mode . "2.3")) - -(defun markdown--footnote-marker-properties () - "Return a font-lock facespec expression for footnote marker text." - `(face markdown-footnote-marker-face - ,@(when markdown-hide-markup - `(display ,markdown-footnote-display)))) - -(defun markdown--pandoc-inline-footnote-properties () - "Return a font-lock facespec expression for Pandoc inline footnote text." - `(face markdown-footnote-text-face - ,@(when markdown-hide-markup - `(display ,markdown-footnote-display)))) - -(defvar markdown-mode-font-lock-keywords - `((markdown-match-yaml-metadata-begin . ((1 'markdown-markup-face))) - (markdown-match-yaml-metadata-end . ((1 'markdown-markup-face))) - (markdown-match-yaml-metadata-key . ((1 'markdown-metadata-key-face) - (2 'markdown-markup-face) - (3 'markdown-metadata-value-face))) - (markdown-match-gfm-open-code-blocks . ((1 markdown-markup-properties) - (2 markdown-markup-properties nil t) - (3 markdown-language-keyword-properties nil t) - (4 markdown-language-info-properties nil t) - (5 markdown-markup-properties nil t))) - (markdown-match-gfm-close-code-blocks . ((0 markdown-markup-properties))) - (markdown-fontify-gfm-code-blocks) - (markdown-fontify-tables) - (markdown-match-fenced-start-code-block . ((1 markdown-markup-properties) - (2 markdown-markup-properties nil t) - (3 markdown-language-keyword-properties nil t) - (4 markdown-language-info-properties nil t) - (5 markdown-markup-properties nil t))) - (markdown-match-fenced-end-code-block . ((0 markdown-markup-properties))) - (markdown-fontify-fenced-code-blocks) - (markdown-match-pre-blocks . ((0 'markdown-pre-face))) - (markdown-fontify-headings) - (markdown-match-declarative-metadata . ((1 'markdown-metadata-key-face) - (2 'markdown-markup-face) - (3 'markdown-metadata-value-face))) - (markdown-match-pandoc-metadata . ((1 'markdown-markup-face) - (2 'markdown-markup-face) - (3 'markdown-metadata-value-face))) - (markdown-fontify-hrs) - (markdown-match-code . ((1 markdown-markup-properties prepend) - (2 'markdown-inline-code-face prepend) - (3 markdown-markup-properties prepend))) - (,markdown-regex-kbd . ((1 markdown-markup-properties) - (2 'markdown-inline-code-face) - (3 markdown-markup-properties))) - (markdown-fontify-angle-uris) - (,markdown-regex-email . 'markdown-plain-url-face) - (markdown-match-html-tag . ((1 'markdown-html-tag-delimiter-face t) - (2 'markdown-html-tag-name-face t) - (3 'markdown-html-tag-delimiter-face t) - ;; Anchored matcher for HTML tag attributes - (,markdown-regex-html-attr - ;; Before searching, move past tag - ;; name; set limit at tag close. - (progn - (goto-char (match-end 2)) (match-end 3)) - nil - . ((1 'markdown-html-attr-name-face) - (3 'markdown-html-tag-delimiter-face nil t) - (4 'markdown-html-attr-value-face nil t))))) - (,markdown-regex-html-entity . 'markdown-html-entity-face) - (markdown-fontify-list-items) - (,markdown-regex-footnote . ((1 markdown-markup-properties) ; [^ - (2 (markdown--footnote-marker-properties)) ; label - (3 markdown-markup-properties))) ; ] - (,markdown-regex-pandoc-inline-footnote . ((1 markdown-markup-properties) ; ^ - (2 markdown-markup-properties) ; [ - (3 (markdown--pandoc-inline-footnote-properties)) ; text - (4 markdown-markup-properties))) ; ] - (markdown-match-includes . ((1 markdown-markup-properties) - (2 markdown-markup-properties nil t) - (3 markdown-include-title-properties nil t) - (4 markdown-markup-properties nil t) - (5 markdown-markup-properties) - (6 'markdown-url-face) - (7 markdown-markup-properties))) - (markdown-fontify-inline-links) - (markdown-fontify-reference-links) - (,markdown-regex-reference-definition . ((1 'markdown-markup-face) ; [ - (2 'markdown-reference-face) ; label - (3 'markdown-markup-face) ; ] - (4 'markdown-markup-face) ; : - (5 'markdown-url-face) ; url - (6 'markdown-link-title-face))) ; "title" (optional) - (markdown-fontify-plain-uris) - ;; Math mode $..$ - (markdown-match-math-single . ((1 'markdown-markup-face prepend) - (2 'markdown-math-face append) - (3 'markdown-markup-face prepend))) - ;; Math mode $$..$$ - (markdown-match-math-double . ((1 'markdown-markup-face prepend) - (2 'markdown-math-face append) - (3 'markdown-markup-face prepend))) - ;; Math mode \[..\] and \\[..\\] - (markdown-match-math-display . ((1 'markdown-markup-face prepend) - (3 'markdown-math-face append) - (4 'markdown-markup-face prepend))) - (markdown-match-bold . ((1 markdown-markup-properties prepend) - (2 'markdown-bold-face append) - (3 markdown-markup-properties prepend))) - (markdown-match-italic . ((1 markdown-markup-properties prepend) - (2 'markdown-italic-face append) - (3 markdown-markup-properties prepend))) - (,markdown-regex-strike-through . ((3 markdown-markup-properties) - (4 'markdown-strike-through-face) - (5 markdown-markup-properties))) - (markdown--match-highlighting . ((3 markdown-markup-properties) - (4 'markdown-highlighting-face) - (5 markdown-markup-properties))) - (,markdown-regex-line-break . (1 markdown-line-break-properties prepend)) - (markdown-match-escape . ((1 markdown-markup-properties prepend))) - (markdown-fontify-sub-superscripts) - (markdown-match-inline-attributes . ((0 markdown-markup-properties prepend))) - (markdown-match-leanpub-sections . ((0 markdown-markup-properties))) - (markdown-fontify-blockquotes) - (markdown-match-wiki-link . ((0 'markdown-link-face prepend)))) - "Syntax highlighting for Markdown files.") - -;; Footnotes -(defvar-local markdown-footnote-counter 0 - "Counter for footnote numbers.") - -(defconst markdown-footnote-chars - "[[:alnum:]-]" - "Regular expression matching any character for a footnote identifier.") - -(defconst markdown-regex-footnote-definition - (concat "^ \\{0,3\\}\\[\\(\\^" markdown-footnote-chars "*?\\)\\]:\\(?:[ \t]+\\|$\\)") - "Regular expression matching a footnote definition, capturing the label.") - - -;;; Compatibility ============================================================= - -(defun markdown--pandoc-reference-p () - (let ((bounds (bounds-of-thing-at-point 'word))) - (when (and bounds (char-before (car bounds))) - (= (char-before (car bounds)) ?@)))) - -(defun markdown-flyspell-check-word-p () - "Return t if `flyspell' should check word just before point. -Used for `flyspell-generic-check-word-predicate'." - (save-excursion - (goto-char (1- (point))) - ;; https://github.com/jrblevin/markdown-mode/issues/560 - ;; enable spell check YAML meta data - (if (or (and (markdown-code-block-at-point-p) - (not (markdown-text-property-at-point 'markdown-yaml-metadata-section))) - (markdown-inline-code-at-point-p) - (markdown-in-comment-p) - (markdown--face-p (point) '(markdown-reference-face - markdown-markup-face - markdown-plain-url-face - markdown-inline-code-face - markdown-url-face)) - (markdown--pandoc-reference-p)) - (prog1 nil - ;; If flyspell overlay is put, then remove it - (let ((bounds (bounds-of-thing-at-point 'word))) - (when bounds - (cl-loop for ov in (overlays-in (car bounds) (cdr bounds)) - when (overlay-get ov 'flyspell-overlay) - do - (delete-overlay ov))))) - t))) - - -;;; Markdown Parsing Functions ================================================ - -(defun markdown-cur-line-blank-p () - "Return t if the current line is blank and nil otherwise." - (save-excursion - (beginning-of-line) - (looking-at-p markdown-regex-blank-line))) - -(defun markdown-prev-line-blank () - "Return t if the previous line is blank and nil otherwise. -If we are at the first line, then consider the previous line to be blank." - (or (= (line-beginning-position) (point-min)) - (save-excursion - (forward-line -1) - (looking-at markdown-regex-blank-line)))) - -(defun markdown-prev-line-blank-p () - "Like `markdown-prev-line-blank', but preserve `match-data'." - (save-match-data (markdown-prev-line-blank))) - -(defun markdown-next-line-blank-p () - "Return t if the next line is blank and nil otherwise. -If we are at the last line, then consider the next line to be blank." - (or (= (line-end-position) (point-max)) - (save-excursion - (forward-line 1) - (markdown-cur-line-blank-p)))) - -(defun markdown-prev-line-indent () - "Return the number of leading whitespace characters in the previous line. -Return 0 if the current line is the first line in the buffer." - (save-excursion - (if (= (line-beginning-position) (point-min)) - 0 - (forward-line -1) - (current-indentation)))) - -(defun markdown-next-line-indent () - "Return the number of leading whitespace characters in the next line. -Return 0 if line is the last line in the buffer." - (save-excursion - (if (= (line-end-position) (point-max)) - 0 - (forward-line 1) - (current-indentation)))) - -(defun markdown-new-baseline () - "Determine if the current line begins a new baseline level. -Assume point is positioned at beginning of line." - (or (looking-at markdown-regex-header) - (looking-at markdown-regex-hr) - (and (= (current-indentation) 0) - (not (looking-at markdown-regex-list)) - (markdown-prev-line-blank)))) - -(defun markdown-search-backward-baseline () - "Search backward baseline point with no indentation and not a list item." - (end-of-line) - (let (stop) - (while (not (or stop (bobp))) - (re-search-backward markdown-regex-block-separator-noindent nil t) - (when (match-end 2) - (goto-char (match-end 2)) - (cond - ((markdown-new-baseline) - (setq stop t)) - ((looking-at-p markdown-regex-list) - (setq stop nil)) - (t (setq stop t))))))) - -(defun markdown-update-list-levels (marker indent levels) - "Update list levels given list MARKER, block INDENT, and current LEVELS. -Here, MARKER is a string representing the type of list, INDENT is an integer -giving the indentation, in spaces, of the current block, and LEVELS is a -list of the indentation levels of parent list items. When LEVELS is nil, -it means we are at baseline (not inside of a nested list)." - (cond - ;; New list item at baseline. - ((and marker (null levels)) - (setq levels (list indent))) - ;; List item with greater indentation (four or more spaces). - ;; Increase list level. - ((and marker (>= indent (+ (car levels) markdown-list-indent-width))) - (setq levels (cons indent levels))) - ;; List item with greater or equal indentation (less than four spaces). - ;; Do not increase list level. - ((and marker (>= indent (car levels))) - levels) - ;; Lesser indentation level. - ;; Pop appropriate number of elements off LEVELS list (e.g., lesser - ;; indentation could move back more than one list level). Note - ;; that this block need not be the beginning of list item. - ((< indent (car levels)) - (while (and (> (length levels) 1) - (< indent (+ (cadr levels) markdown-list-indent-width))) - (setq levels (cdr levels))) - levels) - ;; Otherwise, do nothing. - (t levels))) - -(defun markdown-calculate-list-levels () - "Calculate list levels at point. -Return a list of the form (n1 n2 n3 ...) where n1 is the -indentation of the deepest nested list item in the branch of -the list at the point, n2 is the indentation of the parent -list item, and so on. The depth of the list item is therefore -the length of the returned list. If the point is not at or -immediately after a list item, return nil." - (save-excursion - (let ((first (point)) levels indent pre-regexp) - ;; Find a baseline point with zero list indentation - (markdown-search-backward-baseline) - ;; Search for all list items between baseline and LOC - (while (and (< (point) first) - (re-search-forward markdown-regex-list first t)) - (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" (1+ (length levels)))) - (beginning-of-line) - (cond - ;; Make sure this is not a header or hr - ((markdown-new-baseline) (setq levels nil)) - ;; Make sure this is not a line from a pre block - ((looking-at-p pre-regexp)) - ;; If not, then update levels - (t - (setq indent (current-indentation)) - (setq levels (markdown-update-list-levels (match-string 2) - indent levels)))) - (end-of-line)) - levels))) - -(defun markdown-prev-list-item (level) - "Search backward from point for a list item with indentation LEVEL. -Set point to the beginning of the item, and return point, or nil -upon failure." - (let (bounds indent prev) - (setq prev (point)) - (forward-line -1) - (setq indent (current-indentation)) - (while - (cond - ;; List item - ((and (looking-at-p markdown-regex-list) - (setq bounds (markdown-cur-list-item-bounds))) - (cond - ;; Stop and return point at item of equal indentation - ((= (nth 3 bounds) level) - (setq prev (point)) - nil) - ;; Stop and return nil at item with lesser indentation - ((< (nth 3 bounds) level) - (setq prev nil) - nil) - ;; Stop at beginning of buffer - ((bobp) (setq prev nil)) - ;; Continue at item with greater indentation - ((> (nth 3 bounds) level) t))) - ;; Stop at beginning of buffer - ((bobp) (setq prev nil)) - ;; Continue if current line is blank - ((markdown-cur-line-blank-p) t) - ;; Continue while indentation is the same or greater - ((>= indent level) t) - ;; Stop if current indentation is less than list item - ;; and the next is blank - ((and (< indent level) - (markdown-next-line-blank-p)) - (setq prev nil)) - ;; Stop at a header - ((looking-at-p markdown-regex-header) (setq prev nil)) - ;; Stop at a horizontal rule - ((looking-at-p markdown-regex-hr) (setq prev nil)) - ;; Otherwise, continue. - (t t)) - (forward-line -1) - (setq indent (current-indentation))) - prev)) - -(defun markdown-next-list-item (level) - "Search forward from point for the next list item with indentation LEVEL. -Set point to the beginning of the item, and return point, or nil -upon failure." - (let (bounds indent next) - (setq next (point)) - (if (looking-at markdown-regex-header-setext) - (goto-char (match-end 0))) - (forward-line) - (setq indent (current-indentation)) - (while - (cond - ;; Stop at end of the buffer. - ((eobp) nil) - ;; Continue if the current line is blank - ((markdown-cur-line-blank-p) t) - ;; List item - ((and (looking-at-p markdown-regex-list) - (setq bounds (markdown-cur-list-item-bounds))) - (cond - ;; Continue at item with greater indentation - ((> (nth 3 bounds) level) t) - ;; Stop and return point at item of equal indentation - ((= (nth 3 bounds) level) - (setq next (point)) - nil) - ;; Stop and return nil at item with lesser indentation - ((< (nth 3 bounds) level) - (setq next nil) - nil))) - ;; Continue while indentation is the same or greater - ((>= indent level) t) - ;; Stop if current indentation is less than list item - ;; and the previous line was blank. - ((and (< indent level) - (markdown-prev-line-blank-p)) - (setq next nil)) - ;; Stop at a header - ((looking-at-p markdown-regex-header) (setq next nil)) - ;; Stop at a horizontal rule - ((looking-at-p markdown-regex-hr) (setq next nil)) - ;; Otherwise, continue. - (t t)) - (forward-line) - (setq indent (current-indentation))) - next)) - -(defun markdown-cur-list-item-end (level) - "Move to end of list item with pre-marker indentation LEVEL. -Return the point at the end when a list item was found at the -original point. If the point is not in a list item, do nothing." - (let (indent) - (forward-line) - (setq indent (current-indentation)) - (while - (cond - ;; Stop at end of the buffer. - ((eobp) nil) - ;; Continue while indentation is the same or greater - ((>= indent level) t) - ;; Continue if the current line is blank - ((looking-at markdown-regex-blank-line) t) - ;; Stop if current indentation is less than list item - ;; and the previous line was blank. - ((and (< indent level) - (markdown-prev-line-blank)) - nil) - ;; Stop at a new list items of the same or lesser - ;; indentation, headings, and horizontal rules. - ((looking-at (concat "\\(?:" markdown-regex-list - "\\|" markdown-regex-header - "\\|" markdown-regex-hr "\\)")) - nil) - ;; Otherwise, continue. - (t t)) - (forward-line) - (setq indent (current-indentation))) - ;; Don't skip over whitespace for empty list items (marker and - ;; whitespace only), just move to end of whitespace. - (if (save-excursion - (beginning-of-line) - (looking-at (concat markdown-regex-list "[ \t]*$"))) - (goto-char (match-end 3)) - (skip-chars-backward " \t\n")) - (end-of-line) - (point))) - -(defun markdown-cur-list-item-bounds () - "Return bounds for list item at point. -Return a list of the following form: - - (begin end indent nonlist-indent marker checkbox match) - -The named components are: - - - begin: Position of beginning of list item, including leading indentation. - - end: Position of the end of the list item, including list item text. - - indent: Number of characters of indentation before list marker (an integer). - - nonlist-indent: Number characters of indentation, list - marker, and whitespace following list marker (an integer). - - marker: String containing the list marker and following whitespace - (e.g., \"- \" or \"* \"). - - checkbox: String containing the GFM checkbox portion, if any, - including any trailing whitespace before the text - begins (e.g., \"[x] \"). - - match: match data for markdown-regex-list - -As an example, for the following unordered list item - - - item - -the returned list would be - - (1 14 3 5 \"- \" nil (1 6 1 4 4 5 5 6)) - -If the point is not inside a list item, return nil." - (car (get-text-property (line-beginning-position) 'markdown-list-item))) - -(defun markdown-list-item-at-point-p () - "Return t if there is a list item at the point and nil otherwise." - (save-match-data (markdown-cur-list-item-bounds))) - -(defun markdown-prev-list-item-bounds () - "Return bounds of previous item in the same list of any level. -The return value has the same form as that of -`markdown-cur-list-item-bounds'." - (save-excursion - (let ((cur-bounds (markdown-cur-list-item-bounds)) - (beginning-of-list (save-excursion (markdown-beginning-of-list))) - stop) - (when cur-bounds - (goto-char (nth 0 cur-bounds)) - (while (and (not stop) (not (bobp)) - (re-search-backward markdown-regex-list - beginning-of-list t)) - (unless (or (looking-at markdown-regex-hr) - (markdown-code-block-at-point-p)) - (setq stop (point)))) - (markdown-cur-list-item-bounds))))) - -(defun markdown-next-list-item-bounds () - "Return bounds of next item in the same list of any level. -The return value has the same form as that of -`markdown-cur-list-item-bounds'." - (save-excursion - (let ((cur-bounds (markdown-cur-list-item-bounds)) - (end-of-list (save-excursion (markdown-end-of-list))) - stop) - (when cur-bounds - (goto-char (nth 0 cur-bounds)) - (end-of-line) - (while (and (not stop) (not (eobp)) - (re-search-forward markdown-regex-list - end-of-list t)) - (unless (or (looking-at markdown-regex-hr) - (markdown-code-block-at-point-p)) - (setq stop (point)))) - (when stop - (markdown-cur-list-item-bounds)))))) - -(defun markdown-beginning-of-list () - "Move point to beginning of list at point, if any." - (interactive) - (let ((orig-point (point)) - (list-begin (save-excursion - (markdown-search-backward-baseline) - ;; Stop at next list item, regardless of the indentation. - (markdown-next-list-item (point-max)) - (when (looking-at markdown-regex-list) - (point))))) - (when (and list-begin (<= list-begin orig-point)) - (goto-char list-begin)))) - -(defun markdown-end-of-list () - "Move point to end of list at point, if any." - (interactive) - (let ((start (point)) - (end (save-excursion - (when (markdown-beginning-of-list) - ;; Items can't have nonlist-indent <= 1, so this - ;; moves past all list items. - (markdown-next-list-item 1) - (skip-syntax-backward "-") - (unless (eobp) (forward-char 1)) - (point))))) - (when (and end (>= end start)) - (goto-char end)))) - -(defun markdown-up-list () - "Move point to beginning of parent list item." - (interactive) - (let ((cur-bounds (markdown-cur-list-item-bounds))) - (when cur-bounds - (markdown-prev-list-item (1- (nth 3 cur-bounds))) - (let ((up-bounds (markdown-cur-list-item-bounds))) - (when (and up-bounds (< (nth 3 up-bounds) (nth 3 cur-bounds))) - (point)))))) - -(defun markdown-bounds-of-thing-at-point (thing) - "Call `bounds-of-thing-at-point' for THING with slight modifications. -Does not include trailing newlines when THING is \\='line. Handles the -end of buffer case by setting both endpoints equal to the value of -`point-max', since an empty region will trigger empty markup insertion. -Return bounds of form (beg . end) if THING is found, or nil otherwise." - (let* ((bounds (bounds-of-thing-at-point thing)) - (a (car bounds)) - (b (cdr bounds))) - (when bounds - (when (eq thing 'line) - (cond ((and (eobp) (markdown-cur-line-blank-p)) - (setq a b)) - ((char-equal (char-before b) ?\^J) - (setq b (1- b))))) - (cons a b)))) - -(defun markdown-reference-definition (reference) - "Find out whether Markdown REFERENCE is defined. -REFERENCE should not include the square brackets. -When REFERENCE is defined, return a list of the form (text start end) -containing the definition text itself followed by the start and end -locations of the text. Otherwise, return nil. -Leave match data for `markdown-regex-reference-definition' -intact additional processing." - (let ((reference (downcase reference))) - (save-excursion - (goto-char (point-min)) - (catch 'found - (while (re-search-forward markdown-regex-reference-definition nil t) - (when (string= reference (downcase (match-string-no-properties 2))) - (throw 'found - (list (match-string-no-properties 5) - (match-beginning 5) (match-end 5))))))))) - -(defun markdown-get-defined-references () - "Return all defined reference labels and their line numbers. -They does not include square brackets)." - (save-excursion - (goto-char (point-min)) - (let (refs) - (while (re-search-forward markdown-regex-reference-definition nil t) - (let ((target (match-string-no-properties 2))) - (cl-pushnew - (cons (downcase target) - (markdown-line-number-at-pos (match-beginning 2))) - refs :test #'equal :key #'car))) - (reverse refs)))) - -(defun markdown-get-used-uris () - "Return a list of all used URIs in the buffer." - (save-excursion - (goto-char (point-min)) - (let (uris) - (while (re-search-forward - (concat "\\(?:" markdown-regex-link-inline - "\\|" markdown-regex-angle-uri - "\\|" markdown-regex-uri - "\\|" markdown-regex-email - "\\)") - nil t) - (unless (or (markdown-inline-code-at-point-p) - (markdown-code-block-at-point-p)) - (cl-pushnew (or (match-string-no-properties 6) - (match-string-no-properties 10) - (match-string-no-properties 12) - (match-string-no-properties 13)) - uris :test #'equal))) - (reverse uris)))) - -(defun markdown-inline-code-at-pos (pos &optional from) - "Return non-nil if there is an inline code fragment at POS starting at FROM. -Uses the beginning of the block if FROM is nil. -Return nil otherwise. Set match data according to -`markdown-match-code' upon success. -This function searches the block for a code fragment that -contains the point using `markdown-match-code'. We do this -because `thing-at-point-looking-at' does not work reliably with -`markdown-regex-code'. - -The match data is set as follows: -Group 1 matches the opening backquotes. -Group 2 matches the code fragment itself, without backquotes. -Group 3 matches the closing backquotes." - (save-excursion - (goto-char pos) - (let ((old-point (point)) - (end-of-block (progn (markdown-end-of-text-block) (point))) - found) - (if from - (goto-char from) - (markdown-beginning-of-text-block)) - (while (and (markdown-match-code end-of-block) - (setq found t) - (< (match-end 0) old-point))) - (let ((match-group (if (eq (char-after (match-beginning 0)) ?`) 0 1))) - (and found ; matched something - (<= (match-beginning match-group) old-point) ; match contains old-point - (> (match-end 0) old-point)))))) - -(defun markdown-inline-code-at-pos-p (pos) - "Return non-nil if there is an inline code fragment at POS. -Like `markdown-inline-code-at-pos`, but preserves match data." - (save-match-data (markdown-inline-code-at-pos pos))) - -(defun markdown-inline-code-at-point () - "Return non-nil if the point is at an inline code fragment. -See `markdown-inline-code-at-pos' for details." - (markdown-inline-code-at-pos (point))) - -(defun markdown-inline-code-at-point-p (&optional pos) - "Return non-nil if there is inline code at the POS. -This is a predicate function counterpart to -`markdown-inline-code-at-point' which does not modify the match -data. See `markdown-code-block-at-point-p' for code blocks." - (save-match-data (markdown-inline-code-at-pos (or pos (point))))) - -(defun markdown-code-block-at-pos (pos) - "Return match data list if there is a code block at POS. -Uses text properties at the beginning of the line position. -This includes pre blocks, tilde-fenced code blocks, and GFM -quoted code blocks. Return nil otherwise." - (let ((bol (save-excursion (goto-char pos) (line-beginning-position)))) - (or (get-text-property bol 'markdown-pre) - (let* ((bounds (markdown-get-enclosing-fenced-block-construct pos)) - (second (cl-second bounds))) - (if second - ;; chunks are right open - (when (< pos second) - bounds) - bounds))))) - -;; Function was renamed to emphasize that it does not modify match-data. -(defalias 'markdown-code-block-at-point 'markdown-code-block-at-point-p) - -(defun markdown-code-block-at-point-p (&optional pos) - "Return non-nil if there is a code block at the POS. -This includes pre blocks, tilde-fenced code blocks, and GFM -quoted code blocks. This function does not modify the match -data. See `markdown-inline-code-at-point-p' for inline code." - (save-match-data (markdown-code-block-at-pos (or pos (point))))) - -(defun markdown-heading-at-point (&optional pos) - "Return non-nil if there is a heading at the POS. -Set match data for `markdown-regex-header'." - (let ((match-data (get-text-property (or pos (point)) 'markdown-heading))) - (when match-data - (set-match-data match-data) - t))) - -(defun markdown-pipe-at-bol-p () - "Return non-nil if the line begins with a pipe symbol. -This may be useful for tables and Pandoc's line_blocks extension." - (char-equal (char-after (line-beginning-position)) ?|)) - - -;;; Markdown Font Lock Matching Functions ===================================== - -(defun markdown-range-property-any (begin end prop prop-values) - "Return t if PROP from BEGIN to END is equal to one of the given PROP-VALUES. -Also returns t if PROP is a list containing one of the PROP-VALUES. -Return nil otherwise." - (let (props) - (catch 'found - (dolist (loc (number-sequence begin end)) - (when (setq props (get-text-property loc prop)) - (cond ((listp props) - ;; props is a list, check for membership - (dolist (val prop-values) - (when (memq val props) (throw 'found loc)))) - (t - ;; props is a scalar, check for equality - (dolist (val prop-values) - (when (eq val props) (throw 'found loc)))))))))) - -(defun markdown-range-properties-exist (begin end props) - (cl-loop - for loc in (number-sequence begin end) - with result = nil - while (not - (setq result - (cl-some (lambda (prop) (get-text-property loc prop)) props))) - finally return result)) - -(defun markdown-match-inline-generic (regex last &optional faceless) - "Match inline REGEX from the point to LAST. -When FACELESS is non-nil, do not return matches where faces have been applied." - (when (re-search-forward regex last t) - (let ((bounds (markdown-code-block-at-pos (match-beginning 1))) - (face (and faceless (text-property-not-all - (match-beginning 0) (match-end 0) 'face nil)))) - (cond - ;; In code block: move past it and recursively search again - (bounds - (when (< (goto-char (cl-second bounds)) last) - (markdown-match-inline-generic regex last faceless))) - ;; When faces are found in the match range, skip over the match and - ;; recursively search again. - (face - (when (< (goto-char (match-end 0)) last) - (markdown-match-inline-generic regex last faceless))) - ;; Keep match data and return t when in bounds. - (t - (<= (match-end 0) last)))))) - -(defun markdown-match-code (last) - "Match inline code fragments from point to LAST." - (unless (bobp) - (backward-char 1)) - (when (markdown-search-until-condition - (lambda () - (and - ;; Advance point in case of failure, but without exceeding last. - (goto-char (min (1+ (match-beginning 1)) last)) - (not (markdown-in-comment-p (match-beginning 1))) - (not (markdown-in-comment-p (match-end 1))) - (not (markdown-code-block-at-pos (match-beginning 1))))) - markdown-regex-code last t) - (set-match-data (list (match-beginning 1) (match-end 1) - (match-beginning 2) (match-end 2) - (match-beginning 3) (match-end 3) - (match-beginning 4) (match-end 4))) - (goto-char (min (1+ (match-end 0)) last (point-max))) - t)) - -(defun markdown--gfm-markup-underscore-p (begin end) - (let ((is-underscore (eql (char-after begin) ?_))) - (if (not is-underscore) - t - (save-excursion - (save-match-data - (goto-char begin) - (and (looking-back "\\(?:^\\|[[:blank:][:punct:]]\\)" (1- begin)) - (progn - (goto-char end) - (looking-at-p "\\(?:[[:blank:][:punct:]]\\|$\\)")))))))) - -(defun markdown-match-bold (last) - "Match inline bold from the point to LAST." - (let (done - retval - last-inline-code) - (while (not done) - (if (markdown-match-inline-generic markdown-regex-bold last) - (let ((is-gfm (derived-mode-p 'gfm-mode)) - (begin (match-beginning 2)) - (end (match-end 2))) - (if (or - (and last-inline-code - (>= begin (car last-inline-code)) - (< begin (cdr last-inline-code))) - (save-match-data - (when (markdown-inline-code-at-pos begin (cdr last-inline-code)) - (setq last-inline-code `(,(match-beginning 0) . ,(match-end 0))))) - (markdown-inline-code-at-pos-p end) - (markdown-in-comment-p) - (markdown-range-property-any - begin begin 'face '(markdown-url-face - markdown-plain-url-face)) - (markdown-range-property-any - begin end 'face '(markdown-hr-face - markdown-math-face)) - (and is-gfm (not (markdown--gfm-markup-underscore-p begin end)))) - (progn (goto-char (min (1+ begin) last)) - (unless (< (point) last) - (setq - done t))) - (set-match-data (list (match-beginning 2) (match-end 2) - (match-beginning 3) (match-end 3) - (match-beginning 4) (match-end 4) - (match-beginning 5) (match-end 5))) - (setq done t - retval t))) - (setq done t))) - retval)) - -(defun markdown-match-italic (last) - "Match inline italics from the point to LAST." - (let* ((is-gfm (derived-mode-p 'gfm-mode)) - (regex (if is-gfm - markdown-regex-gfm-italic - markdown-regex-italic))) - (let (done - retval - last-inline-code) - (while (not done) - (if (and (markdown-match-inline-generic regex last) - (not (markdown--face-p - (match-beginning 1) - '(markdown-html-attr-name-face markdown-html-attr-value-face)))) - (let ((begin (match-beginning 1)) - (end (match-end 1)) - (close-end (match-end 4))) - (if (or (eql (char-before begin) (char-after begin)) - (and last-inline-code - (>= begin (car last-inline-code)) - (< begin (cdr last-inline-code))) - (save-match-data - (when (markdown-inline-code-at-pos begin (cdr last-inline-code)) - (setq last-inline-code `(,(match-beginning 0) . ,(match-end 0))))) - - (markdown-inline-code-at-pos-p (1- end)) - (markdown-in-comment-p) - (markdown-range-property-any - begin begin 'face '(markdown-url-face - markdown-plain-url-face - markdown-markup-face)) - (markdown-range-property-any - begin end 'face '(markdown-bold-face - markdown-list-face - markdown-hr-face - markdown-math-face)) - (and is-gfm - (or (char-equal (char-after begin) (char-after (1+ begin))) ;; check bold case - (not (markdown--gfm-markup-underscore-p begin close-end))))) - (progn (goto-char (min (1+ begin) last)) - (unless (< (point) last) - (setq - done t))) - (set-match-data (list (match-beginning 1) (match-end 1) - (match-beginning 2) (match-end 2) - (match-beginning 3) (match-end 3) - (match-beginning 4) (match-end 4))) - (setq done t - retval t))) - (setq done t))) - retval))) - -(defun markdown--match-highlighting (last) - (when markdown-enable-highlighting-syntax - (re-search-forward markdown-regex-highlighting last t))) - -(defun markdown-match-escape (last) - "Match escape characters (backslashes) from point to LAST. -Backlashes only count as escape characters outside of literal -regions (e.g. code blocks). See `markdown-literal-faces'." - (catch 'found - (while (search-forward-regexp markdown-regex-escape last t) - (let* ((face (get-text-property (match-beginning 1) 'face)) - (face-list (if (listp face) face (list face)))) - ;; Ignore any backslashes with a literal face. - (unless (cl-intersection face-list markdown-literal-faces) - (throw 'found t)))))) - -(defun markdown-match-math-generic (regex last) - "Match REGEX from point to LAST. -REGEX is either `markdown-regex-math-inline-single' for matching -$..$ or `markdown-regex-math-inline-double' for matching $$..$$." - (when (markdown-match-inline-generic regex last) - (let ((begin (match-beginning 1)) (end (match-end 1))) - (prog1 - (if (or (markdown-range-property-any - begin end 'face - '(markdown-inline-code-face markdown-bold-face)) - (markdown-range-properties-exist - begin end - (markdown-get-fenced-block-middle-properties))) - (markdown-match-math-generic regex last) - t) - (goto-char (1+ (match-end 0))))))) - -(defun markdown-match-list-items (last) - "Match list items from point to LAST." - (let* ((first (point)) - (pos first) - (prop 'markdown-list-item) - (bounds (car (get-text-property pos prop)))) - (while - (and (or (null (setq bounds (car (get-text-property pos prop)))) - (< (cl-first bounds) pos)) - (< (point) last) - (setq pos (next-single-property-change pos prop nil last)) - (goto-char pos))) - (when bounds - (set-match-data (cl-seventh bounds)) - ;; Step at least one character beyond point. Otherwise - ;; `font-lock-fontify-keywords-region' infloops. - (goto-char (min (1+ (max (line-end-position) first)) - (point-max))) - t))) - -(defun markdown-match-math-single (last) - "Match single quoted $..$ math from point to LAST." - (when markdown-enable-math - (when (and (char-equal (char-after) ?$) - (not (bolp)) - (not (char-equal (char-before) ?\\)) - (not (char-equal (char-before) ?$))) - (forward-char -1)) - (markdown-match-math-generic markdown-regex-math-inline-single last))) - -(defun markdown-match-math-double (last) - "Match double quoted $$..$$ math from point to LAST." - (when markdown-enable-math - (when (and (< (1+ (point)) (point-max)) - (char-equal (char-after) ?$) - (char-equal (char-after (1+ (point))) ?$) - (not (bolp)) - (not (char-equal (char-before) ?\\)) - (not (char-equal (char-before) ?$))) - (forward-char -1)) - (markdown-match-math-generic markdown-regex-math-inline-double last))) - -(defun markdown-match-math-display (last) - "Match bracketed display math \[..\] and \\[..\\] from point to LAST." - (when markdown-enable-math - (markdown-match-math-generic markdown-regex-math-display last))) - -(defun markdown-match-propertized-text (property last) - "Match text with PROPERTY from point to LAST. -Restore match data previously stored in PROPERTY." - (let ((saved (get-text-property (point) property)) - pos) - (unless saved - (setq pos (next-single-property-change (point) property nil last)) - (unless (= pos last) - (setq saved (get-text-property pos property)))) - (when saved - (set-match-data saved) - ;; Step at least one character beyond point. Otherwise - ;; `font-lock-fontify-keywords-region' infloops. - (goto-char (min (1+ (max (match-end 0) (point))) - (point-max))) - saved))) - -(defun markdown-match-pre-blocks (last) - "Match preformatted blocks from point to LAST. -Use data stored in \\='markdown-pre text property during syntax -analysis." - (markdown-match-propertized-text 'markdown-pre last)) - -(defun markdown-match-gfm-code-blocks (last) - "Match GFM quoted code blocks from point to LAST. -Use data stored in \\='markdown-gfm-code text property during syntax -analysis." - (markdown-match-propertized-text 'markdown-gfm-code last)) - -(defun markdown-match-gfm-open-code-blocks (last) - (markdown-match-propertized-text 'markdown-gfm-block-begin last)) - -(defun markdown-match-gfm-close-code-blocks (last) - (markdown-match-propertized-text 'markdown-gfm-block-end last)) - -(defun markdown-match-fenced-code-blocks (last) - "Match fenced code blocks from the point to LAST." - (markdown-match-propertized-text 'markdown-fenced-code last)) - -(defun markdown-match-fenced-start-code-block (last) - (markdown-match-propertized-text 'markdown-tilde-fence-begin last)) - -(defun markdown-match-fenced-end-code-block (last) - (markdown-match-propertized-text 'markdown-tilde-fence-end last)) - -(defun markdown-match-blockquotes (last) - "Match blockquotes from point to LAST. -Use data stored in \\='markdown-blockquote text property during syntax -analysis." - (markdown-match-propertized-text 'markdown-blockquote last)) - -(defun markdown-match-hr (last) - "Match horizontal rules comments from the point to LAST." - (markdown-match-propertized-text 'markdown-hr last)) - -(defun markdown-match-comments (last) - "Match HTML comments from the point to LAST." - (when (and (skip-syntax-forward "^<" last)) - (let ((beg (point))) - (when (and (skip-syntax-forward "^>" last) (< (point) last)) - (forward-char) - (set-match-data (list beg (point))) - t)))) - -(defun markdown-match-generic-links (last ref) - "Match inline links from point to LAST. -When REF is non-nil, match reference links instead of standard -links with URLs. -This function should only be used during font-lock, as it -determines syntax based on the presence of faces for previously -processed elements." - ;; Search for the next potential link (not in a code block). - (let ((prohibited-faces '(markdown-pre-face - markdown-code-face - markdown-inline-code-face - markdown-comment-face)) - found) - (while - (and (not found) (< (point) last) - (progn - ;; Clear match data to test for a match after functions returns. - (set-match-data nil) - ;; Preliminary regular expression search so we can return - ;; quickly upon failure. This doesn't handle malformed links - ;; or nested square brackets well, so if it passes we back up - ;; continue with a more precise search. - (re-search-forward - (if ref - markdown-regex-link-reference - markdown-regex-link-inline) - last 'limit))) - ;; Keep searching if this is in a code block, inline code, or a - ;; comment, or if it is include syntax. The link text portion - ;; (group 3) may contain inline code or comments, but the - ;; markup, URL, and title should not be part of such elements. - (if (or (markdown-range-property-any - (match-beginning 0) (match-end 2) 'face prohibited-faces) - (markdown-range-property-any - (match-beginning 4) (match-end 0) 'face prohibited-faces) - (and (char-equal (char-after (line-beginning-position)) ?<) - (char-equal (char-after (1+ (line-beginning-position))) ?<))) - (set-match-data nil) - (setq found t)))) - ;; Match opening exclamation point (optional) and left bracket. - (when (match-beginning 2) - (let* ((bang (match-beginning 1)) - (first-begin (match-beginning 2)) - ;; Find end of block to prevent matching across blocks. - (end-of-block (save-excursion - (progn - (goto-char (match-beginning 2)) - (markdown-end-of-text-block) - (point)))) - ;; Move over balanced expressions to closing right bracket. - ;; Catch unbalanced expression errors and return nil. - (first-end (condition-case nil - (and (goto-char first-begin) - (scan-sexps (point) 1)) - (error nil))) - ;; Continue with point at CONT-POINT upon failure. - (cont-point (min (1+ first-begin) last)) - second-begin second-end url-begin url-end - title-begin title-end) - ;; When bracket found, in range, and followed by a left paren/bracket... - (when (and first-end (< first-end end-of-block) (goto-char first-end) - (char-equal (char-after (point)) (if ref ?\[ ?\())) - ;; Scan across balanced expressions for closing parenthesis/bracket. - (setq second-begin (point) - second-end (condition-case nil - (scan-sexps (point) 1) - (error nil))) - ;; Check that closing parenthesis/bracket is in range. - (if (and second-end (<= second-end end-of-block) (<= second-end last)) - (progn - ;; Search for (optional) title inside closing parenthesis - (when (and (not ref) (search-forward "\"" second-end t)) - (setq title-begin (1- (point)) - title-end (and (goto-char second-end) - (search-backward "\"" (1+ title-begin) t)) - title-end (and title-end (1+ title-end)))) - ;; Store URL/reference range - (setq url-begin (1+ second-begin) - url-end (1- (or title-begin second-end))) - ;; Set match data, move point beyond link, and return - (set-match-data - (list (or bang first-begin) second-end ; 0 - all - bang (and bang (1+ bang)) ; 1 - bang - first-begin (1+ first-begin) ; 2 - markup - (1+ first-begin) (1- first-end) ; 3 - link text - (1- first-end) first-end ; 4 - markup - second-begin (1+ second-begin) ; 5 - markup - url-begin url-end ; 6 - url/reference - title-begin title-end ; 7 - title - (1- second-end) second-end)) ; 8 - markup - ;; Nullify cont-point and leave point at end and - (setq cont-point nil) - (goto-char second-end)) - ;; If no closing parenthesis in range, update continuation point - (setq cont-point (min end-of-block second-begin)))) - (cond - ;; On failure, continue searching at cont-point - ((and cont-point (< cont-point last)) - (goto-char cont-point) - (markdown-match-generic-links last ref)) - ;; No more text, return nil - ((and cont-point (= cont-point last)) - nil) - ;; Return t if a match occurred - (t t))))) - -(defun markdown-match-angle-uris (last) - "Match angle bracket URIs from point to LAST." - (when (markdown-match-inline-generic markdown-regex-angle-uri last) - (goto-char (1+ (match-end 0))))) - -(defun markdown-match-plain-uris (last) - "Match plain URIs from point to LAST." - (when (markdown-match-inline-generic markdown-regex-uri last t) - (goto-char (1+ (match-end 0))))) - -(defvar markdown-conditional-search-function #'re-search-forward - "Conditional search function used in `markdown-search-until-condition'. -Made into a variable to allow for dynamic let-binding.") - -(defun markdown-search-until-condition (condition &rest args) - (let (ret) - (while (and (not ret) (apply markdown-conditional-search-function args)) - (setq ret (funcall condition))) - ret)) - -(defun markdown-metadata-line-p (pos regexp) - (save-excursion - (or (= (line-number-at-pos pos) 1) - (progn - (forward-line -1) - ;; skip multi-line metadata - (while (and (looking-at-p "^\\s-+[[:alpha:]]") - (> (line-number-at-pos (point)) 1)) - (forward-line -1)) - (looking-at-p regexp))))) - -(defun markdown-match-generic-metadata (regexp last) - "Match metadata declarations specified by REGEXP from point to LAST. -These declarations must appear inside a metadata block that begins at -the beginning of the buffer and ends with a blank line (or the end of -the buffer)." - (let* ((first (point)) - (end-re "\n[ \t]*\n\\|\n\\'\\|\\'") - (block-begin (goto-char 1)) - (block-end (re-search-forward end-re nil t))) - (if (and block-end (> first block-end)) - ;; Don't match declarations if there is no metadata block or if - ;; the point is beyond the block. Move point to point-max to - ;; prevent additional searches and return return nil since nothing - ;; was found. - (progn (goto-char (point-max)) nil) - ;; If a block was found that begins before LAST and ends after - ;; point, search for declarations inside it. If the starting is - ;; before the beginning of the block, start there. Otherwise, - ;; move back to FIRST. - (goto-char (if (< first block-begin) block-begin first)) - (if (and (re-search-forward regexp (min last block-end) t) - (markdown-metadata-line-p (point) regexp)) - ;; If a metadata declaration is found, set match-data and return t. - (let ((key-beginning (match-beginning 1)) - (key-end (match-end 1)) - (markup-begin (match-beginning 2)) - (markup-end (match-end 2)) - (value-beginning (match-beginning 3))) - (set-match-data (list key-beginning (point) ; complete metadata - key-beginning key-end ; key - markup-begin markup-end ; markup - value-beginning (point))) ; value - t) - ;; Otherwise, move the point to last and return nil - (goto-char last) - nil)))) - -(defun markdown-match-declarative-metadata (last) - "Match declarative metadata from the point to LAST." - (markdown-match-generic-metadata markdown-regex-declarative-metadata last)) - -(defun markdown-match-pandoc-metadata (last) - "Match Pandoc metadata from the point to LAST." - (markdown-match-generic-metadata markdown-regex-pandoc-metadata last)) - -(defun markdown-match-yaml-metadata-begin (last) - (markdown-match-propertized-text 'markdown-yaml-metadata-begin last)) - -(defun markdown-match-yaml-metadata-end (last) - (markdown-match-propertized-text 'markdown-yaml-metadata-end last)) - -(defun markdown-match-yaml-metadata-key (last) - (markdown-match-propertized-text 'markdown-metadata-key last)) - -(defun markdown-match-wiki-link (last) - "Match wiki links from point to LAST." - (when (and markdown-enable-wiki-links - (not markdown-wiki-link-fontify-missing) - (markdown-match-inline-generic markdown-regex-wiki-link last)) - (let ((begin (match-beginning 1)) (end (match-end 1))) - (if (or (markdown-in-comment-p begin) - (markdown-in-comment-p end) - (markdown-inline-code-at-pos-p begin) - (markdown-inline-code-at-pos-p end) - (markdown-code-block-at-pos begin)) - (progn (goto-char (min (1+ begin) last)) - (when (< (point) last) - (markdown-match-wiki-link last))) - (set-match-data (list begin end)) - t)))) - -(defun markdown-match-inline-attributes (last) - "Match inline attributes from point to LAST." - ;; #428 re-search-forward markdown-regex-inline-attributes is very slow. - ;; So use simple regex for re-search-forward and use markdown-regex-inline-attributes - ;; against matched string. - (when (markdown-match-inline-generic "[ \t]*\\({\\)\\([^\n]*\\)}[ \t]*$" last) - (if (not (string-match-p markdown-regex-inline-attributes (match-string 0))) - (markdown-match-inline-attributes last) - (unless (or (markdown-inline-code-at-pos-p (match-beginning 0)) - (markdown-inline-code-at-pos-p (match-end 0)) - (markdown-in-comment-p)) - t)))) - -(defun markdown-match-leanpub-sections (last) - "Match Leanpub section markers from point to LAST." - (when (markdown-match-inline-generic markdown-regex-leanpub-sections last) - (unless (or (markdown-inline-code-at-pos-p (match-beginning 0)) - (markdown-inline-code-at-pos-p (match-end 0)) - (markdown-in-comment-p)) - t))) - -(defun markdown-match-includes (last) - "Match include statements from point to LAST. -Sets match data for the following seven groups: -Group 1: opening two angle brackets -Group 2: opening title delimiter (optional) -Group 3: title text (optional) -Group 4: closing title delimiter (optional) -Group 5: opening filename delimiter -Group 6: filename -Group 7: closing filename delimiter" - (when (markdown-match-inline-generic markdown-regex-include last) - (let ((valid (not (or (markdown-in-comment-p (match-beginning 0)) - (markdown-in-comment-p (match-end 0)) - (markdown-code-block-at-pos (match-beginning 0)))))) - (cond - ;; Parentheses and maybe square brackets, but no curly braces: - ;; match optional title in square brackets and file in parentheses. - ((and valid (match-beginning 5) - (not (match-beginning 8))) - (set-match-data (list (match-beginning 1) (match-end 7) - (match-beginning 1) (match-end 1) - (match-beginning 2) (match-end 2) - (match-beginning 3) (match-end 3) - (match-beginning 4) (match-end 4) - (match-beginning 5) (match-end 5) - (match-beginning 6) (match-end 6) - (match-beginning 7) (match-end 7)))) - ;; Only square brackets present: match file in square brackets. - ((and valid (match-beginning 2) - (not (match-beginning 5)) - (not (match-beginning 7))) - (set-match-data (list (match-beginning 1) (match-end 4) - (match-beginning 1) (match-end 1) - nil nil - nil nil - nil nil - (match-beginning 2) (match-end 2) - (match-beginning 3) (match-end 3) - (match-beginning 4) (match-end 4)))) - ;; Only curly braces present: match file in curly braces. - ((and valid (match-beginning 8) - (not (match-beginning 2)) - (not (match-beginning 5))) - (set-match-data (list (match-beginning 1) (match-end 10) - (match-beginning 1) (match-end 1) - nil nil - nil nil - nil nil - (match-beginning 8) (match-end 8) - (match-beginning 9) (match-end 9) - (match-beginning 10) (match-end 10)))) - (t - ;; Not a valid match, move to next line and search again. - (forward-line) - (when (< (point) last) - (setq valid (markdown-match-includes last))))) - valid))) - -(defun markdown-match-html-tag (last) - "Match HTML tags from point to LAST." - (when (and markdown-enable-html - (markdown-match-inline-generic markdown-regex-html-tag last t)) - (set-match-data (list (match-beginning 0) (match-end 0) - (match-beginning 1) (match-end 1) - (match-beginning 2) (match-end 2) - (match-beginning 9) (match-end 9))) - t)) - - -;;; Markdown Font Fontification Functions ===================================== - -(defvar markdown--first-displayable-cache (make-hash-table :test #'equal)) - -(defun markdown--first-displayable (seq) - "Return the first displayable character or string in SEQ. -SEQ may be an atom or a sequence." - (let ((c (gethash seq markdown--first-displayable-cache t))) - (if (not (eq c t)) - c - (puthash seq - (let ((seq (if (listp seq) seq (list seq)))) - (cond ((stringp (car seq)) - (cl-find-if - (lambda (str) - (and (mapcar #'char-displayable-p (string-to-list str)))) - seq)) - ((characterp (car seq)) - (cl-find-if #'char-displayable-p seq)))) - markdown--first-displayable-cache)))) - -(defun markdown--marginalize-string (level) - "Generate atx markup string of given LEVEL for left margin." - (let ((margin-left-space-count - (- markdown-marginalize-headers-margin-width level))) - (concat (make-string margin-left-space-count ? ) - (make-string level ?#)))) - -(defun markdown-marginalize-update-current () - "Update the window configuration to create a left margin." - (if window-system - (let* ((header-delimiter-font-width - (window-font-width nil 'markdown-header-delimiter-face)) - (margin-pixel-width (* markdown-marginalize-headers-margin-width - header-delimiter-font-width)) - (margin-char-width (/ margin-pixel-width (default-font-width)))) - (set-window-margins nil margin-char-width)) - ;; As a fallback, simply set margin based on character count. - (set-window-margins nil (1+ markdown-marginalize-headers-margin-width)))) - -(defun markdown-fontify-headings (last) - "Add text properties to headings from point to LAST." - (when (markdown-match-propertized-text 'markdown-heading last) - (let* ((level (markdown-outline-level)) - (heading-face - (intern (format "markdown-header-face-%d" level))) - (heading-props `(face ,heading-face)) - (left-markup-props - `(face markdown-header-delimiter-face - ,@(cond - (markdown-hide-markup - `(display "")) - (markdown-marginalize-headers - `(display ((margin left-margin) - ,(markdown--marginalize-string level))))))) - (right-markup-props - `(face markdown-header-delimiter-face - ,@(when markdown-hide-markup `(display "")))) - (rule-props `(face markdown-header-rule-face - ,@(when markdown-hide-markup `(display ""))))) - (if (match-end 1) - ;; Setext heading - (progn (add-text-properties - (match-beginning 1) (match-end 1) heading-props) - (if (= level 1) - (add-text-properties - (match-beginning 2) (match-end 2) rule-props) - (add-text-properties - (match-beginning 3) (match-end 3) rule-props))) - ;; atx heading - (let ((fontified-start - (if (or markdown-hide-markup (not markdown-fontify-whole-heading-line)) - (match-beginning 5) - (match-beginning 0))) - (fontified-end - (if markdown-fontify-whole-heading-line - (min (point-max) (1+ (match-end 0))) - (match-end 5)))) - (add-text-properties - (match-beginning 4) (match-end 4) left-markup-props) - - ;; If closing tag is present - (if (match-end 6) - (progn - (add-text-properties fontified-start fontified-end heading-props) - (when (or markdown-hide-markup (not markdown-fontify-whole-heading-line)) - (add-text-properties (match-beginning 6) (match-end 6) right-markup-props))) - ;; If closing tag is not present - (add-text-properties fontified-start fontified-end heading-props))))) - t)) - -(defun markdown-fontify-tables (last) - (when (re-search-forward "|" last t) - (when (markdown-table-at-point-p) - (font-lock-append-text-property - (line-beginning-position) (min (1+ (line-end-position)) (point-max)) - 'face 'markdown-table-face)) - (forward-line 1) - t)) - -(defun markdown-fontify-blockquotes (last) - "Apply font-lock properties to blockquotes from point to LAST." - (when (markdown-match-blockquotes last) - (let ((display-string - (markdown--first-displayable markdown-blockquote-display-char))) - (add-text-properties - (match-beginning 1) (match-end 1) - (if markdown-hide-markup - `(face markdown-blockquote-face display ,display-string) - `(face markdown-markup-face))) - (font-lock-append-text-property - (match-beginning 0) (match-end 0) 'face 'markdown-blockquote-face) - t))) - -(defun markdown-fontify-list-items (last) - "Apply font-lock properties to list markers from point to LAST." - (when (markdown-match-list-items last) - (when (not (markdown-code-block-at-point-p (match-beginning 2))) - (let* ((indent (length (match-string-no-properties 1))) - (level (/ indent markdown-list-indent-width)) ;; level = 0, 1, 2, ... - (bullet (nth (mod level (length markdown-list-item-bullets)) - markdown-list-item-bullets))) - (add-text-properties - (match-beginning 2) (match-end 2) '(face markdown-list-face)) - (when markdown-hide-markup - (cond - ;; Unordered lists - ((string-match-p "[\\*\\+-]" (match-string 2)) - (add-text-properties - (match-beginning 2) (match-end 2) `(display ,bullet))) - ;; Definition lists - ((string-equal ":" (match-string 2)) - (let ((display-string - (char-to-string (markdown--first-displayable - markdown-definition-display-char)))) - (add-text-properties (match-beginning 2) (match-end 2) - `(display ,display-string)))))))) - t)) - -(defun markdown--fontify-hrs-view-mode (hr-char) - (if (and hr-char (display-supports-face-attributes-p '(:extend t))) - (add-text-properties - (match-beginning 0) (match-end 0) - `(face - (:inherit markdown-hr-face :underline t :extend t) - font-lock-multiline t - display "\n")) - (let ((hr-len (and hr-char (/ (1- (window-body-width)) (char-width hr-char))))) - (add-text-properties - (match-beginning 0) (match-end 0) - `(face - markdown-hr-face font-lock-multiline t - display ,(make-string hr-len hr-char)))))) - -(defun markdown-fontify-hrs (last) - "Add text properties to horizontal rules from point to LAST." - (when (markdown-match-hr last) - (let ((hr-char (markdown--first-displayable markdown-hr-display-char))) - (if (and markdown-hide-markup hr-char) - (markdown--fontify-hrs-view-mode hr-char) - (add-text-properties - (match-beginning 0) (match-end 0) - `(face markdown-hr-face font-lock-multiline t))) - t))) - -(defun markdown-fontify-sub-superscripts (last) - "Apply text properties to sub- and superscripts from point to LAST." - (when (markdown-search-until-condition - (lambda () (and (not (markdown-code-block-at-point-p)) - (not (markdown-inline-code-at-point-p)) - (not (markdown-in-comment-p)) - (not (markdown--math-block-p)))) - markdown-regex-sub-superscript last t) - (let* ((subscript-p (string= (match-string 2) "~")) - (props - (if subscript-p - (car markdown-sub-superscript-display) - (cdr markdown-sub-superscript-display))) - (mp (list 'face 'markdown-markup-face - 'invisible 'markdown-markup))) - (when markdown-hide-markup - (put-text-property (match-beginning 3) (match-end 3) - 'display props)) - (add-text-properties (match-beginning 2) (match-end 2) mp) - (add-text-properties (match-beginning 4) (match-end 4) mp) - t))) - - -;;; Syntax Table ============================================================== - -(defvar markdown-mode-syntax-table - (let ((tab (make-syntax-table text-mode-syntax-table))) - (modify-syntax-entry ?\" "." tab) - tab) - "Syntax table for `markdown-mode'.") - - -;;; Element Insertion ========================================================= - -(defun markdown-ensure-blank-line-before () - "If previous line is not already blank, insert a blank line before point." - (unless (bolp) (insert "\n")) - (unless (or (bobp) (looking-back "\n\\s-*\n" nil)) (insert "\n"))) - -(defun markdown-ensure-blank-line-after () - "If following line is not already blank, insert a blank line after point. -Return the point where it was originally." - (save-excursion - (unless (eolp) (insert "\n")) - (unless (or (eobp) (looking-at-p "\n\\s-*\n")) (insert "\n")))) - -(defun markdown-wrap-or-insert (s1 s2 &optional thing beg end) - "Insert the strings S1 and S2, wrapping around region or THING. -If a region is specified by the optional BEG and END arguments, -wrap the strings S1 and S2 around that region. -If there is an active region, wrap the strings S1 and S2 around -the region. If there is not an active region but the point is at -THING, wrap that thing (which defaults to word). Otherwise, just -insert S1 and S2 and place the point in between. Return the -bounds of the entire wrapped string, or nil if nothing was wrapped -and S1 and S2 were only inserted." - (let (a b bounds new-point) - (cond - ;; Given region - ((and beg end) - (setq a beg - b end - new-point (+ (point) (length s1)))) - ;; Active region - ((use-region-p) - (setq a (region-beginning) - b (region-end) - new-point (+ (point) (length s1)))) - ;; Thing (word) at point - ((setq bounds (markdown-bounds-of-thing-at-point (or thing 'word))) - (setq a (car bounds) - b (cdr bounds) - new-point (+ (point) (length s1)))) - ;; No active region and no word - (t - (setq a (point) - b (point)))) - (goto-char b) - (insert s2) - (goto-char a) - (insert s1) - (when new-point (goto-char new-point)) - (if (= a b) - nil - (setq b (+ b (length s1) (length s2))) - (cons a b)))) - -(defun markdown-point-after-unwrap (cur prefix suffix) - "Return desired position of point after an unwrapping operation. -CUR gives the position of the point before the operation. -Additionally, two cons cells must be provided. PREFIX gives the -bounds of the prefix string and SUFFIX gives the bounds of the -suffix string." - (cond ((< cur (cdr prefix)) (car prefix)) - ((< cur (car suffix)) (- cur (- (cdr prefix) (car prefix)))) - ((<= cur (cdr suffix)) - (- cur (+ (- (cdr prefix) (car prefix)) - (- cur (car suffix))))) - (t cur))) - -(defun markdown-unwrap-thing-at-point (regexp all text) - "Remove prefix and suffix of thing at point and reposition the point. -When the thing at point matches REGEXP, replace the subexpression -ALL with the string in subexpression TEXT. Reposition the point -in an appropriate location accounting for the removal of prefix -and suffix strings. Return new bounds of string from group TEXT. -When REGEXP is nil, assumes match data is already set." - (when (or (null regexp) - (thing-at-point-looking-at regexp)) - (let ((cur (point)) - (prefix (cons (match-beginning all) (match-beginning text))) - (suffix (cons (match-end text) (match-end all))) - (bounds (cons (match-beginning text) (match-end text)))) - ;; Replace the thing at point - (replace-match (match-string text) t t nil all) - ;; Reposition the point - (goto-char (markdown-point-after-unwrap cur prefix suffix)) - ;; Adjust bounds - (setq bounds (cons (car prefix) - (- (cdr bounds) (- (cdr prefix) (car prefix)))))))) - -(defun markdown-unwrap-things-in-region (beg end regexp all text) - "Remove prefix and suffix of all things in region from BEG to END. -When a thing in the region matches REGEXP, replace the -subexpression ALL with the string in subexpression TEXT. -Return a cons cell containing updated bounds for the region." - (save-excursion - (goto-char beg) - (let ((removed 0) len-all len-text) - (while (re-search-forward regexp (- end removed) t) - (setq len-all (length (match-string-no-properties all))) - (setq len-text (length (match-string-no-properties text))) - (setq removed (+ removed (- len-all len-text))) - (replace-match (match-string text) t t nil all)) - (cons beg (- end removed))))) - -(defun markdown-insert-hr (arg) - "Insert or replace a horizontal rule. -By default, use the first element of `markdown-hr-strings'. When -ARG is non-nil, as when given a prefix, select a different -element as follows. When prefixed with \\[universal-argument], -use the last element of `markdown-hr-strings' instead. When -prefixed with an integer from 1 to the length of -`markdown-hr-strings', use the element in that position instead." - (interactive "*P") - (when (thing-at-point-looking-at markdown-regex-hr) - (delete-region (match-beginning 0) (match-end 0))) - (markdown-ensure-blank-line-before) - (cond ((equal arg '(4)) - (insert (car (reverse markdown-hr-strings)))) - ((and (integerp arg) (> arg 0) - (<= arg (length markdown-hr-strings))) - (insert (nth (1- arg) markdown-hr-strings))) - (t - (insert (car markdown-hr-strings)))) - (markdown-ensure-blank-line-after)) - -(defun markdown--insert-common (start-delim end-delim regex start-group end-group face - &optional skip-space) - (if (use-region-p) - ;; Active region - (let* ((bounds (markdown-unwrap-things-in-region - (region-beginning) (region-end) - regex start-group end-group)) - (beg (car bounds)) - (end (cdr bounds))) - (when (and beg skip-space) - (save-excursion - (goto-char beg) - (skip-chars-forward " \t") - (setq beg (point)))) - (when (and end skip-space) - (save-excursion - (goto-char end) - (skip-chars-backward " \t") - (setq end (point)))) - (markdown-wrap-or-insert start-delim end-delim nil beg end)) - (if (markdown--face-p (point) (list face)) - (save-excursion - (while (and (markdown--face-p (point) (list face)) (not (bobp))) - (forward-char -1)) - (forward-char (- (1- (length start-delim)))) ;; for delimiter - (unless (bolp) - (forward-char -1)) - (when (looking-at regex) - (markdown-unwrap-thing-at-point nil start-group end-group))) - (if (thing-at-point-looking-at regex) - (markdown-unwrap-thing-at-point nil start-group end-group) - (markdown-wrap-or-insert start-delim end-delim 'word nil nil))))) - -(defun markdown-insert-bold () - "Insert markup to make a region or word bold. -If there is an active region, make the region bold. If the point -is at a non-bold word, make the word bold. If the point is at a -bold word or phrase, remove the bold markup. Otherwise, simply -insert bold delimiters and place the point in between them." - (interactive) - (let ((delim (if markdown-bold-underscore "__" "**"))) - (markdown--insert-common delim delim markdown-regex-bold 2 4 'markdown-bold-face t))) - -(defun markdown-insert-italic () - "Insert markup to make a region or word italic. -If there is an active region, make the region italic. If the point -is at a non-italic word, make the word italic. If the point is at an -italic word or phrase, remove the italic markup. Otherwise, simply -insert italic delimiters and place the point in between them." - (interactive) - (let ((delim (if markdown-italic-underscore "_" "*"))) - (markdown--insert-common delim delim markdown-regex-italic 1 3 'markdown-italic-face t))) - -(defun markdown-insert-strike-through () - "Insert markup to make a region or word strikethrough. -If there is an active region, make the region strikethrough. If the point -is at a non-bold word, make the word strikethrough. If the point is at a -strikethrough word or phrase, remove the strikethrough markup. Otherwise, -simply insert bold delimiters and place the point in between them." - (interactive) - (markdown--insert-common - "~~" "~~" markdown-regex-strike-through 2 4 'markdown-strike-through-face t)) - -(defun markdown-insert-code () - "Insert markup to make a region or word an inline code fragment. -If there is an active region, make the region an inline code -fragment. If the point is at a word, make the word an inline -code fragment. Otherwise, simply insert code delimiters and -place the point in between them." - (interactive) - (if (use-region-p) - ;; Active region - (let ((bounds (markdown-unwrap-things-in-region - (region-beginning) (region-end) - markdown-regex-code 1 3))) - (markdown-wrap-or-insert "`" "`" nil (car bounds) (cdr bounds))) - ;; Code markup removal, code markup for word, or empty markup insertion - (if (markdown-inline-code-at-point) - (markdown-unwrap-thing-at-point nil 0 2) - (markdown-wrap-or-insert "`" "`" 'word nil nil)))) - -(defun markdown-insert-kbd () - "Insert markup to wrap region or word in <kbd> tags. -If there is an active region, use the region. If the point is at -a word, use the word. Otherwise, simply insert <kbd> tags and -place the point in between them." - (interactive) - (if (use-region-p) - ;; Active region - (let ((bounds (markdown-unwrap-things-in-region - (region-beginning) (region-end) - markdown-regex-kbd 0 2))) - (markdown-wrap-or-insert "<kbd>" "</kbd>" nil (car bounds) (cdr bounds))) - ;; Markup removal, markup for word, or empty markup insertion - (if (thing-at-point-looking-at markdown-regex-kbd) - (markdown-unwrap-thing-at-point nil 0 2) - (markdown-wrap-or-insert "<kbd>" "</kbd>" 'word nil nil)))) - -(defun markdown-insert-inline-link (text url &optional title) - "Insert an inline link with TEXT pointing to URL. -Optionally, the user can provide a TITLE." - (let ((cur (point))) - (setq title (and title (concat " \"" title "\""))) - (insert (concat "[" text "](" url title ")")) - (cond ((not text) (goto-char (+ 1 cur))) - ((not url) (goto-char (+ 3 (length text) cur)))))) - -(defun markdown-insert-inline-image (text url &optional title) - "Insert an inline link with alt TEXT pointing to URL. -Optionally, also provide a TITLE." - (let ((cur (point))) - (setq title (and title (concat " \"" title "\""))) - (insert (concat "![" text "](" url title ")")) - (cond ((not text) (goto-char (+ 2 cur))) - ((not url) (goto-char (+ 4 (length text) cur)))))) - -(defun markdown-insert-reference-link (text label &optional url title) - "Insert a reference link and, optionally, a reference definition. -The link TEXT will be inserted followed by the optional LABEL. -If a URL is given, also insert a definition for the reference -LABEL according to `markdown-reference-location'. If a TITLE is -given, it will be added to the end of the reference definition -and will be used to populate the title attribute when converted -to XHTML. If URL is nil, insert only the link portion (for -example, when a reference label is already defined)." - (insert (concat "[" text "][" label "]")) - (when url - (markdown-insert-reference-definition - (if (string-equal label "") text label) - url title))) - -(defun markdown-insert-reference-image (text label &optional url title) - "Insert a reference image and, optionally, a reference definition. -The alt TEXT will be inserted followed by the optional LABEL. -If a URL is given, also insert a definition for the reference -LABEL according to `markdown-reference-location'. If a TITLE is -given, it will be added to the end of the reference definition -and will be used to populate the title attribute when converted -to XHTML. If URL is nil, insert only the link portion (for -example, when a reference label is already defined)." - (insert (concat "![" text "][" label "]")) - (when url - (markdown-insert-reference-definition - (if (string-equal label "") text label) - url title))) - -(defun markdown-insert-reference-definition (label &optional url title) - "Add definition for reference LABEL with URL and TITLE. -LABEL is a Markdown reference label without square brackets. -URL and TITLE are optional. When given, the TITLE will -be used to populate the title attribute when converted to XHTML." - ;; END specifies where to leave the point upon return - (let ((end (point))) - (cl-case markdown-reference-location - (end (goto-char (point-max))) - (immediately (markdown-end-of-text-block)) - (subtree (markdown-end-of-subtree)) - (header (markdown-end-of-defun))) - ;; Skip backwards over local variables. This logic is similar to the one - ;; used in ‘hack-local-variables’. - (when (and enable-local-variables (eobp)) - (search-backward "\n\f" (max (- (point) 3000) (point-min)) :move) - (when (let ((case-fold-search t)) - (search-forward "Local Variables:" nil :move)) - (beginning-of-line 0) - (when (eq (char-before) ?\n) (backward-char)))) - (unless (or (markdown-cur-line-blank-p) - (thing-at-point-looking-at markdown-regex-reference-definition)) - (insert "\n")) - (insert "\n[" label "]: ") - (if url - (insert url) - ;; When no URL is given, leave point at END following the colon - (setq end (point))) - (when (> (length title) 0) - (insert " \"" title "\"")) - (unless (looking-at-p "\n") - (insert "\n")) - (goto-char end) - (when url - (message - (markdown--substitute-command-keys - "Reference [%s] was defined, press \\[markdown-do] to jump there") - label)))) - -(defcustom markdown-link-make-text-function nil - "Function that automatically generates a link text for a URL. - -If non-nil, this function will be called by -`markdown--insert-link-or-image' and the result will be the -default link text. The function should receive exactly one -argument that corresponds to the link URL." - :group 'markdown - :type 'function - :package-version '(markdown-mode . "2.5")) - -(defcustom markdown-disable-tooltip-prompt nil - "Disable prompt for tooltip when inserting a link or image. - -If non-nil, `markdown-insert-link' and `markdown-insert-link' -will not prompt the user to insert a tooltip text for the given -link or image." - :group 'markdown - :type 'boolean - :safe 'booleanp - :package-version '(markdown-mode . "2.5")) - -(defun markdown--insert-link-or-image (image) - "Interactively insert new or update an existing link or image. -When IMAGE is non-nil, insert an image. Otherwise, insert a link. -This is an internal function called by -`markdown-insert-link' and `markdown-insert-image'." - (cl-multiple-value-bind (begin end text uri ref title) - (if (use-region-p) - ;; Use region as either link text or URL as appropriate. - (let ((region (buffer-substring-no-properties - (region-beginning) (region-end)))) - (if (string-match markdown-regex-uri region) - ;; Region contains a URL; use it as such. - (list (region-beginning) (region-end) - nil (match-string 0 region) nil nil) - ;; Region doesn't contain a URL, so use it as text. - (list (region-beginning) (region-end) - region nil nil nil))) - ;; Extract and use properties of existing link, if any. - (markdown-link-at-pos (point))) - (let* ((ref (when ref (concat "[" ref "]"))) - (defined-refs (mapcar #'car (markdown-get-defined-references))) - (defined-ref-cands (mapcar (lambda (ref) (concat "[" ref "]")) defined-refs)) - (used-uris (markdown-get-used-uris)) - (uri-or-ref (completing-read - "URL or [reference]: " - (append defined-ref-cands used-uris) - nil nil (or uri ref))) - (ref (cond ((string-match "\\`\\[\\(.*\\)\\]\\'" uri-or-ref) - (match-string 1 uri-or-ref)) - ((string-equal "" uri-or-ref) - ""))) - (uri (unless ref uri-or-ref)) - (text-prompt (if image - "Alt text: " - (if ref - "Link text: " - "Link text (blank for plain URL): "))) - (text (or text (and markdown-link-make-text-function uri - (funcall markdown-link-make-text-function uri)))) - (text (completing-read text-prompt defined-refs nil nil text)) - (text (if (= (length text) 0) nil text)) - (plainp (and uri (not text))) - (implicitp (string-equal ref "")) - (ref (if implicitp text ref)) - (definedp (and ref (markdown-reference-definition ref))) - (ref-url (unless (or uri definedp) - (completing-read "Reference URL: " used-uris))) - (title (unless (or plainp definedp markdown-disable-tooltip-prompt) - (read-string "Title (tooltip text, optional): " title))) - (title (if (= (length title) 0) nil title))) - (when (and image implicitp) - (user-error "Reference required: implicit image references are invalid")) - (when (and begin end) - (delete-region begin end)) - (cond - ((and (not image) uri text) - (markdown-insert-inline-link text uri title)) - ((and image uri text) - (markdown-insert-inline-image text uri title)) - ((and ref text) - (if image - (markdown-insert-reference-image text (unless implicitp ref) nil title) - (markdown-insert-reference-link text (unless implicitp ref) nil title)) - (unless definedp - (markdown-insert-reference-definition ref ref-url title))) - ((and (not image) uri) - (markdown-insert-uri uri)))))) - -(defun markdown-insert-link () - "Insert new or update an existing link, with interactive prompt. -If the point is at an existing link or URL, update the link text, -URL, reference label, and/or title. Otherwise, insert a new link. -The type of link inserted (inline, reference, or plain URL) -depends on which values are provided: - -* If a URL and TEXT are given, insert an inline link: [TEXT](URL). -* If [REF] and TEXT are given, insert a reference link: [TEXT][REF]. -* If only TEXT is given, insert an implicit reference link: [TEXT][]. -* If only a URL is given, insert a plain link: <URL>. - -In other words, to create an implicit reference link, leave the -URL prompt empty and to create a plain URL link, leave the link -text empty. - -If there is an active region, use the text as the default URL, if -it seems to be a URL, or link text value otherwise. - -If a given reference is not defined, this function will -additionally prompt for the URL and optional title. In this case, -the reference definition is placed at the location determined by -`markdown-reference-location'. In addition, it is possible to -have the `markdown-link-make-text-function' function, if non-nil, -define the default link text before prompting the user for it. - -If `markdown-disable-tooltip-prompt' is non-nil, the user will -not be prompted to add or modify a tooltip text. - -Through updating the link, this function can be used to convert a -link of one type (inline, reference, or plain) to another type by -selectively adding or removing information via the prompts." - (interactive) - (markdown--insert-link-or-image nil)) - -(defun markdown-insert-image () - "Insert new or update an existing image, with interactive prompt. -If the point is at an existing image, update the alt text, URL, -reference label, and/or title. Otherwise, insert a new image. -The type of image inserted (inline or reference) depends on which -values are provided: - -* If a URL and ALT-TEXT are given, insert an inline image: - . -* If [REF] and ALT-TEXT are given, insert a reference image: - ![ALT-TEXT][REF]. - -If there is an active region, use the text as the default URL, if -it seems to be a URL, or alt text value otherwise. - -If a given reference is not defined, this function will -additionally prompt for the URL and optional title. In this case, -the reference definition is placed at the location determined by -`markdown-reference-location'. - -Through updating the image, this function can be used to convert an -image of one type (inline or reference) to another type by -selectively adding or removing information via the prompts." - (interactive) - (markdown--insert-link-or-image t)) - -(defun markdown-insert-uri (&optional uri) - "Insert markup for an inline URI. -If there is an active region, use it as the URI. If the point is -at a URI, wrap it with angle brackets. If the point is at an -inline URI, remove the angle brackets. Otherwise, simply insert -angle brackets place the point between them." - (interactive) - (if (use-region-p) - ;; Active region - (let ((bounds (markdown-unwrap-things-in-region - (region-beginning) (region-end) - markdown-regex-angle-uri 0 2))) - (markdown-wrap-or-insert "<" ">" nil (car bounds) (cdr bounds))) - ;; Markup removal, URI at point, new URI, or empty markup insertion - (if (thing-at-point-looking-at markdown-regex-angle-uri) - (markdown-unwrap-thing-at-point nil 0 2) - (if uri - (insert "<" uri ">") - (markdown-wrap-or-insert "<" ">" 'url nil nil))))) - -(defun markdown-insert-wiki-link () - "Insert a wiki link of the form [[WikiLink]]. -If there is an active region, use the region as the link text. -If the point is at a word, use the word as the link text. If -there is no active region and the point is not at word, simply -insert link markup." - (interactive) - (if (use-region-p) - ;; Active region - (markdown-wrap-or-insert "[[" "]]" nil (region-beginning) (region-end)) - ;; Markup removal, wiki link at at point, or empty markup insertion - (if (thing-at-point-looking-at markdown-regex-wiki-link) - (if (or markdown-wiki-link-alias-first - (null (match-string 5))) - (markdown-unwrap-thing-at-point nil 1 3) - (markdown-unwrap-thing-at-point nil 1 5)) - (markdown-wrap-or-insert "[[" "]]")))) - -(defun markdown-remove-header () - "Remove header markup if point is at a header. -Return bounds of remaining header text if a header was removed -and nil otherwise." - (interactive "*") - (or (markdown-unwrap-thing-at-point markdown-regex-header-atx 0 2) - (markdown-unwrap-thing-at-point markdown-regex-header-setext 0 1))) - -(defun markdown-insert-header (&optional level text setext) - "Insert or replace header markup. -The level of the header is specified by LEVEL and header text is -given by TEXT. LEVEL must be an integer from 1 and 6, and the -default value is 1. -When TEXT is nil, the header text is obtained as follows. -If there is an active region, it is used as the header text. -Otherwise, the current line will be used as the header text. -If there is not an active region and the point is at a header, -remove the header markup and replace with level N header. -Otherwise, insert empty header markup and place the point in -between. -The style of the header will be atx (hash marks) unless -SETEXT is non-nil, in which case a setext-style (underlined) -header will be inserted." - (interactive "p\nsHeader text: ") - (setq level (min (max (or level 1) 1) (if setext 2 6))) - ;; Determine header text if not given - (when (null text) - (if (use-region-p) - ;; Active region - (setq text (delete-and-extract-region (region-beginning) (region-end))) - ;; No active region - (markdown-remove-header) - (setq text (delete-and-extract-region - (line-beginning-position) (line-end-position))) - (when (and setext (string-match-p "^[ \t]*$" text)) - (setq text (read-string "Header text: ")))) - (setq text (markdown-compress-whitespace-string text))) - ;; Insertion with given text - (markdown-ensure-blank-line-before) - (let (hdr) - (cond (setext - (setq hdr (make-string (string-width text) (if (= level 2) ?- ?=))) - (insert text "\n" hdr)) - (t - (setq hdr (make-string level ?#)) - (insert hdr " " text) - (when (null markdown-asymmetric-header) (insert " " hdr))))) - (markdown-ensure-blank-line-after) - ;; Leave point at end of text - (cond (setext - (backward-char (1+ (string-width text)))) - ((null markdown-asymmetric-header) - (backward-char (1+ level))))) - -(defun markdown-insert-header-dwim (&optional arg setext) - "Insert or replace header markup. -The level and type of the header are determined automatically by -the type and level of the previous header, unless a prefix -argument is given via ARG. -With a numeric prefix valued 1 to 6, insert a header of the given -level, with the type being determined automatically (note that -only level 1 or 2 setext headers are possible). - -With a \\[universal-argument] prefix (i.e., when ARG is (4)), -promote the heading by one level. -With two \\[universal-argument] prefixes (i.e., when ARG is (16)), -demote the heading by one level. -When SETEXT is non-nil, prefer setext-style headers when -possible (levels one and two). - -When there is an active region, use it for the header text. When -the point is at an existing header, change the type and level -according to the rules above. -Otherwise, if the line is not empty, create a header using the -text on the current line as the header text. -Finally, if the point is on a blank line, insert empty header -markup (atx) or prompt for text (setext). -See `markdown-insert-header' for more details about how the -header text is determined." - (interactive "*P") - (let (level) - (save-excursion - (when (or (thing-at-point-looking-at markdown-regex-header) - (re-search-backward markdown-regex-header nil t)) - ;; level of current or previous header - (setq level (markdown-outline-level)) - ;; match group 1 indicates a setext header - (setq setext (match-end 1)))) - ;; check prefix argument - (cond - ((and (equal arg '(4)) level (> level 1)) ;; C-u - (cl-decf level)) - ((and (equal arg '(16)) level (< level 6)) ;; C-u C-u - (cl-incf level)) - (arg ;; numeric prefix - (setq level (prefix-numeric-value arg)))) - ;; setext headers must be level one or two - (and level (setq setext (and setext (<= level 2)))) - ;; insert the heading - (markdown-insert-header level nil setext))) - -(defun markdown-insert-header-setext-dwim (&optional arg) - "Insert or replace header markup, with preference for setext. -See `markdown-insert-header-dwim' for details, including how ARG is handled." - (interactive "*P") - (markdown-insert-header-dwim arg t)) - -(defun markdown-insert-header-atx-1 () - "Insert a first level atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 1 nil nil)) - -(defun markdown-insert-header-atx-2 () - "Insert a level two atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 2 nil nil)) - -(defun markdown-insert-header-atx-3 () - "Insert a level three atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 3 nil nil)) - -(defun markdown-insert-header-atx-4 () - "Insert a level four atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 4 nil nil)) - -(defun markdown-insert-header-atx-5 () - "Insert a level five atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 5 nil nil)) - -(defun markdown-insert-header-atx-6 () - "Insert a sixth level atx-style (hash mark) header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 6 nil nil)) - -(defun markdown-insert-header-setext-1 () - "Insert a setext-style (underlined) first-level header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 1 nil t)) - -(defun markdown-insert-header-setext-2 () - "Insert a setext-style (underlined) second-level header. -See `markdown-insert-header'." - (interactive "*") - (markdown-insert-header 2 nil t)) - -(defun markdown-blockquote-indentation (loc) - "Return string containing necessary indentation for a blockquote at LOC. -Also see `markdown-pre-indentation'." - (save-excursion - (goto-char loc) - (let* ((list-level (length (markdown-calculate-list-levels))) - (indent "")) - (dotimes (_ list-level indent) - (setq indent (concat indent " ")))))) - -(defun markdown-insert-blockquote () - "Start a blockquote section (or blockquote the region). -If Transient Mark mode is on and a region is active, it is used as -the blockquote text." - (interactive) - (if (use-region-p) - (markdown-blockquote-region (region-beginning) (region-end)) - (markdown-ensure-blank-line-before) - (insert (markdown-blockquote-indentation (point)) "> ") - (markdown-ensure-blank-line-after))) - -(defun markdown-block-region (beg end prefix) - "Format the region using a block prefix. -Arguments BEG and END specify the beginning and end of the -region. The characters PREFIX will appear at the beginning -of each line." - (save-excursion - (let* ((end-marker (make-marker)) - (beg-marker (make-marker)) - (prefix-without-trailing-whitespace - (replace-regexp-in-string (rx (+ blank) eos) "" prefix))) - ;; Ensure blank line after and remove extra whitespace - (goto-char end) - (skip-syntax-backward "-") - (set-marker end-marker (point)) - (delete-horizontal-space) - (markdown-ensure-blank-line-after) - ;; Ensure blank line before and remove extra whitespace - (goto-char beg) - (skip-syntax-forward "-") - (delete-horizontal-space) - (markdown-ensure-blank-line-before) - (set-marker beg-marker (point)) - ;; Insert PREFIX before each line - (goto-char beg-marker) - (while (and (< (line-beginning-position) end-marker) - (not (eobp))) - ;; Don’t insert trailing whitespace. - (insert (if (eolp) prefix-without-trailing-whitespace prefix)) - (forward-line))))) - -(defun markdown-blockquote-region (beg end) - "Blockquote the region. -Arguments BEG and END specify the beginning and end of the region." - (interactive "*r") - (markdown-block-region - beg end (concat (markdown-blockquote-indentation - (max (point-min) (1- beg))) "> "))) - -(defun markdown-pre-indentation (loc) - "Return string containing necessary whitespace for a pre block at LOC. -Also see `markdown-blockquote-indentation'." - (save-excursion - (goto-char loc) - (let* ((list-level (length (markdown-calculate-list-levels))) - indent) - (dotimes (_ (1+ list-level) indent) - (setq indent (concat indent " ")))))) - -(defun markdown-insert-pre () - "Start a preformatted section (or apply to the region). -If Transient Mark mode is on and a region is active, it is marked -as preformatted text." - (interactive) - (if (use-region-p) - (markdown-pre-region (region-beginning) (region-end)) - (markdown-ensure-blank-line-before) - (insert (markdown-pre-indentation (point))) - (markdown-ensure-blank-line-after))) - -(defun markdown-pre-region (beg end) - "Format the region as preformatted text. -Arguments BEG and END specify the beginning and end of the region." - (interactive "*r") - (let ((indent (markdown-pre-indentation (max (point-min) (1- beg))))) - (markdown-block-region beg end indent))) - -(defun markdown-electric-backquote (arg) - "Insert a backquote. -The numeric prefix argument ARG says how many times to repeat the insertion. -Call `markdown-insert-gfm-code-block' interactively -if three backquotes inserted at the beginning of line." - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (when (and markdown-gfm-use-electric-backquote (looking-back "^```" nil)) - (replace-match "") - (call-interactively #'markdown-insert-gfm-code-block))) - -(defconst markdown-gfm-recognized-languages - ;; To reproduce/update, evaluate the let-form in - ;; scripts/get-recognized-gfm-languages.el. that produces a single long sexp, - ;; but with appropriate use of a keyboard macro, indenting and filling it - ;; properly is pretty fast. - '("1C-Enterprise" "2-Dimensional-Array" "4D" "ABAP" "ABAP-CDS" "ABNF" - "AGS-Script" "AIDL" "AL" "AMPL" "ANTLR" "API-Blueprint" "APL" "ASL" - "ASN.1" "ASP.NET" "ATS" "ActionScript" "Ada" "Adblock-Filter-List" - "Adobe-Font-Metrics" "Agda" "Alloy" "Alpine-Abuild" "Altium-Designer" - "AngelScript" "Ant-Build-System" "Antlers" "ApacheConf" "Apex" - "Apollo-Guidance-Computer" "AppleScript" "Arc" "AsciiDoc" "AspectJ" - "Assembly" "Astro" "Asymptote" "Augeas" "AutoHotkey" "AutoIt" - "Avro-IDL" "Awk" "BASIC" "Ballerina" "Batchfile" "Beef" "Befunge" - "Berry" "BibTeX" "Bicep" "Bikeshed" "Bison" "BitBake" "Blade" - "BlitzBasic" "BlitzMax" "Bluespec" "Bluespec-BH" "Boo" "Boogie" - "Brainfuck" "BrighterScript" "Brightscript" "Browserslist" "C" "C#" - "C++" "C-ObjDump" "C2hs-Haskell" "CAP-CDS" "CIL" "CLIPS" "CMake" - "COBOL" "CODEOWNERS" "COLLADA" "CSON" "CSS" "CSV" "CUE" "CWeb" - "Cabal-Config" "Cadence" "Cairo" "CameLIGO" "Cap'n-Proto" "CartoCSS" - "Ceylon" "Chapel" "Charity" "Checksums" "ChucK" "Circom" "Cirru" - "Clarion" "Clarity" "Classic-ASP" "Clean" "Click" "Clojure" - "Closure-Templates" "Cloud-Firestore-Security-Rules" "CoNLL-U" - "CodeQL" "CoffeeScript" "ColdFusion" "ColdFusion-CFC" "Common-Lisp" - "Common-Workflow-Language" "Component-Pascal" "Cool" "Coq" - "Cpp-ObjDump" "Creole" "Crystal" "Csound" "Csound-Document" - "Csound-Score" "Cuda" "Cue-Sheet" "Curry" "Cycript" "Cypher" "Cython" - "D" "D-ObjDump" "D2" "DIGITAL-Command-Language" "DM" "DNS-Zone" - "DTrace" "Dafny" "Darcs-Patch" "Dart" "DataWeave" - "Debian-Package-Control-File" "DenizenScript" "Dhall" "Diff" - "DirectX-3D-File" "Dockerfile" "Dogescript" "Dotenv" "Dylan" "E" - "E-mail" "EBNF" "ECL" "ECLiPSe" "EJS" "EQ" "Eagle" "Earthly" - "Easybuild" "Ecere-Projects" "Ecmarkup" "Edge" "EdgeQL" - "EditorConfig" "Edje-Data-Collection" "Eiffel" "Elixir" "Elm" - "Elvish" "Elvish-Transcript" "Emacs-Lisp" "EmberScript" "Erlang" - "Euphoria" "F#" "F*" "FIGlet-Font" "FLUX" "Factor" "Fancy" "Fantom" - "Faust" "Fennel" "Filebench-WML" "Filterscript" "Fluent" "Formatted" - "Forth" "Fortran" "Fortran-Free-Form" "FreeBasic" "FreeMarker" - "Frege" "Futhark" "G-code" "GAML" "GAMS" "GAP" - "GCC-Machine-Description" "GDB" "GDScript" "GEDCOM" "GLSL" "GN" "GSC" - "Game-Maker-Language" "Gemfile.lock" "Gemini" "Genero-4gl" - "Genero-per" "Genie" "Genshi" "Gentoo-Ebuild" "Gentoo-Eclass" - "Gerber-Image" "Gettext-Catalog" "Gherkin" "Git-Attributes" - "Git-Config" "Git-Revision-List" "Gleam" "Glimmer-JS" "Glimmer-TS" - "Glyph" "Glyph-Bitmap-Distribution-Format" "Gnuplot" "Go" - "Go-Checksums" "Go-Module" "Go-Workspace" "Godot-Resource" "Golo" - "Gosu" "Grace" "Gradle" "Gradle-Kotlin-DSL" "Grammatical-Framework" - "Graph-Modeling-Language" "GraphQL" "Graphviz-(DOT)" "Groovy" - "Groovy-Server-Pages" "HAProxy" "HCL" "HLSL" "HOCON" "HTML" - "HTML+ECR" "HTML+EEX" "HTML+ERB" "HTML+PHP" "HTML+Razor" "HTTP" - "HXML" "Hack" "Haml" "Handlebars" "Harbour" "Haskell" "Haxe" "HiveQL" - "HolyC" "Hosts-File" "Hy" "HyPhy" "IDL" "IGOR-Pro" "INI" "IRC-log" - "Idris" "Ignore-List" "ImageJ-Macro" "Imba" "Inform-7" "Ink" - "Inno-Setup" "Io" "Ioke" "Isabelle" "Isabelle-ROOT" "J" - "JAR-Manifest" "JCL" "JFlex" "JSON" "JSON-with-Comments" "JSON5" - "JSONLD" "JSONiq" "Janet" "Jasmin" "Java" "Java-Properties" - "Java-Server-Pages" "JavaScript" "JavaScript+ERB" "Jest-Snapshot" - "JetBrains-MPS" "Jinja" "Jison" "Jison-Lex" "Jolie" "Jsonnet" "Julia" - "Jupyter-Notebook" "Just" "KRL" "Kaitai-Struct" "KakouneScript" - "KerboScript" "KiCad-Layout" "KiCad-Legacy-Layout" "KiCad-Schematic" - "Kickstart" "Kit" "Kotlin" "Kusto" "LFE" "LLVM" "LOLCODE" "LSL" - "LTspice-Symbol" "LabVIEW" "Lark" "Lasso" "Latte" "Lean" "Lean-4" - "Less" "Lex" "LigoLANG" "LilyPond" "Limbo" "Linker-Script" - "Linux-Kernel-Module" "Liquid" "Literate-Agda" - "Literate-CoffeeScript" "Literate-Haskell" "LiveScript" "Logos" - "Logtalk" "LookML" "LoomScript" "Lua" "M" "M4" "M4Sugar" "MATLAB" - "MAXScript" "MDX" "MLIR" "MQL4" "MQL5" "MTML" "MUF" "Macaulay2" - "Makefile" "Mako" "Markdown" "Marko" "Mask" "Mathematica" "Maven-POM" - "Max" "Mercury" "Mermaid" "Meson" "Metal" - "Microsoft-Developer-Studio-Project" - "Microsoft-Visual-Studio-Solution" "MiniD" "MiniYAML" "Mint" "Mirah" - "Modelica" "Modula-2" "Modula-3" "Module-Management-System" "Mojo" - "Monkey" "Monkey-C" "Moocode" "MoonScript" "Motoko" - "Motorola-68K-Assembly" "Move" "Muse" "Mustache" "Myghty" "NASL" - "NCL" "NEON" "NL" "NPM-Config" "NSIS" "NWScript" "Nasal" "Nearley" - "Nemerle" "NetLinx" "NetLinx+ERB" "NetLogo" "NewLisp" "Nextflow" - "Nginx" "Nim" "Ninja" "Nit" "Nix" "Nu" "NumPy" "Nunjucks" "Nushell" - "OASv2-json" "OASv2-yaml" "OASv3-json" "OASv3-yaml" "OCaml" "Oberon" - "ObjDump" "Object-Data-Instance-Notation" "ObjectScript" - "Objective-C" "Objective-C++" "Objective-J" "Odin" "Omgrofl" "Opa" - "Opal" "Open-Policy-Agent" "OpenAPI-Specification-v2" - "OpenAPI-Specification-v3" "OpenCL" "OpenEdge-ABL" "OpenQASM" - "OpenRC-runscript" "OpenSCAD" "OpenStep-Property-List" - "OpenType-Feature-File" "Option-List" "Org" "Ox" "Oxygene" "Oz" "P4" - "PDDL" "PEG.js" "PHP" "PLSQL" "PLpgSQL" "POV-Ray-SDL" "Pact" "Pan" - "Papyrus" "Parrot" "Parrot-Assembly" "Parrot-Internal-Representation" - "Pascal" "Pawn" "Pep8" "Perl" "Pic" "Pickle" "PicoLisp" "PigLatin" - "Pike" "Pip-Requirements" "PlantUML" "Pod" "Pod-6" "PogoScript" - "Polar" "Pony" "Portugol" "PostCSS" "PostScript" "PowerBuilder" - "PowerShell" "Praat" "Prisma" "Processing" "Procfile" "Proguard" - "Prolog" "Promela" "Propeller-Spin" "Protocol-Buffer" - "Protocol-Buffer-Text-Format" "Public-Key" "Pug" "Puppet" "Pure-Data" - "PureBasic" "PureScript" "Pyret" "Python" "Python-console" - "Python-traceback" "Q#" "QML" "QMake" "Qt-Script" "Quake" "R" "RAML" - "RBS" "RDoc" "REALbasic" "REXX" "RMarkdown" "RPC" "RPGLE" "RPM-Spec" - "RUNOFF" "Racket" "Ragel" "Raku" "Rascal" "Raw-token-data" "ReScript" - "Readline-Config" "Reason" "ReasonLIGO" "Rebol" "Record-Jar" "Red" - "Redcode" "Redirect-Rules" "Regular-Expression" "Ren'Py" - "RenderScript" "Rez" "Rich-Text-Format" "Ring" "Riot" - "RobotFramework" "Roc" "Roff" "Roff-Manpage" "Rouge" - "RouterOS-Script" "Ruby" "Rust" "SAS" "SCSS" "SELinux-Policy" "SMT" - "SPARQL" "SQF" "SQL" "SQLPL" "SRecode-Template" "SSH-Config" "STAR" - "STL" "STON" "SVG" "SWIG" "Sage" "SaltStack" "Sass" "Scala" "Scaml" - "Scenic" "Scheme" "Scilab" "Self" "ShaderLab" "Shell" - "ShellCheck-Config" "ShellSession" "Shen" "Sieve" - "Simple-File-Verification" "Singularity" "Slash" "Slice" "Slim" - "Slint" "SmPL" "Smali" "Smalltalk" "Smarty" "Smithy" "Snakemake" - "Solidity" "Soong" "SourcePawn" "Spline-Font-Database" "Squirrel" - "Stan" "Standard-ML" "Starlark" "Stata" "StringTemplate" "Stylus" - "SubRip-Text" "SugarSS" "SuperCollider" "Svelte" "Sway" "Sweave" - "Swift" "SystemVerilog" "TI-Program" "TL-Verilog" "TLA" "TOML" "TSQL" - "TSV" "TSX" "TXL" "Talon" "Tcl" "Tcsh" "TeX" "Tea" "Terra" - "Terraform-Template" "Texinfo" "Text" "TextGrid" - "TextMate-Properties" "Textile" "Thrift" "Toit" "Turing" "Turtle" - "Twig" "Type-Language" "TypeScript" "Typst" "Unified-Parallel-C" - "Unity3D-Asset" "Unix-Assembly" "Uno" "UnrealScript" "UrWeb" "V" - "VBA" "VBScript" "VCL" "VHDL" "Vala" "Valve-Data-Format" - "Velocity-Template-Language" "Verilog" "Vim-Help-File" "Vim-Script" - "Vim-Snippet" "Visual-Basic-.NET" "Visual-Basic-6.0" "Volt" "Vue" - "Vyper" "WDL" "WGSL" "Wavefront-Material" "Wavefront-Object" - "Web-Ontology-Language" "WebAssembly" "WebAssembly-Interface-Type" - "WebIDL" "WebVTT" "Wget-Config" "Whiley" "Wikitext" - "Win32-Message-File" "Windows-Registry-Entries" "Witcher-Script" - "Wollok" "World-of-Warcraft-Addon-Data" "Wren" "X-BitMap" - "X-Font-Directory-Index" "X-PixMap" "X10" "XC" "XCompose" "XML" - "XML-Property-List" "XPages" "XProc" "XQuery" "XS" "XSLT" "Xojo" - "Xonsh" "Xtend" "YAML" "YANG" "YARA" "YASnippet" "Yacc" "Yul" "ZAP" - "ZIL" "Zeek" "ZenScript" "Zephir" "Zig" "Zimpl" "cURL-Config" - "desktop" "dircolors" "eC" "edn" "fish" "hoon" "jq" "kvlang" - "mIRC-Script" "mcfunction" "mupad" "nanorc" "nesC" "ooc" "q" - "reStructuredText" "robots.txt" "sed" "wisp" "xBase") - "Language specifiers recognized by GitHub's syntax highlighting features.") - -(defvar-local markdown-gfm-used-languages nil - "Language names used in GFM code blocks.") - -(defun markdown-trim-whitespace (str) - (replace-regexp-in-string - "\\(?:[[:space:]\r\n]+\\'\\|\\`[[:space:]\r\n]+\\)" "" str)) - -(defun markdown-clean-language-string (str) - (replace-regexp-in-string - "{\\.?\\|}" "" (markdown-trim-whitespace str))) - -(defun markdown-validate-language-string (widget) - (let ((str (widget-value widget))) - (unless (string= str (markdown-clean-language-string str)) - (widget-put widget :error (format "Invalid language spec: '%s'" str)) - widget))) - -(defun markdown-gfm-get-corpus () - "Create corpus of recognized GFM code block languages for the given buffer." - (let ((given-corpus (append markdown-gfm-additional-languages - markdown-gfm-recognized-languages))) - (append - markdown-gfm-used-languages - (if markdown-gfm-downcase-languages (cl-mapcar #'downcase given-corpus) - given-corpus)))) - -(defun markdown-gfm-add-used-language (lang) - "Clean LANG and add to list of used languages." - (setq markdown-gfm-used-languages - (cons lang (remove lang markdown-gfm-used-languages)))) - -(defcustom markdown-spaces-after-code-fence 1 - "Number of space characters to insert after a code fence. -\\<gfm-mode-map>\\[markdown-insert-gfm-code-block] inserts this many spaces between an -opening code fence and an info string." - :group 'markdown - :type 'integer - :safe #'natnump - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-code-block-braces nil - "When non-nil, automatically insert braces for GFM code blocks." - :group 'markdown - :type 'boolean) - -(defun markdown-insert-gfm-code-block (&optional lang edit) - "Insert GFM code block for language LANG. -If LANG is nil, the language will be queried from user. If a -region is active, wrap this region with the markup instead. If -the region boundaries are not on empty lines, these are added -automatically in order to have the correct markup. When EDIT is -non-nil (e.g., when \\[universal-argument] is given), edit the -code block in an indirect buffer after insertion." - (interactive - (list (let ((completion-ignore-case nil)) - (condition-case nil - (markdown-clean-language-string - (completing-read - "Programming language: " - (markdown-gfm-get-corpus) - nil 'confirm (car markdown-gfm-used-languages) - 'markdown-gfm-language-history)) - (quit ""))) - current-prefix-arg)) - (unless (string= lang "") (markdown-gfm-add-used-language lang)) - (when (and (> (length lang) 0) - (not markdown-code-block-braces)) - (setq lang (concat (make-string markdown-spaces-after-code-fence ?\s) - lang))) - (let ((gfm-open-brace (if markdown-code-block-braces "{" "")) - (gfm-close-brace (if markdown-code-block-braces "}" ""))) - (if (use-region-p) - (let* ((b (region-beginning)) (e (region-end)) end - (indent (progn (goto-char b) (current-indentation)))) - (goto-char e) - ;; if we're on a blank line, don't newline, otherwise the ``` - ;; should go on its own line - (unless (looking-back "\n" nil) - (newline)) - (indent-to indent) - (insert "```") - (markdown-ensure-blank-line-after) - (setq end (point)) - (goto-char b) - ;; if we're on a blank line, insert the quotes here, otherwise - ;; add a new line first - (unless (looking-at-p "\n") - (newline) - (forward-line -1)) - (markdown-ensure-blank-line-before) - (indent-to indent) - (insert "```" gfm-open-brace lang gfm-close-brace) - (markdown-syntax-propertize-fenced-block-constructs (line-beginning-position) end)) - (let ((indent (current-indentation)) - start-bol) - (delete-horizontal-space :backward-only) - (markdown-ensure-blank-line-before) - (indent-to indent) - (setq start-bol (line-beginning-position)) - (insert "```" gfm-open-brace lang gfm-close-brace "\n") - (indent-to indent) - (unless edit (insert ?\n)) - (indent-to indent) - (insert "```") - (markdown-ensure-blank-line-after) - (markdown-syntax-propertize-fenced-block-constructs start-bol (point))) - (end-of-line 0) - (when edit (markdown-edit-code-block))))) - -(defun markdown-code-block-lang (&optional pos-prop) - "Return the language name for a GFM or tilde fenced code block. -The beginning of the block may be described by POS-PROP, -a cons of (pos . prop) giving the position and property -at the beginning of the block." - (or pos-prop - (setq pos-prop - (markdown-max-of-seq - #'car - (cl-remove-if - #'null - (cl-mapcar - #'markdown-find-previous-prop - (markdown-get-fenced-block-begin-properties)))))) - (when pos-prop - (goto-char (car pos-prop)) - (set-match-data (get-text-property (point) (cdr pos-prop))) - ;; Note: Hard-coded group number assumes tilde - ;; and GFM fenced code regexp groups agree. - (let ((begin (match-beginning 3)) - (end (match-end 3))) - (when (and begin end) - ;; Fix language strings beginning with periods, like ".ruby". - (when (eq (char-after begin) ?.) - (setq begin (1+ begin))) - (buffer-substring-no-properties begin end))))) - -(defun markdown-gfm-parse-buffer-for-languages (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (save-excursion - (goto-char (point-min)) - (cl-loop - with prop = 'markdown-gfm-block-begin - for pos-prop = (markdown-find-next-prop prop) - while pos-prop - for lang = (markdown-code-block-lang pos-prop) - do (progn (when lang (markdown-gfm-add-used-language lang)) - (goto-char (next-single-property-change (point) prop))))))) - -(defun markdown-insert-foldable-block () - "Insert details disclosure element to make content foldable. -If a region is active, wrap this region with the disclosure -element. More details here https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details." - (interactive) - (let ((details-open-tag "<details>") - (details-close-tag "</details>") - (summary-open-tag "<summary>") - (summary-close-tag " </summary>")) - (if (use-region-p) - (let* ((b (region-beginning)) - (e (region-end)) - (indent (progn (goto-char b) (current-indentation)))) - (goto-char e) - ;; if we're on a blank line, don't newline, otherwise the tags - ;; should go on its own line - (unless (looking-back "\n" nil) - (newline)) - (indent-to indent) - (insert details-close-tag) - (markdown-ensure-blank-line-after) - (goto-char b) - ;; if we're on a blank line, insert the quotes here, otherwise - ;; add a new line first - (unless (looking-at-p "\n") - (newline) - (forward-line -1)) - (markdown-ensure-blank-line-before) - (indent-to indent) - (insert details-open-tag "\n") - (insert summary-open-tag summary-close-tag) - (search-backward summary-close-tag)) - (let ((indent (current-indentation))) - (delete-horizontal-space :backward-only) - (markdown-ensure-blank-line-before) - (indent-to indent) - (insert details-open-tag "\n") - (insert summary-open-tag summary-close-tag "\n") - (insert details-close-tag) - (indent-to indent) - (markdown-ensure-blank-line-after) - (search-backward summary-close-tag))))) - - -;;; Footnotes ================================================================= - -(defun markdown-footnote-counter-inc () - "Increment `markdown-footnote-counter' and return the new value." - (when (= markdown-footnote-counter 0) ; hasn't been updated in this buffer yet. - (save-excursion - (goto-char (point-min)) - (while (re-search-forward (concat "^\\[\\^\\(" markdown-footnote-chars "*?\\)\\]:") - (point-max) t) - (let ((fn (string-to-number (match-string 1)))) - (when (> fn markdown-footnote-counter) - (setq markdown-footnote-counter fn)))))) - (cl-incf markdown-footnote-counter)) - -(defun markdown-insert-footnote () - "Insert footnote with a new number and move point to footnote definition." - (interactive) - (let ((fn (markdown-footnote-counter-inc))) - (insert (format "[^%d]" fn)) - (push-mark (point) t) - (markdown-footnote-text-find-new-location) - (markdown-ensure-blank-line-before) - (unless (markdown-cur-line-blank-p) - (insert "\n")) - (insert (format "[^%d]: " fn)) - (markdown-ensure-blank-line-after))) - -(defun markdown-footnote-text-find-new-location () - "Position the point at the proper location for a new footnote text." - (cond - ((eq markdown-footnote-location 'end) (goto-char (point-max))) - ((eq markdown-footnote-location 'immediately) (markdown-end-of-text-block)) - ((eq markdown-footnote-location 'subtree) (markdown-end-of-subtree)) - ((eq markdown-footnote-location 'header) (markdown-end-of-defun)))) - -(defun markdown-footnote-kill () - "Kill the footnote at point. -The footnote text is killed (and added to the kill ring), the -footnote marker is deleted. Point has to be either at the -footnote marker or in the footnote text." - (interactive) - (let ((marker-pos nil) - (skip-deleting-marker nil) - (starting-footnote-text-positions - (markdown-footnote-text-positions))) - (when starting-footnote-text-positions - ;; We're starting in footnote text, so mark our return position and jump - ;; to the marker if possible. - (let ((marker-pos (markdown-footnote-find-marker - (cl-first starting-footnote-text-positions)))) - (if marker-pos - (goto-char (1- marker-pos)) - ;; If there isn't a marker, we still want to kill the text. - (setq skip-deleting-marker t)))) - ;; Either we didn't start in the text, or we started in the text and jumped - ;; to the marker. We want to assume we're at the marker now and error if - ;; we're not. - (unless skip-deleting-marker - (let ((marker (markdown-footnote-delete-marker))) - (unless marker - (error "Not at a footnote")) - ;; Even if we knew the text position before, it changed when we deleted - ;; the label. - (setq marker-pos (cl-second marker)) - (let ((new-text-pos (markdown-footnote-find-text (cl-first marker)))) - (unless new-text-pos - (error "No text for footnote `%s'" (cl-first marker))) - (goto-char new-text-pos)))) - (let ((pos (markdown-footnote-kill-text))) - (goto-char (if starting-footnote-text-positions - pos - marker-pos))))) - -(defun markdown-footnote-delete-marker () - "Delete a footnote marker at point. -Returns a list (ID START) containing the footnote ID and the -start position of the marker before deletion. If no footnote -marker was deleted, this function returns NIL." - (let ((marker (markdown-footnote-marker-positions))) - (when marker - (delete-region (cl-second marker) (cl-third marker)) - (butlast marker)))) - -(defun markdown-footnote-kill-text () - "Kill footnote text at point. -Returns the start position of the footnote text before deletion, -or NIL if point was not inside a footnote text. - -The killed text is placed in the kill ring (without the footnote -number)." - (let ((fn (markdown-footnote-text-positions))) - (when fn - (let ((text (delete-and-extract-region (cl-second fn) (cl-third fn)))) - (string-match (concat "\\[\\" (cl-first fn) "\\]:[[:space:]]*\\(\\(.*\n?\\)*\\)") text) - (kill-new (match-string 1 text)) - (when (and (markdown-cur-line-blank-p) - (markdown-prev-line-blank-p) - (not (bobp))) - (delete-region (1- (point)) (point))) - (cl-second fn))))) - -(defun markdown-footnote-goto-text () - "Jump to the text of the footnote at point." - (interactive) - (let ((fn (car (markdown-footnote-marker-positions)))) - (unless fn - (user-error "Not at a footnote marker")) - (let ((new-pos (markdown-footnote-find-text fn))) - (unless new-pos - (error "No definition found for footnote `%s'" fn)) - (goto-char new-pos)))) - -(defun markdown-footnote-return () - "Return from a footnote to its footnote number in the main text." - (interactive) - (let ((fn (save-excursion - (car (markdown-footnote-text-positions))))) - (unless fn - (user-error "Not in a footnote")) - (let ((new-pos (markdown-footnote-find-marker fn))) - (unless new-pos - (error "Footnote marker `%s' not found" fn)) - (goto-char new-pos)))) - -(defun markdown-footnote-find-marker (id) - "Find the location of the footnote marker with ID. -The actual buffer position returned is the position directly -following the marker's closing bracket. If no marker is found, -NIL is returned." - (save-excursion - (goto-char (point-min)) - (when (re-search-forward (concat "\\[" id "\\]\\([^:]\\|\\'\\)") nil t) - (skip-chars-backward "^]") - (point)))) - -(defun markdown-footnote-find-text (id) - "Find the location of the text of footnote ID. -The actual buffer position returned is the position of the first -character of the text, after the footnote's identifier. If no -footnote text is found, NIL is returned." - (save-excursion - (goto-char (point-min)) - (when (re-search-forward (concat "^ \\{0,3\\}\\[" id "\\]:") nil t) - (skip-chars-forward " \t") - (point)))) - -(defun markdown-footnote-marker-positions () - "Return the position and ID of the footnote marker point is on. -The return value is a list (ID START END). If point is not on a -footnote, NIL is returned." - ;; first make sure we're at a footnote marker - (if (or (looking-back (concat "\\[\\^" markdown-footnote-chars "*\\]?") (line-beginning-position)) - (looking-at-p (concat "\\[?\\^" markdown-footnote-chars "*?\\]"))) - (save-excursion - ;; move point between [ and ^: - (if (looking-at-p "\\[") - (forward-char 1) - (skip-chars-backward "^[")) - (looking-at (concat "\\(\\^" markdown-footnote-chars "*?\\)\\]")) - (list (match-string 1) (1- (match-beginning 1)) (1+ (match-end 1)))))) - -(defun markdown-footnote-text-positions () - "Return the start and end positions of the footnote text point is in. -The exact return value is a list of three elements: (ID START END). -The start position is the position of the opening bracket -of the footnote id. The end position is directly after the -newline that ends the footnote. If point is not in a footnote, -NIL is returned instead." - (save-excursion - (let (result) - (move-beginning-of-line 1) - ;; Try to find the label. If we haven't found the label and we're at a blank - ;; or indented line, back up if possible. - (while (and - (not (and (looking-at markdown-regex-footnote-definition) - (setq result (list (match-string 1) (point))))) - (and (not (bobp)) - (or (markdown-cur-line-blank-p) - (>= (current-indentation) 4)))) - (forward-line -1)) - (when result - ;; Advance if there is a next line that is either blank or indented. - ;; (Need to check if we're on the last line, because - ;; markdown-next-line-blank-p returns true for last line in buffer.) - (while (and (/= (line-end-position) (point-max)) - (or (markdown-next-line-blank-p) - (>= (markdown-next-line-indent) 4))) - (forward-line)) - ;; Move back while the current line is blank. - (while (markdown-cur-line-blank-p) - (forward-line -1)) - ;; Advance to capture this line and a single trailing newline (if there - ;; is one). - (forward-line) - (append result (list (point))))))) - -(defun markdown-get-defined-footnotes () - "Return a list of all defined footnotes. -Result is an alist of pairs (MARKER . LINE), where MARKER is the -footnote marker, a string, and LINE is the line number containing -the footnote definition. - -For example, suppose the following footnotes are defined at positions -448 and 475: - -\[^1]: First footnote here. -\[^marker]: Second footnote. - -Then the returned list is: ((\"^1\" . 478) (\"^marker\" . 475))" - (save-excursion - (goto-char (point-min)) - (let (footnotes) - (while (markdown-search-until-condition - (lambda () (and (not (markdown-code-block-at-point-p)) - (not (markdown-inline-code-at-point-p)) - (not (markdown-in-comment-p)))) - markdown-regex-footnote-definition nil t) - (let ((marker (match-string-no-properties 1)) - (pos (match-beginning 0))) - (unless (zerop (length marker)) - (cl-pushnew (cons marker pos) footnotes :test #'equal)))) - (reverse footnotes)))) - - -;;; Element Removal =========================================================== - -(defun markdown-kill-thing-at-point () - "Kill thing at point and add important text, without markup, to kill ring. -Possible things to kill include (roughly in order of precedence): -inline code, headers, horizontal rules, links (add link text to -kill ring), images (add alt text to kill ring), angle uri, email -addresses, bold, italics, reference definition (add URI to kill -ring), footnote markers and text (kill both marker and text, add -text to kill ring), and list items." - (interactive "*") - (let (val) - (cond - ;; Inline code - ((markdown-inline-code-at-point) - (kill-new (match-string 2)) - (delete-region (match-beginning 0) (match-end 0))) - ;; ATX header - ((thing-at-point-looking-at markdown-regex-header-atx) - (kill-new (match-string 2)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Setext header - ((thing-at-point-looking-at markdown-regex-header-setext) - (kill-new (match-string 1)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Horizontal rule - ((thing-at-point-looking-at markdown-regex-hr) - (kill-new (match-string 0)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Inline link or image (add link or alt text to kill ring) - ((thing-at-point-looking-at markdown-regex-link-inline) - (kill-new (match-string 3)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Reference link or image (add link or alt text to kill ring) - ((thing-at-point-looking-at markdown-regex-link-reference) - (kill-new (match-string 3)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Angle URI (add URL to kill ring) - ((thing-at-point-looking-at markdown-regex-angle-uri) - (kill-new (match-string 2)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Email address in angle brackets (add email address to kill ring) - ((thing-at-point-looking-at markdown-regex-email) - (kill-new (match-string 1)) - (delete-region (match-beginning 0) (match-end 0))) - ;; Wiki link (add alias text to kill ring) - ((and markdown-enable-wiki-links - (thing-at-point-looking-at markdown-regex-wiki-link)) - (kill-new (markdown-wiki-link-alias)) - (delete-region (match-beginning 1) (match-end 1))) - ;; Bold - ((thing-at-point-looking-at markdown-regex-bold) - (kill-new (match-string 4)) - (delete-region (match-beginning 2) (match-end 2))) - ;; Italics - ((thing-at-point-looking-at markdown-regex-italic) - (kill-new (match-string 3)) - (delete-region (match-beginning 1) (match-end 1))) - ;; Strikethrough - ((thing-at-point-looking-at markdown-regex-strike-through) - (kill-new (match-string 4)) - (delete-region (match-beginning 2) (match-end 2))) - ;; Footnote marker (add footnote text to kill ring) - ((thing-at-point-looking-at markdown-regex-footnote) - (markdown-footnote-kill)) - ;; Footnote text (add footnote text to kill ring) - ((setq val (markdown-footnote-text-positions)) - (markdown-footnote-kill)) - ;; Reference definition (add URL to kill ring) - ((thing-at-point-looking-at markdown-regex-reference-definition) - (kill-new (match-string 5)) - (delete-region (match-beginning 0) (match-end 0))) - ;; List item - ((setq val (markdown-cur-list-item-bounds)) - (kill-new (delete-and-extract-region (cl-first val) (cl-second val)))) - (t - (user-error "Nothing found at point to kill"))))) - -(defun markdown-kill-outline () - "Kill visible heading and add it to `kill-ring'." - (interactive) - (save-excursion - (markdown-outline-previous) - (kill-region (point) (progn (markdown-outline-next) (point))))) - -(defun markdown-kill-block () - "Kill visible code block, list item, or blockquote and add it to `kill-ring'." - (interactive) - (save-excursion - (markdown-backward-block) - (kill-region (point) (progn (markdown-forward-block) (point))))) - - -;;; Indentation =============================================================== - -(defun markdown-indent-find-next-position (cur-pos positions) - "Return the position after the index of CUR-POS in POSITIONS. -Positions are calculated by `markdown-calc-indents'." - (while (and positions - (not (equal cur-pos (car positions)))) - (setq positions (cdr positions))) - (or (cadr positions) 0)) - -(defun markdown-outdent-find-next-position (cur-pos positions) - "Return the maximal element that precedes CUR-POS from POSITIONS. -Positions are calculated by `markdown-calc-indents'." - (let ((result 0)) - (dolist (i positions) - (when (< i cur-pos) - (setq result (max result i)))) - result)) - -(defun markdown-indent-line () - "Indent the current line using some heuristics. -If the _previous_ command was either `markdown-enter-key' or -`markdown-cycle', then we should cycle to the next -reasonable indentation position. Otherwise, we could have been -called directly by `markdown-enter-key', by an initial call of -`markdown-cycle', or indirectly by `auto-fill-mode'. In -these cases, indent to the default position. -Positions are calculated by `markdown-calc-indents'." - (interactive) - (let ((positions (markdown-calc-indents)) - (point-pos (current-column)) - (_ (back-to-indentation)) - (cur-pos (current-column))) - (if (not (equal this-command 'markdown-cycle)) - (indent-line-to (car positions)) - (setq positions (sort (delete-dups positions) '<)) - (let* ((next-pos (markdown-indent-find-next-position cur-pos positions)) - (new-point-pos (max (+ point-pos (- next-pos cur-pos)) 0))) - (indent-line-to next-pos) - (move-to-column new-point-pos))))) - -(defun markdown-calc-indents () - "Return a list of indentation columns to cycle through. -The first element in the returned list should be considered the -default indentation level. This function does not worry about -duplicate positions, which are handled up by calling functions." - (let (pos prev-line-pos positions) - - ;; Indentation of previous line - (setq prev-line-pos (markdown-prev-line-indent)) - (setq positions (cons prev-line-pos positions)) - - ;; Indentation of previous non-list-marker text - (when (setq pos (save-excursion - (forward-line -1) - (when (looking-at markdown-regex-list) - (- (match-end 3) (match-beginning 0))))) - (setq positions (cons pos positions))) - - ;; Indentation required for a pre block in current context - (setq pos (length (markdown-pre-indentation (point)))) - (setq positions (cons pos positions)) - - ;; Indentation of the previous line + tab-width - (if prev-line-pos - (setq positions (cons (+ prev-line-pos tab-width) positions)) - (setq positions (cons tab-width positions))) - - ;; Indentation of the previous line - tab-width - (if (and prev-line-pos (> prev-line-pos tab-width)) - (setq positions (cons (- prev-line-pos tab-width) positions))) - - ;; Indentation of all preceding list markers (when in a list) - (when (setq pos (markdown-calculate-list-levels)) - (setq positions (append pos positions))) - - ;; First column - (setq positions (cons 0 positions)) - - ;; Return reversed list - (reverse positions))) - -(defun markdown-enter-key () ;FIXME: Partly obsoleted by electric-indent - "Handle RET depending on the context. -If the point is at a table, move to the next row. Otherwise, -indent according to value of `markdown-indent-on-enter'. -When it is nil, simply call `newline'. Otherwise, indent the next line -following RET using `markdown-indent-line'. Furthermore, when it -is set to \\='indent-and-new-item and the point is in a list item, -start a new item with the same indentation. If the point is in an -empty list item, remove it (so that pressing RET twice when in a -list simply adds a blank line)." - (interactive) - (cond - ;; Table - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-next-row)) - ;; Indent non-table text - (markdown-indent-on-enter - (let (bounds) - (if (and (memq markdown-indent-on-enter '(indent-and-new-item)) - (setq bounds (markdown-cur-list-item-bounds))) - (let ((beg (cl-first bounds)) - (end (cl-second bounds)) - (nonlist-indent (cl-fourth bounds)) - (checkbox (cl-sixth bounds))) - ;; Point is in a list item - (if (= (- end beg) (+ nonlist-indent (length checkbox))) - ;; Delete blank list - (progn - (delete-region beg end) - (newline) - (markdown-indent-line)) - (call-interactively #'markdown-insert-list-item))) - ;; Point is not in a list - (newline) - (markdown-indent-line)))) - ;; Insert a raw newline - (t (newline)))) - -(defun markdown-outdent-or-delete (arg) - "Handle BACKSPACE by cycling through indentation points. -When BACKSPACE is pressed, if there is only whitespace -before the current point, then outdent the line one level. -Otherwise, do normal delete by repeating -`backward-delete-char-untabify' ARG times." - (interactive "*p") - (if (use-region-p) - (backward-delete-char-untabify arg) - (let ((cur-pos (current-column)) - (start-of-indention (save-excursion - (back-to-indentation) - (current-column))) - (positions (markdown-calc-indents))) - (if (and (> cur-pos 0) (= cur-pos start-of-indention)) - (indent-line-to (markdown-outdent-find-next-position cur-pos positions)) - (backward-delete-char-untabify arg))))) - -(defun markdown-find-leftmost-column (beg end) - "Find the leftmost column in the region from BEG to END." - (let ((mincol 1000)) - (save-excursion - (goto-char beg) - (while (< (point) end) - (back-to-indentation) - (unless (looking-at-p "[ \t]*$") - (setq mincol (min mincol (current-column)))) - (forward-line 1) - )) - mincol)) - -(defun markdown-indent-region (beg end arg) - "Indent the region from BEG to END using some heuristics. -When ARG is non-nil, outdent the region instead. -See `markdown-indent-line' and `markdown-indent-line'." - (interactive "*r\nP") - (let* ((positions (sort (delete-dups (markdown-calc-indents)) '<)) - (leftmostcol (markdown-find-leftmost-column beg end)) - (next-pos (if arg - (markdown-outdent-find-next-position leftmostcol positions) - (markdown-indent-find-next-position leftmostcol positions)))) - (indent-rigidly beg end (- next-pos leftmostcol)) - (setq deactivate-mark nil))) - -(defun markdown-outdent-region (beg end) - "Call `markdown-indent-region' on region from BEG to END with prefix." - (interactive "*r") - (markdown-indent-region beg end t)) - -(defun markdown--indent-region (start end) - (let ((deactivate-mark nil)) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (when (bolp) - (forward-line 1)) - (while (< (point) end) - (unless (or (markdown-code-block-at-point-p) (and (bolp) (eolp))) - (indent-according-to-mode)) - (forward-line 1)) - (move-marker end nil)))) - - -;;; Markup Completion ========================================================= - -(defconst markdown-complete-alist - '((markdown-regex-header-atx . markdown-complete-atx) - (markdown-regex-header-setext . markdown-complete-setext) - (markdown-regex-hr . markdown-complete-hr)) - "Association list of form (regexp . function) for markup completion.") - -(defun markdown-incomplete-atx-p () - "Return t if ATX header markup is incomplete and nil otherwise. -Assumes match data is available for `markdown-regex-header-atx'. -Checks that the number of trailing hash marks equals the number of leading -hash marks, that there is only a single space before and after the text, -and that there is no extraneous whitespace in the text." - (or - ;; Number of starting and ending hash marks differs - (not (= (length (match-string 1)) (length (match-string 3)))) - ;; When the header text is not empty... - (and (> (length (match-string 2)) 0) - ;; ...if there are extra leading, trailing, or interior spaces - (or (not (= (match-beginning 2) (1+ (match-end 1)))) - (not (= (match-beginning 3) (1+ (match-end 2)))) - (string-match-p "[ \t\n]\\{2\\}" (match-string 2)))) - ;; When the header text is empty... - (and (= (length (match-string 2)) 0) - ;; ...if there are too many or too few spaces - (not (= (match-beginning 3) (+ (match-end 1) 2)))))) - -(defun markdown-complete-atx () - "Complete and normalize ATX headers. -Add or remove hash marks to the end of the header to match the -beginning. Ensure that there is only a single space between hash -marks and header text. Removes extraneous whitespace from header text. -Assumes match data is available for `markdown-regex-header-atx'. -Return nil if markup was complete and non-nil if markup was completed." - (when (markdown-incomplete-atx-p) - (let* ((new-marker (make-marker)) - (new-marker (set-marker new-marker (match-end 2)))) - ;; Hash marks and spacing at end - (goto-char (match-end 2)) - (delete-region (match-end 2) (match-end 3)) - (insert " " (match-string 1)) - ;; Remove extraneous whitespace from title - (replace-match (markdown-compress-whitespace-string (match-string 2)) - t t nil 2) - ;; Spacing at beginning - (goto-char (match-end 1)) - (delete-region (match-end 1) (match-beginning 2)) - (insert " ") - ;; Leave point at end of text - (goto-char new-marker)))) - -(defun markdown-incomplete-setext-p () - "Return t if setext header markup is incomplete and nil otherwise. -Assumes match data is available for `markdown-regex-header-setext'. -Checks that length of underline matches text and that there is no -extraneous whitespace in the text." - (or (not (= (length (match-string 1)) (length (match-string 2)))) - (string-match-p "[ \t\n]\\{2\\}" (match-string 1)))) - -(defun markdown-complete-setext () - "Complete and normalize setext headers. -Add or remove underline characters to match length of header -text. Removes extraneous whitespace from header text. Assumes -match data is available for `markdown-regex-header-setext'. -Return nil if markup was complete and non-nil if markup was completed." - (when (markdown-incomplete-setext-p) - (let* ((text (markdown-compress-whitespace-string (match-string 1))) - (char (char-after (match-beginning 2))) - (level (if (char-equal char ?-) 2 1))) - (goto-char (match-beginning 0)) - (delete-region (match-beginning 0) (match-end 0)) - (markdown-insert-header level text t) - t))) - -(defun markdown-incomplete-hr-p () - "Return non-nil if hr is not in `markdown-hr-strings' and nil otherwise. -Assumes match data is available for `markdown-regex-hr'." - (not (member (match-string 0) markdown-hr-strings))) - -(defun markdown-complete-hr () - "Complete horizontal rules. -If horizontal rule string is a member of `markdown-hr-strings', -do nothing. Otherwise, replace with the car of -`markdown-hr-strings'. -Assumes match data is available for `markdown-regex-hr'. -Return nil if markup was complete and non-nil if markup was completed." - (when (markdown-incomplete-hr-p) - (replace-match (car markdown-hr-strings)) - t)) - -(defun markdown-complete () - "Complete markup of object near point or in region when active. -Handle all objects in `markdown-complete-alist', in order. -See `markdown-complete-at-point' and `markdown-complete-region'." - (interactive "*") - (if (use-region-p) - (markdown-complete-region (region-beginning) (region-end)) - (markdown-complete-at-point))) - -(defun markdown-complete-at-point () - "Complete markup of object near point. -Handle all elements of `markdown-complete-alist' in order." - (interactive "*") - (let ((list markdown-complete-alist) found changed) - (while list - (let ((regexp (eval (caar list) t)) ;FIXME: Why `eval'? - (function (cdar list))) - (setq list (cdr list)) - (when (thing-at-point-looking-at regexp) - (setq found t) - (setq changed (funcall function)) - (setq list nil)))) - (if found - (or changed (user-error "Markup at point is complete")) - (user-error "Nothing to complete at point")))) - -(defun markdown-complete-region (beg end) - "Complete markup of objects in region from BEG to END. -Handle all objects in `markdown-complete-alist', in order. Each -match is checked to ensure that a previous regexp does not also -match." - (interactive "*r") - (let ((end-marker (set-marker (make-marker) end)) - previous) - (dolist (element markdown-complete-alist) - (let ((regexp (eval (car element) t)) ;FIXME: Why `eval'? - (function (cdr element))) - (goto-char beg) - (while (re-search-forward regexp end-marker 'limit) - (when (match-string 0) - ;; Make sure this is not a match for any of the preceding regexps. - ;; This prevents mistaking an HR for a Setext subheading. - (let (match) - (save-match-data - (dolist (prev-regexp previous) - (or match (setq match (looking-back prev-regexp nil))))) - (unless match - (save-excursion (funcall function)))))) - (cl-pushnew regexp previous :test #'equal))) - previous)) - -(defun markdown-complete-buffer () - "Complete markup for all objects in the current buffer." - (interactive "*") - (markdown-complete-region (point-min) (point-max))) - - -;;; Markup Cycling ============================================================ - -(defun markdown-cycle-atx (arg &optional remove) - "Cycle ATX header markup. -Promote header (decrease level) when ARG is 1 and demote -header (increase level) if arg is -1. When REMOVE is non-nil, -remove the header when the level reaches zero and stop cycling -when it reaches six. Otherwise, perform a proper cycling through -levels one through six. Assumes match data is available for -`markdown-regex-header-atx'." - (let* ((old-level (length (match-string 1))) - (new-level (+ old-level arg)) - (text (match-string 2))) - (when (not remove) - (setq new-level (% new-level 6)) - (setq new-level (cond ((= new-level 0) 6) - ((< new-level 0) (+ new-level 6)) - (t new-level)))) - (cond - ((= new-level 0) - (markdown-unwrap-thing-at-point nil 0 2)) - ((<= new-level 6) - (goto-char (match-beginning 0)) - (delete-region (match-beginning 0) (match-end 0)) - (markdown-insert-header new-level text nil))))) - -(defun markdown-cycle-setext (arg &optional remove) - "Cycle setext header markup. -Promote header (increase level) when ARG is 1 and demote -header (decrease level or remove) if arg is -1. When demoting a -level-two setext header, replace with a level-three atx header. -When REMOVE is non-nil, remove the header when the level reaches -zero. Otherwise, cycle back to a level six atx header. Assumes -match data is available for `markdown-regex-header-setext'." - (let* ((char (char-after (match-beginning 2))) - (old-level (if (char-equal char ?=) 1 2)) - (new-level (+ old-level arg))) - (when (and (not remove) (= new-level 0)) - (setq new-level 6)) - (cond - ((= new-level 0) - (markdown-unwrap-thing-at-point nil 0 1)) - ((<= new-level 2) - (markdown-insert-header new-level nil t)) - ((<= new-level 6) - (markdown-insert-header new-level nil nil))))) - -(defun markdown-cycle-hr (arg &optional remove) - "Cycle string used for horizontal rule from `markdown-hr-strings'. -When ARG is 1, cycle forward (demote), and when ARG is -1, cycle -backwards (promote). When REMOVE is non-nil, remove the hr instead -of cycling when the end of the list is reached. -Assumes match data is available for `markdown-regex-hr'." - (let* ((strings (if (= arg -1) - (reverse markdown-hr-strings) - markdown-hr-strings)) - (tail (member (match-string 0) strings)) - (new (or (cadr tail) - (if remove - (if (= arg 1) - "" - (car tail)) - (car strings))))) - (replace-match new))) - -(defun markdown-cycle-bold () - "Cycle bold markup between underscores and asterisks. -Assumes match data is available for `markdown-regex-bold'." - (save-excursion - (let* ((old-delim (match-string 3)) - (new-delim (if (string-equal old-delim "**") "__" "**"))) - (replace-match new-delim t t nil 3) - (replace-match new-delim t t nil 5)))) - -(defun markdown-cycle-italic () - "Cycle italic markup between underscores and asterisks. -Assumes match data is available for `markdown-regex-italic'." - (save-excursion - (let* ((old-delim (match-string 2)) - (new-delim (if (string-equal old-delim "*") "_" "*"))) - (replace-match new-delim t t nil 2) - (replace-match new-delim t t nil 4)))) - - -;;; Keymap ==================================================================== - -(defun markdown--style-map-prompt () - "Return a formatted prompt for Markdown markup insertion." - (when markdown-enable-prefix-prompts - (concat - "Markdown: " - (propertize "bold" 'face 'markdown-bold-face) ", " - (propertize "italic" 'face 'markdown-italic-face) ", " - (propertize "code" 'face 'markdown-inline-code-face) ", " - (propertize "C = GFM code" 'face 'markdown-code-face) ", " - (propertize "pre" 'face 'markdown-pre-face) ", " - (propertize "footnote" 'face 'markdown-footnote-text-face) ", " - (propertize "F = foldable" 'face 'markdown-bold-face) ", " - (propertize "q = blockquote" 'face 'markdown-blockquote-face) ", " - (propertize "h & 1-6 = heading" 'face 'markdown-header-face) ", " - (propertize "- = hr" 'face 'markdown-hr-face) ", " - "C-h = more"))) - -(defun markdown--command-map-prompt () - "Return prompt for Markdown buffer-wide commands." - (when markdown-enable-prefix-prompts - (concat - "Command: " - (propertize "m" 'face 'markdown-bold-face) "arkdown, " - (propertize "p" 'face 'markdown-bold-face) "review, " - (propertize "o" 'face 'markdown-bold-face) "pen, " - (propertize "e" 'face 'markdown-bold-face) "xport, " - "export & pre" (propertize "v" 'face 'markdown-bold-face) "iew, " - (propertize "c" 'face 'markdown-bold-face) "heck refs, " - (propertize "u" 'face 'markdown-bold-face) "nused refs, " - "C-h = more"))) - -(defvar markdown-mode-style-map - (let ((map (make-keymap (markdown--style-map-prompt)))) - (define-key map (kbd "1") 'markdown-insert-header-atx-1) - (define-key map (kbd "2") 'markdown-insert-header-atx-2) - (define-key map (kbd "3") 'markdown-insert-header-atx-3) - (define-key map (kbd "4") 'markdown-insert-header-atx-4) - (define-key map (kbd "5") 'markdown-insert-header-atx-5) - (define-key map (kbd "6") 'markdown-insert-header-atx-6) - (define-key map (kbd "!") 'markdown-insert-header-setext-1) - (define-key map (kbd "@") 'markdown-insert-header-setext-2) - (define-key map (kbd "b") 'markdown-insert-bold) - (define-key map (kbd "c") 'markdown-insert-code) - (define-key map (kbd "C") 'markdown-insert-gfm-code-block) - (define-key map (kbd "f") 'markdown-insert-footnote) - (define-key map (kbd "F") 'markdown-insert-foldable-block) - (define-key map (kbd "h") 'markdown-insert-header-dwim) - (define-key map (kbd "H") 'markdown-insert-header-setext-dwim) - (define-key map (kbd "i") 'markdown-insert-italic) - (define-key map (kbd "k") 'markdown-insert-kbd) - (define-key map (kbd "l") 'markdown-insert-link) - (define-key map (kbd "p") 'markdown-insert-pre) - (define-key map (kbd "P") 'markdown-pre-region) - (define-key map (kbd "q") 'markdown-insert-blockquote) - (define-key map (kbd "s") 'markdown-insert-strike-through) - (define-key map (kbd "t") 'markdown-insert-table) - (define-key map (kbd "Q") 'markdown-blockquote-region) - (define-key map (kbd "w") 'markdown-insert-wiki-link) - (define-key map (kbd "-") 'markdown-insert-hr) - (define-key map (kbd "[") 'markdown-insert-gfm-checkbox) - ;; Deprecated keys that may be removed in a future version - (define-key map (kbd "e") 'markdown-insert-italic) - map) - "Keymap for Markdown text styling commands.") - -(defvar markdown-mode-command-map - (let ((map (make-keymap (markdown--command-map-prompt)))) - (define-key map (kbd "m") 'markdown-other-window) - (define-key map (kbd "p") 'markdown-preview) - (define-key map (kbd "e") 'markdown-export) - (define-key map (kbd "v") 'markdown-export-and-preview) - (define-key map (kbd "o") 'markdown-open) - (define-key map (kbd "l") 'markdown-live-preview-mode) - (define-key map (kbd "w") 'markdown-kill-ring-save) - (define-key map (kbd "c") 'markdown-check-refs) - (define-key map (kbd "u") 'markdown-unused-refs) - (define-key map (kbd "n") 'markdown-cleanup-list-numbers) - (define-key map (kbd "]") 'markdown-complete-buffer) - (define-key map (kbd "^") 'markdown-table-sort-lines) - (define-key map (kbd "|") 'markdown-table-convert-region) - (define-key map (kbd "t") 'markdown-table-transpose) - map) - "Keymap for Markdown buffer-wide commands.") - -(defvar markdown-mode-map - (let ((map (make-keymap))) - ;; Markup insertion & removal - (define-key map (kbd "C-c C-s") markdown-mode-style-map) - (define-key map (kbd "C-c C-l") 'markdown-insert-link) - (define-key map (kbd "C-c C-k") 'markdown-kill-thing-at-point) - ;; Promotion, demotion, and cycling - (define-key map (kbd "C-c C--") 'markdown-promote) - (define-key map (kbd "C-c C-=") 'markdown-demote) - (define-key map (kbd "C-c C-]") 'markdown-complete) - ;; Following and doing things - (define-key map (kbd "C-c C-o") 'markdown-follow-thing-at-point) - (define-key map (kbd "C-c C-d") 'markdown-do) - (define-key map (kbd "C-c '") 'markdown-edit-code-block) - ;; Indentation - (define-key map (kbd "RET") 'markdown-enter-key) - (define-key map (kbd "DEL") 'markdown-outdent-or-delete) - (define-key map (kbd "C-c >") 'markdown-indent-region) - (define-key map (kbd "C-c <") 'markdown-outdent-region) - ;; Visibility cycling - (define-key map (kbd "TAB") 'markdown-cycle) - ;; S-iso-lefttab and S-tab should both be mapped to `backtab' by - ;; (local-)function-key-map. - ;;(define-key map (kbd "<S-iso-lefttab>") 'markdown-shifttab) - ;;(define-key map (kbd "<S-tab>") 'markdown-shifttab) - (define-key map (kbd "<backtab>") 'markdown-shifttab) - ;; Heading and list navigation - (define-key map (kbd "C-c C-n") 'markdown-outline-next) - (define-key map (kbd "C-c C-p") 'markdown-outline-previous) - (define-key map (kbd "C-c C-f") 'markdown-outline-next-same-level) - (define-key map (kbd "C-c C-b") 'markdown-outline-previous-same-level) - (define-key map (kbd "C-c C-u") 'markdown-outline-up) - ;; Buffer-wide commands - (define-key map (kbd "C-c C-c") markdown-mode-command-map) - ;; Subtree, list, and table editing - (define-key map (kbd "C-c <up>") 'markdown-move-up) - (define-key map (kbd "C-c <down>") 'markdown-move-down) - (define-key map (kbd "C-c <left>") 'markdown-promote) - (define-key map (kbd "C-c <right>") 'markdown-demote) - (define-key map (kbd "C-c S-<up>") 'markdown-table-delete-row) - (define-key map (kbd "C-c S-<down>") 'markdown-table-insert-row) - (define-key map (kbd "C-c S-<left>") 'markdown-table-delete-column) - (define-key map (kbd "C-c S-<right>") 'markdown-table-insert-column) - (define-key map (kbd "C-c C-M-h") 'markdown-mark-subtree) - (define-key map (kbd "C-x n s") 'markdown-narrow-to-subtree) - (define-key map (kbd "M-RET") 'markdown-insert-list-item) - (define-key map (kbd "C-c C-j") 'markdown-insert-list-item) - ;; Lines - (define-key map [remap move-beginning-of-line] 'markdown-beginning-of-line) - (define-key map [remap move-end-of-line] 'markdown-end-of-line) - ;; Paragraphs (Markdown context aware) - (define-key map [remap backward-paragraph] 'markdown-backward-paragraph) - (define-key map [remap forward-paragraph] 'markdown-forward-paragraph) - (define-key map [remap mark-paragraph] 'markdown-mark-paragraph) - ;; Blocks (one or more paragraphs) - (define-key map (kbd "C-M-{") 'markdown-backward-block) - (define-key map (kbd "C-M-}") 'markdown-forward-block) - (define-key map (kbd "C-c M-h") 'markdown-mark-block) - (define-key map (kbd "C-x n b") 'markdown-narrow-to-block) - ;; Pages (top-level sections) - (define-key map [remap backward-page] 'markdown-backward-page) - (define-key map [remap forward-page] 'markdown-forward-page) - (define-key map [remap mark-page] 'markdown-mark-page) - (define-key map [remap narrow-to-page] 'markdown-narrow-to-page) - ;; Link Movement - (define-key map (kbd "M-n") 'markdown-next-link) - (define-key map (kbd "M-p") 'markdown-previous-link) - ;; Toggling functionality - (define-key map (kbd "C-c C-x C-e") 'markdown-toggle-math) - (define-key map (kbd "C-c C-x C-f") 'markdown-toggle-fontify-code-blocks-natively) - (define-key map (kbd "C-c C-x C-i") 'markdown-toggle-inline-images) - (define-key map (kbd "C-c C-x C-l") 'markdown-toggle-url-hiding) - (define-key map (kbd "C-c C-x C-m") 'markdown-toggle-markup-hiding) - ;; Alternative keys (in case of problems with the arrow keys) - (define-key map (kbd "C-c C-x u") 'markdown-move-up) - (define-key map (kbd "C-c C-x d") 'markdown-move-down) - (define-key map (kbd "C-c C-x l") 'markdown-promote) - (define-key map (kbd "C-c C-x r") 'markdown-demote) - ;; Deprecated keys that may be removed in a future version - (define-key map (kbd "C-c C-a L") 'markdown-insert-link) ;; C-c C-l - (define-key map (kbd "C-c C-a l") 'markdown-insert-link) ;; C-c C-l - (define-key map (kbd "C-c C-a r") 'markdown-insert-link) ;; C-c C-l - (define-key map (kbd "C-c C-a u") 'markdown-insert-uri) ;; C-c C-l - (define-key map (kbd "C-c C-a f") 'markdown-insert-footnote) - (define-key map (kbd "C-c C-a w") 'markdown-insert-wiki-link) - (define-key map (kbd "C-c C-t 1") 'markdown-insert-header-atx-1) - (define-key map (kbd "C-c C-t 2") 'markdown-insert-header-atx-2) - (define-key map (kbd "C-c C-t 3") 'markdown-insert-header-atx-3) - (define-key map (kbd "C-c C-t 4") 'markdown-insert-header-atx-4) - (define-key map (kbd "C-c C-t 5") 'markdown-insert-header-atx-5) - (define-key map (kbd "C-c C-t 6") 'markdown-insert-header-atx-6) - (define-key map (kbd "C-c C-t !") 'markdown-insert-header-setext-1) - (define-key map (kbd "C-c C-t @") 'markdown-insert-header-setext-2) - (define-key map (kbd "C-c C-t h") 'markdown-insert-header-dwim) - (define-key map (kbd "C-c C-t H") 'markdown-insert-header-setext-dwim) - (define-key map (kbd "C-c C-t s") 'markdown-insert-header-setext-2) - (define-key map (kbd "C-c C-t t") 'markdown-insert-header-setext-1) - (define-key map (kbd "C-c C-i") 'markdown-insert-image) - (define-key map (kbd "C-c C-x m") 'markdown-insert-list-item) ;; C-c C-j - (define-key map (kbd "C-c C-x C-x") 'markdown-toggle-gfm-checkbox) ;; C-c C-d - (define-key map (kbd "C-c -") 'markdown-insert-hr) - map) - "Keymap for Markdown major mode.") - -(defvar markdown-mode-mouse-map - (when markdown-mouse-follow-link - (let ((map (make-sparse-keymap))) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'markdown-follow-thing-at-point) - map)) - "Keymap for following links with mouse.") - -(defvar gfm-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map markdown-mode-map) - (define-key map (kbd "C-c C-s d") 'markdown-insert-strike-through) - (define-key map "`" 'markdown-electric-backquote) - map) - "Keymap for `gfm-mode'. -See also `markdown-mode-map'.") - - -;;; Menu ====================================================================== - -(easy-menu-define markdown-mode-menu markdown-mode-map - "Menu for Markdown mode." - '("Markdown" - "---" - ("Movement" - ["Jump" markdown-do] - ["Follow Link" markdown-follow-thing-at-point] - ["Next Link" markdown-next-link] - ["Previous Link" markdown-previous-link] - "---" - ["Next Heading or List Item" markdown-outline-next] - ["Previous Heading or List Item" markdown-outline-previous] - ["Next at Same Level" markdown-outline-next-same-level] - ["Previous at Same Level" markdown-outline-previous-same-level] - ["Up to Parent" markdown-outline-up] - "---" - ["Forward Paragraph" markdown-forward-paragraph] - ["Backward Paragraph" markdown-backward-paragraph] - ["Forward Block" markdown-forward-block] - ["Backward Block" markdown-backward-block]) - ("Show & Hide" - ["Cycle Heading Visibility" markdown-cycle - :enable (markdown-on-heading-p)] - ["Cycle Heading Visibility (Global)" markdown-shifttab] - "---" - ["Narrow to Region" narrow-to-region] - ["Narrow to Block" markdown-narrow-to-block] - ["Narrow to Section" narrow-to-defun] - ["Narrow to Subtree" markdown-narrow-to-subtree] - ["Widen" widen (buffer-narrowed-p)] - "---" - ["Toggle Markup Hiding" markdown-toggle-markup-hiding - :keys "C-c C-x C-m" - :style radio - :selected markdown-hide-markup]) - "---" - ("Headings & Structure" - ["Automatic Heading" markdown-insert-header-dwim - :keys "C-c C-s h"] - ["Automatic Heading (Setext)" markdown-insert-header-setext-dwim - :keys "C-c C-s H"] - ("Specific Heading (atx)" - ["First Level atx" markdown-insert-header-atx-1 - :keys "C-c C-s 1"] - ["Second Level atx" markdown-insert-header-atx-2 - :keys "C-c C-s 2"] - ["Third Level atx" markdown-insert-header-atx-3 - :keys "C-c C-s 3"] - ["Fourth Level atx" markdown-insert-header-atx-4 - :keys "C-c C-s 4"] - ["Fifth Level atx" markdown-insert-header-atx-5 - :keys "C-c C-s 5"] - ["Sixth Level atx" markdown-insert-header-atx-6 - :keys "C-c C-s 6"]) - ("Specific Heading (Setext)" - ["First Level Setext" markdown-insert-header-setext-1 - :keys "C-c C-s !"] - ["Second Level Setext" markdown-insert-header-setext-2 - :keys "C-c C-s @"]) - ["Horizontal Rule" markdown-insert-hr - :keys "C-c C-s -"] - "---" - ["Move Subtree Up" markdown-move-up - :keys "C-c <up>"] - ["Move Subtree Down" markdown-move-down - :keys "C-c <down>"] - ["Promote Subtree" markdown-promote - :keys "C-c <left>"] - ["Demote Subtree" markdown-demote - :keys "C-c <right>"]) - ("Region & Mark" - ["Indent Region" markdown-indent-region] - ["Outdent Region" markdown-outdent-region] - "--" - ["Mark Paragraph" mark-paragraph] - ["Mark Block" markdown-mark-block] - ["Mark Section" mark-defun] - ["Mark Subtree" markdown-mark-subtree]) - ("Tables" - ["Move Row Up" markdown-move-up - :enable (markdown-table-at-point-p) - :keys "C-c <up>"] - ["Move Row Down" markdown-move-down - :enable (markdown-table-at-point-p) - :keys "C-c <down>"] - ["Move Column Left" markdown-promote - :enable (markdown-table-at-point-p) - :keys "C-c <left>"] - ["Move Column Right" markdown-demote - :enable (markdown-table-at-point-p) - :keys "C-c <right>"] - ["Delete Row" markdown-table-delete-row - :enable (markdown-table-at-point-p)] - ["Insert Row" markdown-table-insert-row - :enable (markdown-table-at-point-p)] - ["Delete Column" markdown-table-delete-column - :enable (markdown-table-at-point-p)] - ["Insert Column" markdown-table-insert-column - :enable (markdown-table-at-point-p)] - ["Insert Table" markdown-insert-table] - "--" - ["Convert Region to Table" markdown-table-convert-region] - ["Sort Table Lines" markdown-table-sort-lines - :enable (markdown-table-at-point-p)] - ["Transpose Table" markdown-table-transpose - :enable (markdown-table-at-point-p)]) - ("Lists" - ["Insert List Item" markdown-insert-list-item] - ["Move Subtree Up" markdown-move-up - :keys "C-c <up>"] - ["Move Subtree Down" markdown-move-down - :keys "C-c <down>"] - ["Indent Subtree" markdown-demote - :keys "C-c <right>"] - ["Outdent Subtree" markdown-promote - :keys "C-c <left>"] - ["Renumber List" markdown-cleanup-list-numbers] - ["Insert Task List Item" markdown-insert-gfm-checkbox - :keys "C-c C-x ["] - ["Toggle Task List Item" markdown-toggle-gfm-checkbox - :enable (markdown-gfm-task-list-item-at-point) - :keys "C-c C-d"]) - ("Links & Images" - ["Insert Link" markdown-insert-link] - ["Insert Image" markdown-insert-image] - ["Insert Footnote" markdown-insert-footnote - :keys "C-c C-s f"] - ["Insert Wiki Link" markdown-insert-wiki-link - :keys "C-c C-s w"] - "---" - ["Check References" markdown-check-refs] - ["Find Unused References" markdown-unused-refs] - ["Toggle URL Hiding" markdown-toggle-url-hiding - :style radio - :selected markdown-hide-urls] - ["Toggle Inline Images" markdown-toggle-inline-images - :keys "C-c C-x C-i" - :style radio - :selected markdown-inline-image-overlays] - ["Toggle Wiki Links" markdown-toggle-wiki-links - :style radio - :selected markdown-enable-wiki-links]) - ("Styles" - ["Bold" markdown-insert-bold] - ["Italic" markdown-insert-italic] - ["Code" markdown-insert-code] - ["Strikethrough" markdown-insert-strike-through] - ["Keyboard" markdown-insert-kbd] - "---" - ["Blockquote" markdown-insert-blockquote] - ["Preformatted" markdown-insert-pre] - ["GFM Code Block" markdown-insert-gfm-code-block] - ["Edit Code Block" markdown-edit-code-block - :enable (markdown-code-block-at-point-p)] - ["Foldable Block" markdown-insert-foldable-block] - "---" - ["Blockquote Region" markdown-blockquote-region] - ["Preformatted Region" markdown-pre-region] - "---" - ["Fontify Code Blocks Natively" - markdown-toggle-fontify-code-blocks-natively - :style radio - :selected markdown-fontify-code-blocks-natively] - ["LaTeX Math Support" markdown-toggle-math - :style radio - :selected markdown-enable-math]) - "---" - ("Preview & Export" - ["Compile" markdown-other-window] - ["Preview" markdown-preview] - ["Export" markdown-export] - ["Export & View" markdown-export-and-preview] - ["Open" markdown-open] - ["Live Export" markdown-live-preview-mode - :style radio - :selected markdown-live-preview-mode] - ["Kill ring save" markdown-kill-ring-save]) - ("Markup Completion and Cycling" - ["Complete Markup" markdown-complete] - ["Promote Element" markdown-promote - :keys "C-c C--"] - ["Demote Element" markdown-demote - :keys "C-c C-="]) - "---" - ["Kill Element" markdown-kill-thing-at-point] - "---" - ("Documentation" - ["Version" markdown-show-version] - ["Homepage" markdown-mode-info] - ["Describe Mode" (describe-function 'markdown-mode)] - ["Guide" (browse-url "https://leanpub.com/markdown-mode")]))) - - -;;; imenu ===================================================================== - -(defun markdown-imenu-create-nested-index () - "Create and return a nested imenu index alist for the current buffer. -See `imenu-create-index-function' and `imenu--index-alist' for details." - (let* ((root (list nil)) - (min-level 9999) - hashes headers) - (save-excursion - ;; Headings - (goto-char (point-min)) - (while (re-search-forward markdown-regex-header (point-max) t) - (unless (or (markdown-code-block-at-point-p) - (and (match-beginning 3) - (get-text-property (match-beginning 3) 'markdown-yaml-metadata-end))) - (cond - ((match-string-no-properties 2) ;; level 1 setext - (setq min-level 1) - (push (list :heading (match-string-no-properties 1) - :point (match-beginning 1) - :level 1) headers)) - ((match-string-no-properties 3) ;; level 2 setext - (setq min-level (min min-level 2)) - (push (list :heading (match-string-no-properties 1) - :point (match-beginning 1) - :level (- 2 (1- min-level))) headers)) - ((setq hashes (markdown-trim-whitespace - (match-string-no-properties 4))) - (setq min-level (min min-level (length hashes))) - (push (list :heading (match-string-no-properties 5) - :point (match-beginning 4) - :level (- (length hashes) (1- min-level))) headers))))) - (cl-loop with cur-level = 0 - with cur-alist = nil - with empty-heading = "-" - with self-heading = "." - for header in (reverse headers) - for level = (plist-get header :level) - do - (let ((alist (list (cons (plist-get header :heading) (plist-get header :point))))) - (cond - ((= cur-level level) ; new sibling - (setcdr cur-alist alist) - (setq cur-alist alist)) - ((< cur-level level) ; first child - (dotimes (_ (- level cur-level 1)) - (setq alist (list (cons empty-heading alist)))) - (if cur-alist - (let* ((parent (car cur-alist)) - (self-pos (cdr parent))) - (setcdr parent (cons (cons self-heading self-pos) alist))) - (setcdr root alist)) ; primogenitor - (setq cur-alist alist) - (setq cur-level level)) - (t ; new sibling of an ancestor - (let ((sibling-alist (last (cdr root)))) - (dotimes (_ (1- level)) - (setq sibling-alist (last (cdar sibling-alist)))) - (setcdr sibling-alist alist) - (setq cur-alist alist)) - (setq cur-level level))))) - (setq root (copy-tree root)) - ;; Footnotes - (let ((fn (markdown-get-defined-footnotes))) - (if (or (zerop (length fn)) - (null markdown-add-footnotes-to-imenu)) - (cdr root) - (nconc (cdr root) (list (cons "Footnotes" fn)))))))) - -(defun markdown-imenu-create-flat-index () - "Create and return a flat imenu index alist for the current buffer. -See `imenu-create-index-function' and `imenu--index-alist' for details." - (let* ((empty-heading "-") index heading pos) - (save-excursion - ;; Headings - (goto-char (point-min)) - (while (re-search-forward markdown-regex-header (point-max) t) - (when (and (not (markdown-code-block-at-point-p (line-beginning-position))) - (not (markdown-text-property-at-point 'markdown-yaml-metadata-begin))) - (cond - ((setq heading (match-string-no-properties 1)) - (setq pos (match-beginning 1))) - ((setq heading (match-string-no-properties 5)) - (setq pos (match-beginning 4)))) - (or (> (length heading) 0) - (setq heading empty-heading)) - (setq index (append index (list (cons heading pos)))))) - ;; Footnotes - (when markdown-add-footnotes-to-imenu - (nconc index (markdown-get-defined-footnotes))) - index))) - - -;;; References ================================================================ - -(defun markdown-reference-goto-definition () - "Jump to the definition of the reference at point or create it." - (interactive) - (when (thing-at-point-looking-at markdown-regex-link-reference) - (let* ((text (match-string-no-properties 3)) - (reference (match-string-no-properties 6)) - (target (downcase (if (string= reference "") text reference))) - (loc (cadr (save-match-data (markdown-reference-definition target))))) - (if loc - (goto-char loc) - (goto-char (match-beginning 0)) - (markdown-insert-reference-definition target))))) - -(defun markdown-reference-find-links (reference) - "Return a list of all links for REFERENCE. -REFERENCE should not include the surrounding square brackets. -Elements of the list have the form (text start line), where -text is the link text, start is the location at the beginning of -the link, and line is the line number on which the link appears." - (let* ((ref-quote (regexp-quote reference)) - (regexp (format "!?\\(?:\\[\\(%s\\)\\][ ]?\\[\\]\\|\\[\\([^]]+?\\)\\][ ]?\\[%s\\]\\)" - ref-quote ref-quote)) - links) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((text (or (match-string-no-properties 1) - (match-string-no-properties 2))) - (start (match-beginning 0)) - (line (markdown-line-number-at-pos))) - (cl-pushnew (list text start line) links :test #'equal)))) - links)) - -(defmacro markdown-for-all-refs (f) - `(let ((result)) - (save-excursion - (goto-char (point-min)) - (while - (re-search-forward markdown-regex-link-reference nil t) - (let* ((text (match-string-no-properties 3)) - (reference (match-string-no-properties 6)) - (target (downcase (if (string= reference "") text reference)))) - (,f text target result)))) - (reverse result))) - -(defmacro markdown-collect-always (_ target result) - `(cl-pushnew ,target ,result :test #'equal)) - -(defmacro markdown-collect-undefined (text target result) - `(unless (markdown-reference-definition target) - (let ((entry (assoc ,target ,result))) - (if (not entry) - (cl-pushnew - (cons ,target (list (cons ,text (markdown-line-number-at-pos)))) - ,result :test #'equal) - (setcdr entry - (append (cdr entry) (list (cons ,text (markdown-line-number-at-pos))))))))) - -(defun markdown-get-all-refs () - "Return a list of all Markdown references." - (markdown-for-all-refs markdown-collect-always)) - -(defun markdown-get-undefined-refs () - "Return a list of undefined Markdown references. -Result is an alist of pairs (reference . occurrences), where -occurrences is itself another alist of pairs (label . line-number). -For example, an alist corresponding to [Nice editor][Emacs] at line 12, -\[GNU Emacs][Emacs] at line 45 and [manual][elisp] at line 127 is -\((\"emacs\" (\"Nice editor\" . 12) (\"GNU Emacs\" . 45)) (\"elisp\" (\"manual\" . 127)))." - (markdown-for-all-refs markdown-collect-undefined)) - -(defun markdown-get-unused-refs () - (cl-sort - (cl-set-difference - (markdown-get-defined-references) (markdown-get-all-refs) - :test (lambda (e1 e2) (equal (car e1) e2))) - #'< :key #'cdr)) - -(defmacro defun-markdown-buffer (name docstring) - "Define a function to name and return a buffer. - -By convention, NAME must be a name of a string constant with -%buffer% placeholder used to name the buffer, and will also be -used as a name of the function defined. - -DOCSTRING will be used as the first part of the docstring." - `(defun ,name (&optional buffer-name) - ,(concat docstring "\n\nBUFFER-NAME is the name of the main buffer being visited.") - (or buffer-name (setq buffer-name (buffer-name))) - (let ((refbuf (get-buffer-create (replace-regexp-in-string - "%buffer%" buffer-name - ,name)))) - (with-current-buffer refbuf - (when view-mode - (View-exit-and-edit)) - (use-local-map button-buffer-map) - (erase-buffer)) - refbuf))) - -(defconst markdown-reference-check-buffer - "*Undefined references for %buffer%*" - "Pattern for name of buffer for listing undefined references. -The string %buffer% will be replaced by the corresponding -`markdown-mode' buffer name.") - -(defun-markdown-buffer - markdown-reference-check-buffer - "Name and return buffer for reference checking.") - -(defconst markdown-unused-references-buffer - "*Unused references for %buffer%*" - "Pattern for name of buffer for listing unused references. -The string %buffer% will be replaced by the corresponding -`markdown-mode' buffer name.") - -(defun-markdown-buffer - markdown-unused-references-buffer - "Name and return buffer for unused reference checking.") - -(defconst markdown-reference-links-buffer - "*Reference links for %buffer%*" - "Pattern for name of buffer for listing references. -The string %buffer% will be replaced by the corresponding buffer name.") - -(defun-markdown-buffer - markdown-reference-links-buffer - "Name, setup, and return a buffer for listing links.") - -;; Add an empty Markdown reference definition to buffer -;; specified in the 'target-buffer property. The reference name is -;; the button's label. -(define-button-type 'markdown-undefined-reference-button - 'help-echo "mouse-1, RET: create definition for undefined reference" - 'follow-link t - 'face 'bold - 'action (lambda (b) - (let ((buffer (button-get b 'target-buffer)) - (line (button-get b 'target-line)) - (label (button-label b))) - (switch-to-buffer-other-window buffer) - (goto-char (point-min)) - (forward-line line) - (markdown-insert-reference-definition label) - (markdown-check-refs t)))) - -;; Jump to line in buffer specified by 'target-buffer property. -;; Line number is button's 'target-line property. -(define-button-type 'markdown-goto-line-button - 'help-echo "mouse-1, RET: go to line" - 'follow-link t - 'face 'italic - 'action (lambda (b) - (switch-to-buffer-other-window (button-get b 'target-buffer)) - ;; use call-interactively to silence compiler - (let ((current-prefix-arg (button-get b 'target-line))) - (call-interactively 'goto-line)))) - -;; Kill a line in buffer specified by 'target-buffer property. -;; Line number is button's 'target-line property. -(define-button-type 'markdown-kill-line-button - 'help-echo "mouse-1, RET: kill line" - 'follow-link t - 'face 'italic - 'action (lambda (b) - (switch-to-buffer-other-window (button-get b 'target-buffer)) - ;; use call-interactively to silence compiler - (let ((current-prefix-arg (button-get b 'target-line))) - (call-interactively 'goto-line)) - (kill-line 1) - (markdown-unused-refs t))) - -;; Jumps to a particular link at location given by 'target-char -;; property in buffer given by 'target-buffer property. -(define-button-type 'markdown-location-button - 'help-echo "mouse-1, RET: jump to location of link" - 'follow-link t - 'face 'bold - 'action (lambda (b) - (let ((target (button-get b 'target-buffer)) - (loc (button-get b 'target-char))) - (kill-buffer-and-window) - (switch-to-buffer target) - (goto-char loc)))) - -(defun markdown-insert-undefined-reference-button (reference oldbuf) - "Insert a button for creating REFERENCE in buffer OLDBUF. -REFERENCE should be a list of the form (reference . occurrences), -as returned by `markdown-get-undefined-refs'." - (let ((label (car reference))) - ;; Create a reference button - (insert-button label - :type 'markdown-undefined-reference-button - 'target-buffer oldbuf - 'target-line (cdr (car (cdr reference)))) - (insert " (") - (dolist (occurrence (cdr reference)) - (let ((line (cdr occurrence))) - ;; Create a line number button - (insert-button (number-to-string line) - :type 'markdown-goto-line-button - 'target-buffer oldbuf - 'target-line line) - (insert " "))) - (delete-char -1) - (insert ")") - (newline))) - -(defun markdown-insert-unused-reference-button (reference oldbuf) - "Insert a button for creating REFERENCE in buffer OLDBUF. -REFERENCE must be a pair of (ref . line-number)." - (let ((label (car reference)) - (line (cdr reference))) - ;; Create a reference button - (insert-button label - :type 'markdown-goto-line-button - 'face 'bold - 'target-buffer oldbuf - 'target-line line) - (insert (format " (%d) [" line)) - (insert-button "X" - :type 'markdown-kill-line-button - 'face 'bold - 'target-buffer oldbuf - 'target-line line) - (insert "]") - (newline))) - -(defun markdown-insert-link-button (link oldbuf) - "Insert a button for jumping to LINK in buffer OLDBUF. -LINK should be a list of the form (text char line) containing -the link text, location, and line number." - (let ((label (cl-first link)) - (char (cl-second link)) - (line (cl-third link))) - ;; Create a reference button - (insert-button label - :type 'markdown-location-button - 'target-buffer oldbuf - 'target-char char) - (insert (format " (line %d)\n" line)))) - -(defun markdown-reference-goto-link (&optional reference) - "Jump to the location of the first use of REFERENCE." - (interactive) - (unless reference - (if (thing-at-point-looking-at markdown-regex-reference-definition) - (setq reference (match-string-no-properties 2)) - (user-error "No reference definition at point"))) - (let ((links (markdown-reference-find-links reference))) - (cond ((= (length links) 1) - (goto-char (cadr (car links)))) - ((> (length links) 1) - (let ((oldbuf (current-buffer)) - (linkbuf (markdown-reference-links-buffer))) - (with-current-buffer linkbuf - (insert "Links using reference " reference ":\n\n") - (dolist (link (reverse links)) - (markdown-insert-link-button link oldbuf))) - (view-buffer-other-window linkbuf) - (goto-char (point-min)) - (forward-line 2))) - (t - (error "No links for reference %s" reference))))) - -(defmacro defun-markdown-ref-checker - (name docstring checker-function buffer-function none-message buffer-header insert-reference) - "Define a function NAME acting on result of CHECKER-FUNCTION. - -DOCSTRING is used as a docstring for the defined function. - -BUFFER-FUNCTION should name and return an auxiliary buffer to put -results in. - -NONE-MESSAGE is used when CHECKER-FUNCTION returns no results. - -BUFFER-HEADER is put into the auxiliary buffer first, followed by -calling INSERT-REFERENCE for each element in the list returned by -CHECKER-FUNCTION." - `(defun ,name (&optional silent) - ,(concat - docstring - "\n\nIf SILENT is non-nil, do not message anything when no -such references found.") - (interactive "P") - (unless (derived-mode-p 'markdown-mode) - (user-error "Not available in current mode")) - (let ((oldbuf (current-buffer)) - (refs (,checker-function)) - (refbuf (,buffer-function))) - (if (null refs) - (progn - (when (not silent) - (message ,none-message)) - (kill-buffer refbuf)) - (with-current-buffer refbuf - (insert ,buffer-header) - (dolist (ref refs) - (,insert-reference ref oldbuf)) - (view-buffer-other-window refbuf) - (goto-char (point-min)) - (forward-line 2)))))) - -(defun-markdown-ref-checker - markdown-check-refs - "Show all undefined Markdown references in current `markdown-mode' buffer. - -Links which have empty reference definitions are considered to be -defined." - markdown-get-undefined-refs - markdown-reference-check-buffer - "No undefined references found" - "The following references are undefined:\n\n" - markdown-insert-undefined-reference-button) - - -(defun-markdown-ref-checker - markdown-unused-refs - "Show all unused Markdown references in current `markdown-mode' buffer." - markdown-get-unused-refs - markdown-unused-references-buffer - "No unused references found" - "The following references are unused:\n\n" - markdown-insert-unused-reference-button) - - - -;;; Lists ===================================================================== - -(defun markdown-insert-list-item (&optional arg) - "Insert a new list item. -If the point is inside unordered list, insert a bullet mark. If -the point is inside ordered list, insert the next number followed -by a period. Use the previous list item to determine the amount -of whitespace to place before and after list markers. - -With a \\[universal-argument] prefix (i.e., when ARG is (4)), -decrease the indentation by one level. - -With two \\[universal-argument] prefixes (i.e., when ARG is (16)), -increase the indentation by one level." - (interactive "p") - (let (bounds cur-indent marker indent new-indent new-loc) - (save-match-data - ;; Look for a list item on current or previous non-blank line - (save-excursion - (while (and (not (setq bounds (markdown-cur-list-item-bounds))) - (not (bobp)) - (markdown-cur-line-blank-p)) - (forward-line -1))) - (when bounds - (cond ((save-excursion - (skip-chars-backward " \t") - (looking-at-p markdown-regex-list)) - (beginning-of-line) - (insert "\n") - (forward-line -1)) - ((not (markdown-cur-line-blank-p)) - (newline))) - (setq new-loc (point))) - ;; Look ahead for a list item on next non-blank line - (unless bounds - (save-excursion - (while (and (null bounds) - (not (eobp)) - (markdown-cur-line-blank-p)) - (forward-line) - (setq bounds (markdown-cur-list-item-bounds)))) - (when bounds - (setq new-loc (point)) - (unless (markdown-cur-line-blank-p) - (newline)))) - (if (not bounds) - ;; When not in a list, start a new unordered one - (progn - (unless (markdown-cur-line-blank-p) - (insert "\n")) - (insert markdown-unordered-list-item-prefix)) - ;; Compute indentation and marker for new list item - (setq cur-indent (nth 2 bounds)) - (setq marker (nth 4 bounds)) - ;; If current item is a GFM checkbox, insert new unchecked checkbox. - (when (nth 5 bounds) - (setq marker - (concat marker - (replace-regexp-in-string "[Xx]" " " (nth 5 bounds))))) - (cond - ;; Dedent: decrement indentation, find previous marker. - ((= arg 4) - (setq indent (max (- cur-indent markdown-list-indent-width) 0)) - (let ((prev-bounds - (save-excursion - (goto-char (nth 0 bounds)) - (when (markdown-up-list) - (markdown-cur-list-item-bounds))))) - (when prev-bounds - (setq marker (nth 4 prev-bounds))))) - ;; Indent: increment indentation by 4, use same marker. - ((= arg 16) (setq indent (+ cur-indent markdown-list-indent-width))) - ;; Same level: keep current indentation and marker. - (t (setq indent cur-indent))) - (setq new-indent (make-string indent 32)) - (goto-char new-loc) - (cond - ;; Ordered list - ((string-match-p "[0-9]" marker) - (if (= arg 16) ;; starting a new column indented one more level - (insert (concat new-indent "1. ")) - ;; Don't use previous match-data - (set-match-data nil) - ;; travel up to the last item and pick the correct number. If - ;; the argument was nil, "new-indent = cur-indent" is the same, - ;; so we don't need special treatment. Neat. - (save-excursion - (while (and (not (looking-at (concat new-indent "\\([0-9]+\\)\\(\\.[ \t]*\\)"))) - (>= (forward-line -1) 0)))) - (let* ((old-prefix (match-string 1)) - (old-spacing (match-string 2)) - (new-prefix (if (and old-prefix markdown-ordered-list-enumeration) - (int-to-string (1+ (string-to-number old-prefix))) - "1")) - (space-adjust (- (length old-prefix) (length new-prefix))) - (new-spacing (if (and (match-string 2) - (not (string-match-p "\t" old-spacing)) - (< space-adjust 0) - (> space-adjust (- 1 (length (match-string 2))))) - (substring (match-string 2) 0 space-adjust) - (or old-spacing ". ")))) - (insert (concat new-indent new-prefix new-spacing))))) - ;; Unordered list, GFM task list, or ordered list with hash mark - ((string-match-p "[\\*\\+-]\\|#\\." marker) - (insert new-indent marker)))) - ;; Propertize the newly inserted list item now - (markdown-syntax-propertize-list-items (line-beginning-position) (line-end-position))))) - -(defun markdown-move-list-item-up () - "Move the current list item up in the list when possible. -In nested lists, move child items with the parent item." - (interactive) - (let (cur prev old) - (when (setq cur (markdown-cur-list-item-bounds)) - (setq old (point)) - (goto-char (nth 0 cur)) - (if (markdown-prev-list-item (nth 3 cur)) - (progn - (setq prev (markdown-cur-list-item-bounds)) - (condition-case nil - (progn - (transpose-regions (nth 0 prev) (nth 1 prev) - (nth 0 cur) (nth 1 cur) t) - (goto-char (+ (nth 0 prev) (- old (nth 0 cur))))) - ;; Catch error in case regions overlap. - (error (goto-char old)))) - (goto-char old))))) - -(defun markdown-move-list-item-down () - "Move the current list item down in the list when possible. -In nested lists, move child items with the parent item." - (interactive) - (let (cur next old) - (when (setq cur (markdown-cur-list-item-bounds)) - (setq old (point)) - (if (markdown-next-list-item (nth 3 cur)) - (progn - (setq next (markdown-cur-list-item-bounds)) - (condition-case nil - (progn - (transpose-regions (nth 0 cur) (nth 1 cur) - (nth 0 next) (nth 1 next) nil) - (goto-char (+ old (- (nth 1 next) (nth 1 cur))))) - ;; Catch error in case regions overlap. - (error (goto-char old)))) - (goto-char old))))) - -(defun markdown-demote-list-item (&optional bounds) - "Indent (or demote) the current list item. -Optionally, BOUNDS of the current list item may be provided if available. -In nested lists, demote child items as well." - (interactive) - (when (or bounds (setq bounds (markdown-cur-list-item-bounds))) - (save-excursion - (let* ((item-start (set-marker (make-marker) (nth 0 bounds))) - (item-end (set-marker (make-marker) (nth 1 bounds))) - (list-start (progn (markdown-beginning-of-list) - (set-marker (make-marker) (point)))) - (list-end (progn (markdown-end-of-list) - (set-marker (make-marker) (point))))) - (goto-char item-start) - (while (< (point) item-end) - (unless (markdown-cur-line-blank-p) - (insert (make-string markdown-list-indent-width ? ))) - (forward-line)) - (markdown-syntax-propertize-list-items list-start list-end))))) - -(defun markdown-promote-list-item (&optional bounds) - "Unindent (or promote) the current list item. -Optionally, BOUNDS of the current list item may be provided if available. -In nested lists, demote child items as well." - (interactive) - (when (or bounds (setq bounds (markdown-cur-list-item-bounds))) - (save-excursion - (save-match-data - (let ((item-start (set-marker (make-marker) (nth 0 bounds))) - (item-end (set-marker (make-marker) (nth 1 bounds))) - (list-start (progn (markdown-beginning-of-list) - (set-marker (make-marker) (point)))) - (list-end (progn (markdown-end-of-list) - (set-marker (make-marker) (point)))) - num regexp) - (goto-char item-start) - (when (looking-at (format "^[ ]\\{1,%d\\}" - markdown-list-indent-width)) - (setq num (- (match-end 0) (match-beginning 0))) - (setq regexp (format "^[ ]\\{1,%d\\}" num)) - (while (and (< (point) item-end) - (re-search-forward regexp item-end t)) - (replace-match "" nil nil) - (forward-line)) - (markdown-syntax-propertize-list-items list-start list-end))))))) - -(defun markdown-cleanup-list-numbers-level (&optional pfx prev-item) - "Update the numbering for level PFX (as a string of spaces) and PREV-ITEM. -PREV-ITEM is width of previous-indentation and list number - -Assume that the previously found match was for a numbered item in -a list." - (let ((cpfx pfx) - (cur-item nil) - (idx 0) - (continue t) - (step t) - (sep nil)) - (while (and continue (not (eobp))) - (setq step t) - (cond - ((looking-at "^\\(\\([\s-]*\\)[0-9]+\\)\\. ") - (setq cpfx (match-string-no-properties 2)) - (setq cur-item (match-string-no-properties 1)) ;; indentation and list marker - (cond - ((or (= (length cpfx) (length pfx)) - (= (length cur-item) (length prev-item))) - (save-excursion - (replace-match - (if (not markdown-ordered-list-enumeration) - (concat pfx "1. ") - (cl-incf idx) - (concat pfx (number-to-string idx) ". ")))) - (setq sep nil)) - ;; indented a level - ((< (length pfx) (length cpfx)) - (setq sep (markdown-cleanup-list-numbers-level cpfx cur-item)) - (setq step nil)) - ;; exit the loop - (t - (setq step nil) - (setq continue nil)))) - - ((looking-at "^\\([\s-]*\\)[^ \t\n\r].*$") - (setq cpfx (match-string-no-properties 1)) - (cond - ;; reset if separated before - ((string= cpfx pfx) (when sep (setq idx 0))) - ((string< cpfx pfx) - (setq step nil) - (setq continue nil)))) - (t (setq sep t))) - - (when step - (beginning-of-line) - (setq continue (= (forward-line) 0)))) - sep)) - -(defun markdown-cleanup-list-numbers () - "Update the numbering of ordered lists." - (interactive) - (save-excursion - (goto-char (point-min)) - (markdown-cleanup-list-numbers-level ""))) - - -;;; Movement ================================================================== - -;; This function was originally derived from `org-beginning-of-line' from org.el. -(defun markdown-beginning-of-line (&optional n) - "Go to the beginning of the current visible line. - -If this is a headline, and `markdown-special-ctrl-a/e' is not nil -or symbol `reversed', on the first attempt move to where the -headline text hashes, and only move to beginning of line when the -cursor is already before the hashes of the text of the headline. - -If `markdown-special-ctrl-a/e' is symbol `reversed' then go to -the hashes of the text on the second attempt. - -With argument N not nil or 1, move forward N - 1 lines first." - (interactive "^p") - (let ((origin (point)) - (special (pcase markdown-special-ctrl-a/e - (`(,C-a . ,_) C-a) (_ markdown-special-ctrl-a/e))) - deactivate-mark) - ;; First move to a visible line. - (if visual-line-mode - (beginning-of-visual-line n) - (move-beginning-of-line n) - ;; `move-beginning-of-line' may leave point after invisible - ;; characters if line starts with such of these (e.g., with - ;; a link at column 0). Really move to the beginning of the - ;; current visible line. - (forward-line 0)) - (cond - ;; No special behavior. Point is already at the beginning of - ;; a line, logical or visual. - ((not special)) - ;; `beginning-of-visual-line' left point before logical beginning - ;; of line: point is at the beginning of a visual line. Bail - ;; out. - ((and visual-line-mode (not (bolp)))) - ((looking-at markdown-regex-header-atx) - ;; At a header, special position is before the title. - (let ((refpos (match-beginning 2)) - (bol (point))) - (if (eq special 'reversed) - (when (and (= origin bol) (eq last-command this-command)) - (goto-char refpos)) - (when (or (> origin refpos) (<= origin bol)) - (goto-char refpos))) - ;; Prevent automatic cursor movement caused by the command loop. - ;; Enable disable-point-adjustment to avoid unintended cursor repositioning. - (when (and markdown-hide-markup - (equal (get-char-property (point) 'display) "")) - (setq disable-point-adjustment t)))) - ((looking-at markdown-regex-list) - ;; At a list item, special position is after the list marker or checkbox. - (let ((refpos (or (match-end 4) (match-end 3)))) - (if (eq special 'reversed) - (when (and (= (point) origin) (eq last-command this-command)) - (goto-char refpos)) - (when (or (> origin refpos) (<= origin (line-beginning-position))) - (goto-char refpos))))) - ;; No special case, already at beginning of line. - (t nil)))) - -;; This function was originally derived from `org-end-of-line' from org.el. -(defun markdown-end-of-line (&optional n) - "Go to the end of the line, but before ellipsis, if any. - -If this is a headline, and `markdown-special-ctrl-a/e' is not nil -or symbol `reversed', ignore closing tags on the first attempt, -and only move to after the closing tags when the cursor is -already beyond the end of the headline. - -If `markdown-special-ctrl-a/e' is symbol `reversed' then ignore -closing tags on the second attempt. - -With argument N not nil or 1, move forward N - 1 lines first." - (interactive "^p") - (let ((origin (point)) - (special (pcase markdown-special-ctrl-a/e - (`(,_ . ,C-e) C-e) (_ markdown-special-ctrl-a/e))) - deactivate-mark) - ;; First move to a visible line. - (if visual-line-mode - (beginning-of-visual-line n) - (move-beginning-of-line n)) - (cond - ;; At a headline, with closing tags. - ((save-excursion - (forward-line 0) - (and (looking-at markdown-regex-header-atx) (match-end 3))) - (let ((refpos (match-end 2)) - (visual-end (and visual-line-mode - (save-excursion - (end-of-visual-line) - (point))))) - ;; If `end-of-visual-line' brings us before end of line or even closing - ;; tags, i.e., the headline spans over multiple visual lines, move - ;; there. - (cond ((and visual-end - (< visual-end refpos) - (<= origin visual-end)) - (goto-char visual-end)) - ((not special) (end-of-line)) - ((eq special 'reversed) - (if (and (= origin (line-end-position)) - (eq this-command last-command)) - (goto-char refpos) - (end-of-line))) - (t - (if (or (< origin refpos) (>= origin (line-end-position))) - (goto-char refpos) - (end-of-line)))) - ;; Prevent automatic cursor movement caused by the command loop. - ;; Enable disable-point-adjustment to avoid unintended cursor repositioning. - (when (and markdown-hide-markup - (equal (get-char-property (point) 'display) "")) - (setq disable-point-adjustment t)))) - (visual-line-mode - (let ((bol (line-beginning-position))) - (end-of-visual-line) - ;; If `end-of-visual-line' gets us past the ellipsis at the - ;; end of a line, backtrack and use `end-of-line' instead. - (when (/= bol (line-beginning-position)) - (goto-char bol) - (end-of-line)))) - (t (end-of-line))))) - -(defun markdown-beginning-of-defun (&optional arg) - "`beginning-of-defun-function' for Markdown. -This is used to find the beginning of the defun and should behave -like ‘beginning-of-defun’, returning non-nil if it found the -beginning of a defun. It moves the point backward, right before a -heading which defines a defun. When ARG is non-nil, repeat that -many times. When ARG is negative, move forward to the ARG-th -following section." - (or arg (setq arg 1)) - (when (< arg 0) (end-of-line)) - ;; Adjust position for setext headings. - (when (and (thing-at-point-looking-at markdown-regex-header-setext) - (not (= (point) (match-beginning 0))) - (not (markdown-code-block-at-point-p))) - (goto-char (match-end 0))) - (let (found) - ;; Move backward with positive argument. - (while (and (not (bobp)) (> arg 0)) - (setq found nil) - (while (and (not found) - (not (bobp)) - (re-search-backward markdown-regex-header nil 'move)) - (markdown-code-block-at-pos (match-beginning 0)) - (setq found (match-beginning 0))) - (setq arg (1- arg))) - ;; Move forward with negative argument. - (while (and (not (eobp)) (< arg 0)) - (setq found nil) - (while (and (not found) - (not (eobp)) - (re-search-forward markdown-regex-header nil 'move)) - (markdown-code-block-at-pos (match-beginning 0)) - (setq found (match-beginning 0))) - (setq arg (1+ arg))) - (when found - (beginning-of-line) - t))) - -(defun markdown-end-of-defun () - "`end-of-defun-function’ for Markdown. -This is used to find the end of the defun at point. -It is called with no argument, right after calling ‘beginning-of-defun-raw’, -so it can assume that point is at the beginning of the defun body. -It should move point to the first position after the defun." - (or (eobp) (forward-char 1)) - (let (found) - (while (and (not found) - (not (eobp)) - (re-search-forward markdown-regex-header nil 'move)) - (when (not (markdown-code-block-at-pos (match-beginning 0))) - (setq found (match-beginning 0)))) - (when found - (goto-char found) - (skip-syntax-backward "-")))) - -(defun markdown-beginning-of-text-block () - "Move backward to previous beginning of a plain text block. -This function simply looks for blank lines without considering -the surrounding context in light of Markdown syntax. For that, see -`markdown-backward-block'." - (interactive) - (let ((start (point))) - (if (re-search-backward markdown-regex-block-separator nil t) - (goto-char (match-end 0)) - (goto-char (point-min))) - (when (and (= start (point)) (not (bobp))) - (forward-line -1) - (if (re-search-backward markdown-regex-block-separator nil t) - (goto-char (match-end 0)) - (goto-char (point-min)))))) - -(defun markdown-end-of-text-block () - "Move forward to next beginning of a plain text block. -This function simply looks for blank lines without considering -the surrounding context in light of Markdown syntax. For that, see -`markdown-forward-block'." - (interactive) - (beginning-of-line) - (skip-chars-forward " \t\n") - (when (= (point) (point-min)) - (forward-char)) - (if (re-search-forward markdown-regex-block-separator nil t) - (goto-char (match-end 0)) - (goto-char (point-max))) - (skip-chars-backward " \t\n") - (forward-line)) - -(defun markdown-backward-paragraph (&optional arg) - "Move the point to the start of the current paragraph. -With argument ARG, do it ARG times; a negative argument ARG = -N -means move forward N blocks." - (interactive "^p") - (or arg (setq arg 1)) - (if (< arg 0) - (markdown-forward-paragraph (- arg)) - (dotimes (_ arg) - ;; Skip over whitespace in between paragraphs when moving backward. - (skip-chars-backward " \t\n") - (beginning-of-line) - ;; Skip over code block endings. - (when (markdown-range-properties-exist - (line-beginning-position) (line-end-position) - '(markdown-gfm-block-end - markdown-tilde-fence-end)) - (forward-line -1)) - ;; Skip over blank lines inside blockquotes. - (while (and (not (eobp)) - (looking-at markdown-regex-blockquote) - (= (length (match-string 3)) 0)) - (forward-line -1)) - ;; Proceed forward based on the type of block of paragraph. - (let (bounds skip) - (cond - ;; Blockquotes - ((looking-at markdown-regex-blockquote) - (while (and (not (bobp)) - (looking-at markdown-regex-blockquote) - (> (length (match-string 3)) 0)) ;; not blank - (forward-line -1)) - (forward-line)) - ;; List items - ((setq bounds (markdown-cur-list-item-bounds)) - (goto-char (nth 0 bounds))) - ;; Other - (t - (while (and (not (bobp)) - (not skip) - (not (markdown-cur-line-blank-p)) - (not (looking-at markdown-regex-blockquote)) - (not (markdown-range-properties-exist - (line-beginning-position) (line-end-position) - '(markdown-gfm-block-end - markdown-tilde-fence-end)))) - (setq skip (markdown-range-properties-exist - (line-beginning-position) (line-end-position) - '(markdown-gfm-block-begin - markdown-tilde-fence-begin))) - (forward-line -1)) - (unless (bobp) - (forward-line 1)))))))) - -(defun markdown-forward-paragraph (&optional arg) - "Move forward to the next end of a paragraph. -With argument ARG, do it ARG times; a negative argument ARG = -N -means move backward N blocks." - (interactive "^p") - (or arg (setq arg 1)) - (if (< arg 0) - (markdown-backward-paragraph (- arg)) - (dotimes (_ arg) - ;; Skip whitespace in between paragraphs. - (when (markdown-cur-line-blank-p) - (skip-syntax-forward "-") - (beginning-of-line)) - ;; Proceed forward based on the type of block. - (let (bounds skip) - (cond - ;; Blockquotes - ((looking-at markdown-regex-blockquote) - ;; Skip over blank lines inside blockquotes. - (while (and (not (eobp)) - (looking-at markdown-regex-blockquote) - (= (length (match-string 3)) 0)) - (forward-line)) - ;; Move to end of quoted text block - (while (and (not (eobp)) - (looking-at markdown-regex-blockquote) - (> (length (match-string 3)) 0)) ;; not blank - (forward-line))) - ;; List items - ((and (markdown-cur-list-item-bounds) - (setq bounds (markdown-next-list-item-bounds))) - (goto-char (nth 0 bounds))) - ;; Other - (t - (forward-line) - (while (and (not (eobp)) - (not skip) - (not (markdown-cur-line-blank-p)) - (not (looking-at markdown-regex-blockquote)) - (not (markdown-range-properties-exist - (line-beginning-position) (line-end-position) - '(markdown-gfm-block-begin - markdown-tilde-fence-begin)))) - (setq skip (markdown-range-properties-exist - (line-beginning-position) (line-end-position) - '(markdown-gfm-block-end - markdown-tilde-fence-end))) - (forward-line)))))))) - -(defun markdown-backward-block (&optional arg) - "Move the point to the start of the current Markdown block. -Moves across complete code blocks, list items, and blockquotes, -but otherwise stops at blank lines, headers, and horizontal -rules. With argument ARG, do it ARG times; a negative argument -ARG = -N means move forward N blocks." - (interactive "^p") - (or arg (setq arg 1)) - (if (< arg 0) - (markdown-forward-block (- arg)) - (dotimes (_ arg) - ;; Skip over whitespace in between blocks when moving backward, - ;; unless at a block boundary with no whitespace. - (skip-syntax-backward "-") - (beginning-of-line) - ;; Proceed forward based on the type of block. - (cond - ;; Code blocks - ((and (markdown-code-block-at-pos (point)) ;; this line - (markdown-code-block-at-pos (line-beginning-position 0))) ;; previous line - (forward-line -1) - (while (and (markdown-code-block-at-point-p) (not (bobp))) - (forward-line -1)) - (forward-line)) - ;; Headings - ((markdown-heading-at-point) - (goto-char (match-beginning 0))) - ;; Horizontal rules - ((looking-at markdown-regex-hr)) - ;; Blockquotes - ((looking-at markdown-regex-blockquote) - (forward-line -1) - (while (and (looking-at markdown-regex-blockquote) - (not (bobp))) - (forward-line -1)) - (forward-line)) - ;; List items - ((markdown-cur-list-item-bounds) - (markdown-beginning-of-list)) - ;; Other - (t - ;; Move forward in case it is a one line regular paragraph. - (unless (markdown-next-line-blank-p) - (forward-line)) - (unless (markdown-prev-line-blank-p) - (markdown-backward-paragraph))))))) - -(defun markdown-forward-block (&optional arg) - "Move forward to the next end of a Markdown block. -Moves across complete code blocks, list items, and blockquotes, -but otherwise stops at blank lines, headers, and horizontal -rules. With argument ARG, do it ARG times; a negative argument -ARG = -N means move backward N blocks." - (interactive "^p") - (or arg (setq arg 1)) - (if (< arg 0) - (markdown-backward-block (- arg)) - (dotimes (_ arg) - ;; Skip over whitespace in between blocks when moving forward. - (if (markdown-cur-line-blank-p) - (skip-syntax-forward "-") - (beginning-of-line)) - ;; Proceed forward based on the type of block. - (cond - ;; Code blocks - ((markdown-code-block-at-point-p) - (forward-line) - (while (and (markdown-code-block-at-point-p) (not (eobp))) - (forward-line))) - ;; Headings - ((looking-at markdown-regex-header) - (goto-char (or (match-end 4) (match-end 2) (match-end 3))) - (forward-line)) - ;; Horizontal rules - ((looking-at markdown-regex-hr) - (forward-line)) - ;; Blockquotes - ((looking-at markdown-regex-blockquote) - (forward-line) - (while (and (looking-at markdown-regex-blockquote) (not (eobp))) - (forward-line))) - ;; List items - ((markdown-cur-list-item-bounds) - (markdown-end-of-list) - (forward-line)) - ;; Other - (t (markdown-forward-paragraph)))) - (skip-syntax-backward "-") - (unless (eobp) - (forward-char 1)))) - -(defun markdown-backward-page (&optional count) - "Move backward to boundary of the current toplevel section. -With COUNT, repeat, or go forward if negative." - (interactive "p") - (or count (setq count 1)) - (if (< count 0) - (markdown-forward-page (- count)) - (skip-syntax-backward "-") - (or (markdown-back-to-heading-over-code-block t t) - (goto-char (point-min))) - (when (looking-at markdown-regex-header) - (let ((level (markdown-outline-level))) - (when (> level 1) (markdown-up-heading level)) - (when (> count 1) - (condition-case nil - (markdown-backward-same-level (1- count)) - (error (goto-char (point-min))))))))) - -(defun markdown-forward-page (&optional count) - "Move forward to boundary of the current toplevel section. -With COUNT, repeat, or go backward if negative." - (interactive "p") - (or count (setq count 1)) - (if (< count 0) - (markdown-backward-page (- count)) - (if (markdown-back-to-heading-over-code-block t t) - (let ((level (markdown-outline-level))) - (when (> level 1) (markdown-up-heading level)) - (condition-case nil - (markdown-forward-same-level count) - (error (goto-char (point-max))))) - (markdown-next-visible-heading 1)))) - -(defun markdown-next-link () - "Jump to next inline, reference, or wiki link. -If successful, return point. Otherwise, return nil. -See `markdown-wiki-link-p' and `markdown-previous-wiki-link'." - (interactive) - (let ((opoint (point))) - (when (or (markdown-link-p) (markdown-wiki-link-p)) - ;; At a link already, move past it. - (goto-char (+ (match-end 0) 1))) - ;; Search for the next wiki link and move to the beginning. - (while (and (re-search-forward (markdown-make-regex-link-generic) nil t) - (markdown-code-block-at-point-p) - (< (point) (point-max)))) - (if (and (not (eq (point) opoint)) - (or (markdown-link-p) (markdown-wiki-link-p))) - ;; Group 1 will move past non-escape character in wiki link regexp. - ;; Go to beginning of group zero for all other link types. - (goto-char (or (match-beginning 1) (match-beginning 0))) - (goto-char opoint) - nil))) - -(defun markdown-previous-link () - "Jump to previous wiki link. -If successful, return point. Otherwise, return nil. -See `markdown-wiki-link-p' and `markdown-next-wiki-link'." - (interactive) - (let ((opoint (point))) - (while (and (re-search-backward (markdown-make-regex-link-generic) nil t) - (markdown-code-block-at-point-p) - (> (point) (point-min)))) - (if (and (not (eq (point) opoint)) - (or (markdown-link-p) (markdown-wiki-link-p))) - (goto-char (or (match-beginning 1) (match-beginning 0))) - (goto-char opoint) - nil))) - - -;;; Outline =================================================================== - -(defun markdown-move-heading-common (move-fn &optional arg adjust) - "Wrapper for `outline-mode' functions to skip false positives. -MOVE-FN is a function and ARG is its argument. For example, -headings inside preformatted code blocks may match -`outline-regexp' but should not be considered as headings. -When ADJUST is non-nil, adjust the point for interactive calls -to avoid leaving the point at invisible markup. This adjustment -generally should only be done for interactive calls, since other -functions may expect the point to be at the beginning of the -regular expression." - (let ((prev -1) (start (point))) - (if arg (funcall move-fn arg) (funcall move-fn)) - (while (and (/= prev (point)) (markdown-code-block-at-point-p)) - (setq prev (point)) - (if arg (funcall move-fn arg) (funcall move-fn))) - ;; Adjust point for setext headings and invisible text. - (save-match-data - (when (and adjust (thing-at-point-looking-at markdown-regex-header)) - (if markdown-hide-markup - ;; Move to beginning of heading text if markup is hidden. - (goto-char (or (match-beginning 1) (match-beginning 5))) - ;; Move to beginning of markup otherwise. - (goto-char (or (match-beginning 1) (match-beginning 4)))))) - (if (= (point) start) nil (point)))) - -(defun markdown-next-visible-heading (arg) - "Move to the next visible heading line of any level. -With argument, repeats or can move backward if negative. ARG is -passed to `outline-next-visible-heading'." - (interactive "p") - (markdown-move-heading-common #'outline-next-visible-heading arg 'adjust)) - -(defun markdown-previous-visible-heading (arg) - "Move to the previous visible heading line of any level. -With argument, repeats or can move backward if negative. ARG is -passed to `outline-previous-visible-heading'." - (interactive "p") - (markdown-move-heading-common #'outline-previous-visible-heading arg 'adjust)) - -(defun markdown-next-heading () - "Move to the next heading line of any level." - (markdown-move-heading-common #'outline-next-heading)) - -(defun markdown-previous-heading () - "Move to the previous heading line of any level." - (markdown-move-heading-common #'outline-previous-heading)) - -(defun markdown-back-to-heading-over-code-block (&optional invisible-ok no-error) - "Move back to the beginning of the previous heading. -Returns t if the point is at a heading, the location if a heading -was found, and nil otherwise. -Only visible heading lines are considered, unless INVISIBLE-OK is -non-nil. Throw an error if there is no previous heading unless -NO-ERROR is non-nil. -Leaves match data intact for `markdown-regex-header'." - (beginning-of-line) - (or (and (markdown-heading-at-point) - (not (markdown-code-block-at-point-p))) - (let (found) - (save-excursion - (while (and (not found) - (re-search-backward markdown-regex-header nil t)) - (when (and (or invisible-ok (not (outline-invisible-p))) - (not (markdown-code-block-at-point-p))) - (setq found (point)))) - (if (not found) - (unless no-error (user-error "Before first heading")) - (setq found (point)))) - (when found (goto-char found))))) - -(defun markdown-forward-same-level (arg) - "Move forward to the ARG'th heading at same level as this one. -Stop at the first and last headings of a superior heading." - (interactive "p") - (markdown-back-to-heading-over-code-block) - (markdown-move-heading-common #'outline-forward-same-level arg 'adjust)) - -(defun markdown-backward-same-level (arg) - "Move backward to the ARG'th heading at same level as this one. -Stop at the first and last headings of a superior heading." - (interactive "p") - (markdown-back-to-heading-over-code-block) - (while (> arg 0) - (let ((point-to-move-to - (save-excursion - (markdown-move-heading-common #'outline-get-last-sibling nil 'adjust)))) - (if point-to-move-to - (progn - (goto-char point-to-move-to) - (setq arg (1- arg))) - (user-error "No previous same-level heading"))))) - -(defun markdown-up-heading (arg &optional interactive) - "Move to the visible heading line of which the present line is a subheading. -With argument, move up ARG levels. When called interactively (or -INTERACTIVE is non-nil), also push the mark." - (interactive "p\np") - (and interactive (not (eq last-command 'markdown-up-heading)) - (push-mark)) - (markdown-move-heading-common #'outline-up-heading arg 'adjust)) - -(defun markdown-back-to-heading (&optional invisible-ok) - "Move to previous heading line, or beg of this line if it's a heading. -Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." - (interactive) - (markdown-move-heading-common #'outline-back-to-heading invisible-ok)) - -(defalias 'markdown-end-of-heading 'outline-end-of-heading) - -(defun markdown-on-heading-p () - "Return non-nil if point is on a heading line." - (get-text-property (line-beginning-position) 'markdown-heading)) - -(defun markdown-end-of-subtree (&optional invisible-OK) - "Move to the end of the current subtree. -Only visible heading lines are considered, unless INVISIBLE-OK is -non-nil. -Derived from `org-end-of-subtree'." - (markdown-back-to-heading invisible-OK) - (let ((first t) - (level (markdown-outline-level))) - (while (and (not (eobp)) - (or first (> (markdown-outline-level) level))) - (setq first nil) - (markdown-next-heading)) - (if (memq (preceding-char) '(?\n ?\^M)) - (progn - ;; Go to end of line before heading - (forward-char -1) - (if (memq (preceding-char) '(?\n ?\^M)) - ;; leave blank line before heading - (forward-char -1))))) - (point)) - -(defun markdown-outline-fix-visibility () - "Hide any false positive headings that should not be shown. -For example, headings inside preformatted code blocks may match -`outline-regexp' but should not be shown as headings when cycling. -Also, the ending --- line in metadata blocks appears to be a -setext header, but should not be folded." - (save-excursion - (goto-char (point-min)) - ;; Unhide any false positives in metadata blocks - (when (markdown-text-property-at-point 'markdown-yaml-metadata-begin) - (let ((body (progn (forward-line) - (markdown-text-property-at-point - 'markdown-yaml-metadata-section)))) - (when body - (let ((end (progn (goto-char (cl-second body)) - (markdown-text-property-at-point - 'markdown-yaml-metadata-end)))) - (outline-flag-region (point-min) (1+ (cl-second end)) nil))))) - ;; Hide any false positives in code blocks - (unless (outline-on-heading-p) - (outline-next-visible-heading 1)) - (while (< (point) (point-max)) - (when (markdown-code-block-at-point-p) - (outline-flag-region (1- (line-beginning-position)) (line-end-position) t)) - (outline-next-visible-heading 1)))) - -(defvar markdown-cycle-global-status 1) -(defvar markdown-cycle-subtree-status nil) - -(defun markdown-next-preface () - (let (finish) - (while (and (not finish) (re-search-forward (concat "\n\\(?:" outline-regexp "\\)") - nil 'move)) - (unless (markdown-code-block-at-point-p) - (goto-char (match-beginning 0)) - (setq finish t)))) - (when (and (bolp) (or outline-blank-line (eobp)) (not (bobp))) - (forward-char -1))) - -(defun markdown-show-entry () - (save-excursion - (outline-back-to-heading t) - (outline-flag-region (1- (point)) - (progn - (markdown-next-preface) - (if (= 1 (- (point-max) (point))) - (point-max) - (point))) - nil))) - -;; This function was originally derived from `org-cycle' from org.el. -(defun markdown-cycle (&optional arg) - "Visibility cycling for Markdown mode. -This function is called with a `\\[universal-argument]' or if ARG is t, perform -global visibility cycling. If the point is at an atx-style header, cycle -visibility of the corresponding subtree. Otherwise, indent the current line - or insert a tab, as appropriate, by calling `indent-for-tab-command'." - (interactive "P") - (cond - - ;; Global cycling - (arg - (cond - ;; Move from overview to contents - ((and (eq last-command this-command) - (eq markdown-cycle-global-status 2)) - (outline-hide-sublevels 1) - (message "CONTENTS") - (setq markdown-cycle-global-status 3) - (markdown-outline-fix-visibility)) - ;; Move from contents to all - ((and (eq last-command this-command) - (eq markdown-cycle-global-status 3)) - (outline-show-all) - (message "SHOW ALL") - (setq markdown-cycle-global-status 1)) - ;; Defaults to overview - (t - (outline-hide-body) - (message "OVERVIEW") - (setq markdown-cycle-global-status 2) - (markdown-outline-fix-visibility)))) - - ;; At a heading: rotate between three different views - ((save-excursion (beginning-of-line 1) (markdown-on-heading-p)) - (markdown-back-to-heading) - (let ((goal-column 0) eoh eol eos) - ;; Determine boundaries - (save-excursion - (markdown-back-to-heading) - (save-excursion - (beginning-of-line 2) - (while (and (not (eobp)) ;; this is like `next-line' - (get-char-property (1- (point)) 'invisible)) - (beginning-of-line 2)) (setq eol (point))) - (markdown-end-of-heading) (setq eoh (point)) - (markdown-end-of-subtree t) - (skip-chars-forward " \t\n") - (beginning-of-line 1) ; in case this is an item - (setq eos (1- (point)))) - ;; Find out what to do next and set `this-command' - (cond - ;; Nothing is hidden behind this heading - ((= eos eoh) - (message "EMPTY ENTRY") - (setq markdown-cycle-subtree-status nil)) - ;; Entire subtree is hidden in one line: open it - ((>= eol eos) - (markdown-show-entry) - (outline-show-children) - (message "CHILDREN") - (setq markdown-cycle-subtree-status 'children)) - ;; We just showed the children, now show everything. - ((and (eq last-command this-command) - (eq markdown-cycle-subtree-status 'children)) - (outline-show-subtree) - (message "SUBTREE") - (setq markdown-cycle-subtree-status 'subtree)) - ;; Default action: hide the subtree. - (t - (outline-hide-subtree) - (message "FOLDED") - (setq markdown-cycle-subtree-status 'folded))))) - - ;; In a table, move forward by one cell - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-forward-cell)) - - ;; Otherwise, indent as appropriate - (t - (indent-for-tab-command)))) - -(defun markdown-shifttab () - "Handle S-TAB keybinding based on context. -When in a table, move backward one cell. -Otherwise, cycle global heading visibility by calling -`markdown-cycle' with argument t." - (interactive) - (cond ((markdown-table-at-point-p) - (call-interactively #'markdown-table-backward-cell)) - (t (markdown-cycle t)))) - -(defun markdown-outline-level () - "Return the depth to which a statement is nested in the outline." - (cond - ((and (match-beginning 0) - (markdown-code-block-at-pos (match-beginning 0))) - 7) ;; Only 6 header levels are defined. - ((match-end 2) 1) - ((match-end 3) 2) - ((match-end 4) - (length (markdown-trim-whitespace (match-string-no-properties 4)))))) - -(defun markdown-promote-subtree (&optional arg) - "Promote the current subtree of ATX headings. -Note that Markdown does not support heading levels higher than -six and therefore level-six headings will not be promoted -further. If ARG is non-nil promote the heading, otherwise -demote." - (interactive "*P") - (save-excursion - (when (and (or (thing-at-point-looking-at markdown-regex-header-atx) - (re-search-backward markdown-regex-header-atx nil t)) - (not (markdown-code-block-at-point-p))) - (let ((level (length (match-string 1))) - (promote-or-demote (if arg 1 -1)) - (remove 't)) - (markdown-cycle-atx promote-or-demote remove) - (catch 'end-of-subtree - (while (and (markdown-next-heading) - (looking-at markdown-regex-header-atx)) - ;; Exit if this not a higher level heading; promote otherwise. - (if (and (looking-at markdown-regex-header-atx) - (<= (length (match-string-no-properties 1)) level)) - (throw 'end-of-subtree nil) - (markdown-cycle-atx promote-or-demote remove)))))))) - -(defun markdown-demote-subtree () - "Demote the current subtree of ATX headings." - (interactive) - (markdown-promote-subtree t)) - -(defun markdown-move-subtree-up () - "Move the current subtree of ATX headings up." - (interactive) - (outline-move-subtree-up 1)) - -(defun markdown-move-subtree-down () - "Move the current subtree of ATX headings down." - (interactive) - (outline-move-subtree-down 1)) - -(defun markdown-outline-next () - "Move to next list item, when in a list, or next visible heading." - (interactive) - (let ((bounds (markdown-next-list-item-bounds))) - (if bounds - (goto-char (nth 0 bounds)) - (markdown-next-visible-heading 1)))) - -(defun markdown-outline-previous () - "Move to previous list item, when in a list, or previous visible heading." - (interactive) - (let ((bounds (markdown-prev-list-item-bounds))) - (if bounds - (goto-char (nth 0 bounds)) - (markdown-previous-visible-heading 1)))) - -(defun markdown-outline-next-same-level () - "Move to next list item or heading of same level." - (interactive) - (let ((bounds (markdown-cur-list-item-bounds))) - (if bounds - (markdown-next-list-item (nth 3 bounds)) - (markdown-forward-same-level 1)))) - -(defun markdown-outline-previous-same-level () - "Move to previous list item or heading of same level." - (interactive) - (let ((bounds (markdown-cur-list-item-bounds))) - (if bounds - (markdown-prev-list-item (nth 3 bounds)) - (markdown-backward-same-level 1)))) - -(defun markdown-outline-up () - "Move to previous list item, when in a list, or previous heading." - (interactive) - (unless (markdown-up-list) - (markdown-up-heading 1))) - - -;;; Marking and Narrowing ===================================================== - -(defun markdown-mark-paragraph () - "Put mark at end of this block, point at beginning. -The block marked is the one that contains point or follows point. - -Interactively, if this command is repeated or (in Transient Mark -mode) if the mark is active, it marks the next block after the -ones already marked." - (interactive) - (if (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active)) - (set-mark - (save-excursion - (goto-char (mark)) - (markdown-forward-paragraph) - (point))) - (let ((beginning-of-defun-function #'markdown-backward-paragraph) - (end-of-defun-function #'markdown-forward-paragraph)) - (mark-defun)))) - -(defun markdown-mark-block () - "Put mark at end of this block, point at beginning. -The block marked is the one that contains point or follows point. - -Interactively, if this command is repeated or (in Transient Mark -mode) if the mark is active, it marks the next block after the -ones already marked." - (interactive) - (if (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active)) - (set-mark - (save-excursion - (goto-char (mark)) - (markdown-forward-block) - (point))) - (let ((beginning-of-defun-function #'markdown-backward-block) - (end-of-defun-function #'markdown-forward-block)) - (mark-defun)))) - -(defun markdown-narrow-to-block () - "Make text outside current block invisible. -The current block is the one that contains point or follows point." - (interactive) - (let ((beginning-of-defun-function #'markdown-backward-block) - (end-of-defun-function #'markdown-forward-block)) - (narrow-to-defun))) - -(defun markdown-mark-text-block () - "Put mark at end of this plain text block, point at beginning. -The block marked is the one that contains point or follows point. - -Interactively, if this command is repeated or (in Transient Mark -mode) if the mark is active, it marks the next block after the -ones already marked." - (interactive) - (if (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active)) - (set-mark - (save-excursion - (goto-char (mark)) - (markdown-end-of-text-block) - (point))) - (let ((beginning-of-defun-function #'markdown-beginning-of-text-block) - (end-of-defun-function #'markdown-end-of-text-block)) - (mark-defun)))) - -(defun markdown-mark-page () - "Put mark at end of this top level section, point at beginning. -The top level section marked is the one that contains point or -follows point. - -Interactively, if this command is repeated or (in Transient Mark -mode) if the mark is active, it marks the next page after the -ones already marked." - (interactive) - (if (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active)) - (set-mark - (save-excursion - (goto-char (mark)) - (markdown-forward-page) - (point))) - (let ((beginning-of-defun-function #'markdown-backward-page) - (end-of-defun-function #'markdown-forward-page)) - (mark-defun)))) - -(defun markdown-narrow-to-page () - "Make text outside current top level section invisible. -The current section is the one that contains point or follows point." - (interactive) - (let ((beginning-of-defun-function #'markdown-backward-page) - (end-of-defun-function #'markdown-forward-page)) - (narrow-to-defun))) - -(defun markdown-mark-subtree () - "Mark the current subtree. -This puts point at the start of the current subtree, and mark at the end." - (interactive) - (let ((beg)) - (if (markdown-heading-at-point) - (beginning-of-line) - (markdown-previous-visible-heading 1)) - (setq beg (point)) - (markdown-end-of-subtree) - (push-mark (point) nil t) - (goto-char beg))) - -(defun markdown-narrow-to-subtree () - "Narrow buffer to the current subtree." - (interactive) - (save-excursion - (save-match-data - (narrow-to-region - (progn (markdown-back-to-heading-over-code-block t) (point)) - (progn (markdown-end-of-subtree) - (if (and (markdown-heading-at-point) (not (eobp))) - (backward-char 1)) - (point)))))) - - -;;; Generic Structure Editing, Completion, and Cycling Commands =============== - -(defun markdown-move-up () - "Move thing at point up. -When in a list item, call `markdown-move-list-item-up'. -When in a table, call `markdown-table-move-row-up'. -Otherwise, move the current heading subtree up with -`markdown-move-subtree-up'." - (interactive) - (cond - ((markdown-list-item-at-point-p) - (call-interactively #'markdown-move-list-item-up)) - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-move-row-up)) - (t - (call-interactively #'markdown-move-subtree-up)))) - -(defun markdown-move-down () - "Move thing at point down. -When in a list item, call `markdown-move-list-item-down'. -Otherwise, move the current heading subtree up with -`markdown-move-subtree-down'." - (interactive) - (cond - ((markdown-list-item-at-point-p) - (call-interactively #'markdown-move-list-item-down)) - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-move-row-down)) - (t - (call-interactively #'markdown-move-subtree-down)))) - -(defun markdown-promote () - "Promote or move element at point to the left. -Depending on the context, this function will promote a heading or -list item at the point, move a table column to the left, or cycle -markup." - (interactive) - (let (bounds) - (cond - ;; Promote atx heading subtree - ((thing-at-point-looking-at markdown-regex-header-atx) - (markdown-promote-subtree)) - ;; Promote setext heading - ((thing-at-point-looking-at markdown-regex-header-setext) - (markdown-cycle-setext -1)) - ;; Promote horizontal rule - ((thing-at-point-looking-at markdown-regex-hr) - (markdown-cycle-hr -1)) - ;; Promote list item - ((setq bounds (markdown-cur-list-item-bounds)) - (markdown-promote-list-item bounds)) - ;; Move table column to the left - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-move-column-left)) - ;; Promote bold - ((thing-at-point-looking-at markdown-regex-bold) - (markdown-cycle-bold)) - ;; Promote italic - ((thing-at-point-looking-at markdown-regex-italic) - (markdown-cycle-italic)) - (t - (user-error "Nothing to promote at point"))))) - -(defun markdown-demote () - "Demote or move element at point to the right. -Depending on the context, this function will demote a heading or -list item at the point, move a table column to the right, or cycle -or remove markup." - (interactive) - (let (bounds) - (cond - ;; Demote atx heading subtree - ((thing-at-point-looking-at markdown-regex-header-atx) - (markdown-demote-subtree)) - ;; Demote setext heading - ((thing-at-point-looking-at markdown-regex-header-setext) - (markdown-cycle-setext 1)) - ;; Demote horizontal rule - ((thing-at-point-looking-at markdown-regex-hr) - (markdown-cycle-hr 1)) - ;; Demote list item - ((setq bounds (markdown-cur-list-item-bounds)) - (markdown-demote-list-item bounds)) - ;; Move table column to the right - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-move-column-right)) - ;; Demote bold - ((thing-at-point-looking-at markdown-regex-bold) - (markdown-cycle-bold)) - ;; Demote italic - ((thing-at-point-looking-at markdown-regex-italic) - (markdown-cycle-italic)) - (t - (user-error "Nothing to demote at point"))))) - - -;;; Commands ================================================================== - -(defun markdown (&optional output-buffer-name) - "Run `markdown-command' on buffer, sending output to OUTPUT-BUFFER-NAME. -The output buffer name defaults to `markdown-output-buffer-name'. -Return the name of the output buffer used." - (interactive) - (save-window-excursion - (let* ((commands (cond ((stringp markdown-command) (split-string markdown-command)) - ((listp markdown-command) markdown-command))) - (command (car-safe commands)) - (command-args (cdr-safe commands)) - begin-region end-region) - (if (use-region-p) - (setq begin-region (region-beginning) - end-region (region-end)) - (setq begin-region (point-min) - end-region (point-max))) - - (unless output-buffer-name - (setq output-buffer-name markdown-output-buffer-name)) - (when (and (stringp command) (not (executable-find command))) - (user-error "Markdown command %s is not found" command)) - (let ((exit-code - (cond - ;; Handle case when `markdown-command' does not read from stdin - ((and (stringp command) markdown-command-needs-filename) - (if (not buffer-file-name) - (user-error "Must be visiting a file") - ;; Don’t use ‘shell-command’ because it’s not guaranteed to - ;; return the exit code of the process. - (let ((command (if (listp markdown-command) - (string-join markdown-command " ") - markdown-command))) - (shell-command-on-region - ;; Pass an empty region so that stdin is empty. - (point) (point) - (concat command " " - (shell-quote-argument buffer-file-name)) - output-buffer-name)))) - ;; Pass region to `markdown-command' via stdin - (t - (let ((buf (get-buffer-create output-buffer-name))) - (with-current-buffer buf - (setq buffer-read-only nil) - (erase-buffer)) - (if (stringp command) - (if (not (null command-args)) - (apply #'call-process-region begin-region end-region command nil buf nil command-args) - (call-process-region begin-region end-region command nil buf)) - (if markdown-command-needs-filename - (if (not buffer-file-name) - (user-error "Must be visiting a file") - (funcall markdown-command begin-region end-region buf buffer-file-name)) - (funcall markdown-command begin-region end-region buf)) - ;; If the ‘markdown-command’ function didn’t signal an - ;; error, assume it succeeded by binding ‘exit-code’ to 0. - 0)))))) - ;; The exit code can be a signal description string, so don’t use ‘=’ - ;; or ‘zerop’. - (unless (eq exit-code 0) - (user-error "%s failed with exit code %s" - markdown-command exit-code)))) - output-buffer-name)) - -(defun markdown-standalone (&optional output-buffer-name) - "Special function to provide standalone HTML output. -Insert the output in the buffer named OUTPUT-BUFFER-NAME." - (interactive) - (setq output-buffer-name (markdown output-buffer-name)) - (let ((css-path markdown-css-paths)) - (with-current-buffer output-buffer-name - (set-buffer output-buffer-name) - (setq-local markdown-css-paths css-path) - (unless (markdown-output-standalone-p) - (markdown-add-xhtml-header-and-footer output-buffer-name)) - (goto-char (point-min)) - (html-mode))) - output-buffer-name) - -(defun markdown-other-window (&optional output-buffer-name) - "Run `markdown-command' on current buffer and display in other window. -When OUTPUT-BUFFER-NAME is given, insert the output in the buffer with -that name." - (interactive) - (markdown-display-buffer-other-window - (markdown-standalone output-buffer-name))) - -(defun markdown-output-standalone-p () - "Determine whether `markdown-command' output is standalone XHTML. -Standalone XHTML output is identified by an occurrence of -`markdown-xhtml-standalone-regexp' in the first five lines of output." - (save-excursion - (goto-char (point-min)) - (save-match-data - (re-search-forward - markdown-xhtml-standalone-regexp - (save-excursion (goto-char (point-min)) (forward-line 4) (point)) - t)))) - -(defun markdown-stylesheet-link-string (stylesheet-path) - (concat "<link rel=\"stylesheet\" type=\"text/css\" media=\"all\" href=\"" - (or (and (string-prefix-p "~" stylesheet-path) - (expand-file-name stylesheet-path)) - stylesheet-path) - "\" />")) - -(defun markdown-escape-title (title) - "Escape a minimum set of characters in TITLE so they don't clash with html." - (replace-regexp-in-string ">" ">" - (replace-regexp-in-string "<" "<" - (replace-regexp-in-string "&" "&" title)))) - -(defun markdown-add-xhtml-header-and-footer (title) - "Wrap XHTML header and footer with given TITLE around current buffer." - (goto-char (point-min)) - (insert "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n" - "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" - "\t\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n\n" - "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n\n" - "<head>\n<title>") - (insert (markdown-escape-title title)) - (insert "</title>\n") - (unless (= (length markdown-content-type) 0) - (insert - (format - "<meta http-equiv=\"Content-Type\" content=\"%s;charset=%s\"/>\n" - markdown-content-type - (or (and markdown-coding-system - (coding-system-get markdown-coding-system - 'mime-charset)) - (coding-system-get buffer-file-coding-system - 'mime-charset) - "utf-8")))) - (if (> (length markdown-css-paths) 0) - (insert (mapconcat #'markdown-stylesheet-link-string - markdown-css-paths "\n"))) - (when (> (length markdown-xhtml-header-content) 0) - (insert markdown-xhtml-header-content)) - (insert "\n</head>\n\n" - "<body>\n\n") - (when (> (length markdown-xhtml-body-preamble) 0) - (insert markdown-xhtml-body-preamble "\n")) - (goto-char (point-max)) - (when (> (length markdown-xhtml-body-epilogue) 0) - (insert "\n" markdown-xhtml-body-epilogue)) - (insert "\n" - "</body>\n" - "</html>\n")) - -(defun markdown-preview (&optional output-buffer-name) - "Run `markdown-command' on the current buffer and view output in browser. -When OUTPUT-BUFFER-NAME is given, insert the output in the buffer with -that name." - (interactive) - (browse-url-of-buffer - (markdown-standalone (or output-buffer-name markdown-output-buffer-name)))) - -(defun markdown-export-file-name (&optional extension) - "Attempt to generate a filename for Markdown output. -The file extension will be EXTENSION if given, or .html by default. -If the current buffer is visiting a file, we construct a new -output filename based on that filename. Otherwise, return nil." - (when (buffer-file-name) - (unless extension - (setq extension ".html")) - (let ((candidate - (concat - (cond - ((buffer-file-name) - (file-name-sans-extension (buffer-file-name))) - (t (buffer-name))) - extension))) - (cond - ((equal candidate (buffer-file-name)) - (concat candidate extension)) - (t - candidate))))) - -(defun markdown-export (&optional output-file) - "Run Markdown on the current buffer, save to file, and return the filename. -If OUTPUT-FILE is given, use that as the filename. Otherwise, use the filename -generated by `markdown-export-file-name', which will be constructed using the -current filename, but with the extension removed and replaced with .html." - (interactive) - (unless output-file - (setq output-file (markdown-export-file-name ".html"))) - (when output-file - (let* ((init-buf (current-buffer)) - (init-point (point)) - (init-buf-string (buffer-string)) - (output-buffer (find-file-noselect output-file)) - (output-buffer-name (buffer-name output-buffer))) - (run-hooks 'markdown-before-export-hook) - (markdown-standalone output-buffer-name) - (with-current-buffer output-buffer - (run-hooks 'markdown-after-export-hook) - (save-buffer) - (when markdown-export-kill-buffer (kill-buffer))) - ;; if modified, restore initial buffer - (when (buffer-modified-p init-buf) - (erase-buffer) - (insert init-buf-string) - (save-buffer) - (goto-char init-point)) - output-file))) - -(defun markdown-export-and-preview () - "Export to XHTML using `markdown-export' and browse the resulting file." - (interactive) - (browse-url-of-file (markdown-export))) - -(defvar-local markdown-live-preview-buffer nil - "Buffer used to preview markdown output in `markdown-live-preview-export'.") - -(defvar-local markdown-live-preview-source-buffer nil - "Source buffer from which current buffer was generated. -This is the inverse of `markdown-live-preview-buffer'.") - -(defvar markdown-live-preview-currently-exporting nil) - -(defun markdown-live-preview-get-filename () - "Standardize the filename exported by `markdown-live-preview-export'." - (markdown-export-file-name ".html")) - -(defun markdown-live-preview-window-eww (file) - "Preview FILE with eww. -To be used with `markdown-live-preview-window-function'." - (when (and (bound-and-true-p eww-auto-rename-buffer) - markdown-live-preview-buffer) - (kill-buffer markdown-live-preview-buffer)) - (eww-open-file file) - ;; #737 if `eww-auto-rename-buffer' is non-nil, the buffer name is not "*eww*" - ;; Try to find the buffer whose name ends with "eww*" - (if (bound-and-true-p eww-auto-rename-buffer) - (cl-loop for buf in (buffer-list) - when (string-match-p "eww\\*\\'" (buffer-name buf)) - return buf) - (get-buffer "*eww*"))) - -(defun markdown-visual-lines-between-points (beg end) - (save-excursion - (goto-char beg) - (cl-loop with count = 0 - while (progn (end-of-visual-line) - (and (< (point) end) (line-move-visual 1 t))) - do (cl-incf count) - finally return count))) - -(defun markdown-live-preview-window-serialize (buf) - "Get window point and scroll data for all windows displaying BUF." - (when (buffer-live-p buf) - (with-current-buffer buf - (mapcar - (lambda (win) - (with-selected-window win - (let* ((start (window-start)) - (pt (window-point)) - (pt-or-sym (cond ((= pt (point-min)) 'min) - ((= pt (point-max)) 'max) - (t pt))) - (diff (markdown-visual-lines-between-points - start pt))) - (list win pt-or-sym diff)))) - (get-buffer-window-list buf))))) - -(defun markdown-get-point-back-lines (pt num-lines) - (save-excursion - (goto-char pt) - (line-move-visual (- num-lines) t) - ;; in testing, can occasionally overshoot the number of lines to traverse - (let ((actual-num-lines (markdown-visual-lines-between-points (point) pt))) - (when (> actual-num-lines num-lines) - (line-move-visual (- actual-num-lines num-lines) t))) - (point))) - -(defun markdown-live-preview-window-deserialize (window-posns) - "Apply window point and scroll data from WINDOW-POSNS. -WINDOW-POSNS is provided by `markdown-live-preview-window-serialize'." - (cl-destructuring-bind (win pt-or-sym diff) window-posns - (when (window-live-p win) - (with-current-buffer markdown-live-preview-buffer - (set-window-buffer win (current-buffer)) - (cl-destructuring-bind (actual-pt actual-diff) - (cl-case pt-or-sym - (min (list (point-min) 0)) - (max (list (point-max) diff)) - (t (list pt-or-sym diff))) - (set-window-start - win (markdown-get-point-back-lines actual-pt actual-diff)) - (set-window-point win actual-pt)))))) - -(defun markdown-live-preview-export () - "Export to XHTML using `markdown-export'. -Browse the resulting file within Emacs using -`markdown-live-preview-window-function' Return the buffer -displaying the rendered output." - (interactive) - (let ((filename (markdown-live-preview-get-filename))) - (when filename - (let* ((markdown-live-preview-currently-exporting t) - (cur-buf (current-buffer)) - (export-file (markdown-export filename)) - ;; get positions in all windows currently displaying output buffer - (window-data - (markdown-live-preview-window-serialize - markdown-live-preview-buffer))) - (save-window-excursion - (let ((output-buffer - (funcall markdown-live-preview-window-function export-file))) - (with-current-buffer output-buffer - (setq markdown-live-preview-source-buffer cur-buf) - (add-hook 'kill-buffer-hook - #'markdown-live-preview-remove-on-kill t t)) - (with-current-buffer cur-buf - (setq markdown-live-preview-buffer output-buffer)))) - (with-current-buffer cur-buf - ;; reset all windows displaying output buffer to where they were, - ;; now with the new output - (mapc #'markdown-live-preview-window-deserialize window-data) - ;; delete html editing buffer - (let ((buf (get-file-buffer export-file))) (when buf (kill-buffer buf))) - (when (and export-file (file-exists-p export-file) - (eq markdown-live-preview-delete-export - 'delete-on-export)) - (delete-file export-file)) - markdown-live-preview-buffer))))) - -(defun markdown-live-preview-remove () - (when (buffer-live-p markdown-live-preview-buffer) - (kill-buffer markdown-live-preview-buffer)) - (setq markdown-live-preview-buffer nil) - ;; if set to 'delete-on-export, the output has already been deleted - (when (eq markdown-live-preview-delete-export 'delete-on-destroy) - (let ((outfile-name (markdown-live-preview-get-filename))) - (when (and outfile-name (file-exists-p outfile-name)) - (delete-file outfile-name))))) - -(defun markdown-get-other-window () - "Find another window to display preview or output content." - (cond - ((memq markdown-split-window-direction '(vertical below)) - (or (window-in-direction 'below) (split-window-vertically))) - ((memq markdown-split-window-direction '(horizontal right)) - (or (window-in-direction 'right) (split-window-horizontally))) - (t (split-window-sensibly (get-buffer-window))))) - -(defun markdown-display-buffer-other-window (buf) - "Display preview or output buffer BUF in another window." - (if (and display-buffer-alist (eq markdown-split-window-direction 'any)) - (display-buffer buf) - (let ((cur-buf (current-buffer)) - (window (markdown-get-other-window))) - (set-window-buffer window buf) - (set-buffer cur-buf)))) - -(defun markdown-live-preview-if-markdown () - (when (and (derived-mode-p 'markdown-mode) - markdown-live-preview-mode) - (unless markdown-live-preview-currently-exporting - (if (buffer-live-p markdown-live-preview-buffer) - (markdown-live-preview-export) - (markdown-display-buffer-other-window - (markdown-live-preview-export)))))) - -(defun markdown-live-preview-remove-on-kill () - (cond ((and (derived-mode-p 'markdown-mode) - markdown-live-preview-mode) - (markdown-live-preview-remove)) - (markdown-live-preview-source-buffer - (with-current-buffer markdown-live-preview-source-buffer - (setq markdown-live-preview-buffer nil)) - (setq markdown-live-preview-source-buffer nil)))) - -(defun markdown-live-preview-switch-to-output () - "Turn on `markdown-live-preview-mode' and switch to output buffer. -The output buffer is opened in another window." - (interactive) - (if markdown-live-preview-mode - (markdown-display-buffer-other-window (markdown-live-preview-export))) - (markdown-live-preview-mode)) - -(defun markdown-live-preview-re-export () - "Re-export the current live previewed content. -If the current buffer is a buffer displaying the exported version of a -`markdown-live-preview-mode' buffer, call `markdown-live-preview-export' and -update this buffer's contents." - (interactive) - (when markdown-live-preview-source-buffer - (with-current-buffer markdown-live-preview-source-buffer - (markdown-live-preview-export)))) - -(defun markdown-open () - "Open file for the current buffer with `markdown-open-command'." - (interactive) - (unless markdown-open-command - (user-error "Variable `markdown-open-command' must be set")) - (if (stringp markdown-open-command) - (if (not buffer-file-name) - (user-error "Must be visiting a file") - (save-buffer) - (let ((exit-code (call-process markdown-open-command nil nil nil - buffer-file-name))) - ;; The exit code can be a signal description string, so don’t use ‘=’ - ;; or ‘zerop’. - (unless (eq exit-code 0) - (user-error "%s failed with exit code %s" - markdown-open-command exit-code)))) - (funcall markdown-open-command)) - nil) - -(defun markdown-kill-ring-save () - "Run Markdown on file and store output in the kill ring." - (interactive) - (save-window-excursion - (markdown) - (with-current-buffer markdown-output-buffer-name - (kill-ring-save (point-min) (point-max))))) - - -;;; Links ===================================================================== - -(defun markdown-backward-to-link-start () - "Backward link start position if current position is in link title." - ;; Issue #305 - (when (eq (get-text-property (point) 'face) 'markdown-link-face) - (skip-chars-backward "^[") - (forward-char -1))) - -(defun markdown-link-p () - "Return non-nil when `point' is at a non-wiki link. -See `markdown-wiki-link-p' for more information." - (save-excursion - (let ((case-fold-search nil)) - (when (and (not (markdown-wiki-link-p)) (not (markdown-code-block-at-point-p))) - (markdown-backward-to-link-start) - (or (thing-at-point-looking-at markdown-regex-link-inline) - (thing-at-point-looking-at markdown-regex-link-reference) - (thing-at-point-looking-at markdown-regex-uri) - (thing-at-point-looking-at markdown-regex-angle-uri)))))) - -(defun markdown-link-at-pos (pos) - "Return properties of link or image at position POS. -Value is a list of elements describing the link: - 0. beginning position - 1. end position - 2. link text - 3. URL - 4. reference label - 5. title text - 6. bang (nil or \"!\")" - (save-excursion - (goto-char pos) - (markdown-backward-to-link-start) - (let (begin end text url reference title bang) - (cond - ;; Inline image or link at point. - ((thing-at-point-looking-at markdown-regex-link-inline) - (setq bang (match-string-no-properties 1) - begin (match-beginning 0) - text (match-string-no-properties 3) - url (match-string-no-properties 6)) - ;; consider nested parentheses - ;; if link target contains parentheses, (match-end 0) isn't correct end position of the link - (let* ((close-pos (scan-sexps (match-beginning 5) 1)) - (destination-part (string-trim (buffer-substring-no-properties (1+ (match-beginning 5)) (1- close-pos))))) - (setq end close-pos) - ;; A link can contain spaces if it is wrapped with angle brackets - (cond ((string-match "\\`<\\(.+\\)>\\'" destination-part) - (setq url (match-string-no-properties 1 destination-part))) - ((string-match "\\([^ ]+\\)\\s-+\\(.+\\)" destination-part) - (setq url (match-string-no-properties 1 destination-part) - title (substring (match-string-no-properties 2 destination-part) 1 -1))) - (t (setq url destination-part))) - (setq url (url-unhex-string url)))) - ;; Reference link at point. - ((thing-at-point-looking-at markdown-regex-link-reference) - (setq bang (match-string-no-properties 1) - begin (match-beginning 0) - end (match-end 0) - text (match-string-no-properties 3)) - (when (char-equal (char-after (match-beginning 5)) ?\[) - (setq reference (match-string-no-properties 6)))) - ;; Angle bracket URI at point. - ((thing-at-point-looking-at markdown-regex-angle-uri) - (setq begin (match-beginning 0) - end (match-end 0) - url (match-string-no-properties 2))) - ;; Plain URI at point. - ((thing-at-point-looking-at markdown-regex-uri) - (setq begin (match-beginning 0) - end (match-end 0) - url (match-string-no-properties 1)))) - (list begin end text url reference title bang)))) - -(defun markdown-link-url () - "Return the URL part of the regular (non-wiki) link at point. -Works with both inline and reference style links, and with images. -If point is not at a link or the link reference is not defined -returns nil." - (let* ((values (markdown-link-at-pos (point))) - (text (nth 2 values)) - (url (nth 3 values)) - (ref (nth 4 values))) - (or url (and ref (car (markdown-reference-definition - (downcase (if (string= ref "") text ref)))))))) - -(defun markdown--browse-url (url) - (let* ((struct (url-generic-parse-url url)) - (full (url-fullness struct)) - (file url)) - ;; Parse URL, determine fullness, strip query string - (setq file (car (url-path-and-query struct))) - ;; Open full URLs in browser, files in Emacs - (if full - (browse-url url) - (when (and file (> (length file) 0)) - (let ((link-file (funcall markdown-translate-filename-function file))) - (if (and markdown-open-image-command (string-match-p (image-file-name-regexp) link-file)) - (if (functionp markdown-open-image-command) - (funcall markdown-open-image-command link-file) - (process-file markdown-open-image-command nil nil nil link-file)) - (find-file link-file))))))) - -(defun markdown-follow-link-at-point (&optional event) - "Open the non-wiki link at point or EVENT. -If the link is a complete URL, open in browser with `browse-url'. -Otherwise, open with `find-file' after stripping anchor and/or query string. -Translate filenames using `markdown-filename-translate-function'." - (interactive (list last-command-event)) - (if event (posn-set-point (event-start event))) - (if (markdown-link-p) - (or (run-hook-with-args-until-success 'markdown-follow-link-functions (markdown-link-url)) - (markdown--browse-url (markdown-link-url))) - (user-error "Point is not at a Markdown link or URL"))) - -(defun markdown-fontify-inline-links (last) - "Add text properties to next inline link from point to LAST." - (when (markdown-match-generic-links last nil) - (let* ((link-start (match-beginning 3)) - (link-end (match-end 3)) - (url-start (match-beginning 6)) - (url-end (match-end 6)) - (url (match-string-no-properties 6)) - (title-start (match-beginning 7)) - (title-end (match-end 7)) - (title (match-string-no-properties 7)) - ;; Markup part - (mp (list 'invisible 'markdown-markup - 'rear-nonsticky t - 'font-lock-multiline t)) - ;; Link part (without face) - (lp (list 'keymap markdown-mode-mouse-map - 'mouse-face 'markdown-highlight-face - 'font-lock-multiline t - 'help-echo (if title (concat title "\n" url) url))) - ;; URL part - (up (list 'keymap markdown-mode-mouse-map - 'invisible 'markdown-markup - 'mouse-face 'markdown-highlight-face - 'font-lock-multiline t)) - ;; URL composition character - (url-char (markdown--first-displayable markdown-url-compose-char)) - ;; Title part - (tp (list 'invisible 'markdown-markup - 'font-lock-multiline t))) - (dolist (g '(1 2 4 5 8)) - (when (match-end g) - (add-text-properties (match-beginning g) (match-end g) mp) - (add-face-text-property (match-beginning g) (match-end g) 'markdown-markup-face))) - ;; Preserve existing faces applied to link part (e.g., inline code) - (when link-start - (add-text-properties link-start link-end lp) - (add-face-text-property link-start link-end 'markdown-link-face)) - (when url-start - (add-text-properties url-start url-end up) - (add-face-text-property url-start url-end 'markdown-url-face)) - (when title-start - (add-text-properties url-end title-end tp) - (add-face-text-property url-end title-end 'markdown-link-title-face)) - (when (and markdown-hide-urls url-start) - (compose-region url-start (or title-end url-end) url-char)) - t))) - -(defun markdown-fontify-reference-links (last) - "Add text properties to next reference link from point to LAST." - (when (markdown-match-generic-links last t) - (let* ((link-start (match-beginning 3)) - (link-end (match-end 3)) - (ref-start (match-beginning 6)) - (ref-end (match-end 6)) - ;; Markup part - (mp (list 'invisible 'markdown-markup - 'rear-nonsticky t - 'font-lock-multiline t)) - ;; Link part - (lp (list 'keymap markdown-mode-mouse-map - 'mouse-face 'markdown-highlight-face - 'font-lock-multiline t - 'help-echo (lambda (_ __ pos) - (save-match-data - (save-excursion - (goto-char pos) - (or (markdown-link-url) - "Undefined reference")))))) - ;; URL composition character - (url-char (markdown--first-displayable markdown-url-compose-char)) - ;; Reference part - (rp (list 'invisible 'markdown-markup - 'font-lock-multiline t))) - (dolist (g '(1 2 4 5 8)) - (when (match-end g) - (add-text-properties (match-beginning g) (match-end g) mp) - (add-face-text-property (match-beginning g) (match-end g) 'markdown-markup-face))) - (when link-start - (add-text-properties link-start link-end lp) - (add-face-text-property link-start link-end 'markdown-link-face)) - (when ref-start - (add-text-properties ref-start ref-end rp) - (add-face-text-property ref-start ref-end 'markdown-reference-face) - (when (and markdown-hide-urls (> (- ref-end ref-start) 2)) - (compose-region ref-start ref-end url-char))) - t))) - -(defun markdown-fontify-angle-uris (last) - "Add text properties to angle URIs from point to LAST." - (when (markdown-match-angle-uris last) - (let* ((url-start (match-beginning 2)) - (url-end (match-end 2)) - ;; Markup part - (mp (list 'face 'markdown-markup-face - 'invisible 'markdown-markup - 'rear-nonsticky t - 'font-lock-multiline t)) - ;; URI part - (up (list 'keymap markdown-mode-mouse-map - 'face 'markdown-plain-url-face - 'mouse-face 'markdown-highlight-face - 'font-lock-multiline t))) - (dolist (g '(1 3)) - (add-text-properties (match-beginning g) (match-end g) mp)) - (add-text-properties url-start url-end up) - t))) - -(defun markdown-fontify-plain-uris (last) - "Add text properties to plain URLs from point to LAST." - (when (markdown-match-plain-uris last) - (let* ((start (match-beginning 0)) - (end (match-end 0)) - (props (list 'keymap markdown-mode-mouse-map - 'face 'markdown-plain-url-face - 'mouse-face 'markdown-highlight-face - 'rear-nonsticky t - 'font-lock-multiline t))) - (add-text-properties start end props) - t))) - -(defun markdown-toggle-url-hiding (&optional arg) - "Toggle the display or hiding of URLs. -With a prefix argument ARG, enable URL hiding if ARG is positive, -and disable it otherwise." - (interactive (list (or current-prefix-arg 'toggle))) - (setq markdown-hide-urls - (if (eq arg 'toggle) - (not markdown-hide-urls) - (> (prefix-numeric-value arg) 0))) - (when (called-interactively-p 'interactive) - (message "markdown-mode URL hiding %s" (if markdown-hide-urls "enabled" "disabled"))) - (markdown-reload-extensions)) - - -;;; Wiki Links ================================================================ - -(defun markdown-wiki-link-p () - "Return non-nil if wiki links are enabled and `point' is at a true wiki link. -A true wiki link name matches `markdown-regex-wiki-link' but does -not match the current file name after conversion. This modifies -the data returned by `match-data'. Note that the potential wiki -link name must be available via `match-string'." - (when markdown-enable-wiki-links - (let ((case-fold-search nil)) - (and (thing-at-point-looking-at markdown-regex-wiki-link) - (not (markdown-code-block-at-point-p)) - (or (not buffer-file-name) - (not (string-equal (buffer-file-name) - (markdown-convert-wiki-link-to-filename - (markdown-wiki-link-link))))))))) - -(defun markdown-wiki-link-link () - "Return the link part of the wiki link using current match data. -The location of the link component depends on the value of -`markdown-wiki-link-alias-first'." - (if markdown-wiki-link-alias-first - (or (match-string-no-properties 5) (match-string-no-properties 3)) - (match-string-no-properties 3))) - -(defun markdown-wiki-link-alias () - "Return the alias or text part of the wiki link using current match data. -The location of the alias component depends on the value of -`markdown-wiki-link-alias-first'." - (if markdown-wiki-link-alias-first - (match-string-no-properties 3) - (or (match-string-no-properties 5) (match-string-no-properties 3)))) - -(defun markdown--wiki-link-search-types () - (let ((ret (and markdown-wiki-link-search-type - (cl-copy-list markdown-wiki-link-search-type)))) - (when (and markdown-wiki-link-search-subdirectories - (not (memq 'sub-directories markdown-wiki-link-search-type))) - (push 'sub-directories ret)) - (when (and markdown-wiki-link-search-parent-directories - (not (memq 'parent-directories markdown-wiki-link-search-type))) - (push 'parent-directories ret)) - ret)) - -(defun markdown--project-root () - (or (cl-loop for dir in '(".git" ".hg" ".svn") - when (locate-dominating-file default-directory dir) - return it) - (progn - (require 'project) - (let ((project (project-current t))) - (with-no-warnings - (if (fboundp 'project-root) - (project-root project) - (car (project-roots project)))))))) - -(defun markdown-convert-wiki-link-to-filename (name) - "Generate a filename from the wiki link NAME. -Spaces in NAME are replaced with `markdown-link-space-sub-char'. -When in `gfm-mode', follow GitHub's conventions where [[Test Test]] -and [[test test]] both map to Test-test.ext. Look in the current -directory first, then in subdirectories if -`markdown-wiki-link-search-subdirectories' is non-nil, and then -in parent directories if -`markdown-wiki-link-search-parent-directories' is non-nil." - (save-match-data - ;; This function must not overwrite match data(PR #590) - (let* ((basename (replace-regexp-in-string - "[[:space:]\n]" markdown-link-space-sub-char name)) - (basename (if (derived-mode-p 'gfm-mode) - (concat (upcase (substring basename 0 1)) - (downcase (substring basename 1 nil))) - basename)) - (search-types (markdown--wiki-link-search-types)) - directory extension default candidates dir) - (when buffer-file-name - (setq directory (file-name-directory buffer-file-name) - extension (file-name-extension buffer-file-name))) - (setq default (concat basename - (when extension (concat "." extension)))) - (cond - ;; Look in current directory first. - ((or (null buffer-file-name) - (file-exists-p default)) - default) - ;; Possibly search in subdirectories, next. - ((and (memq 'sub-directories search-types) - (setq candidates - (directory-files-recursively - directory (concat "^" default "$")))) - (car candidates)) - ;; Possibly search in parent directories as a last resort. - ((and (memq 'parent-directories search-types) - (setq dir (locate-dominating-file directory default))) - (concat dir default)) - ((and (memq 'project search-types) - (setq candidates - (directory-files-recursively - (markdown--project-root) (concat "^" default "$")))) - (car candidates)) - ;; If nothing is found, return default in current directory. - (t default))))) - -(defun markdown-follow-wiki-link (name &optional other) - "Follow the wiki link NAME. -Convert the name to a file name and call `find-file'. Ensure that -the new buffer remains in `markdown-mode'. Open the link in another -window when OTHER is non-nil." - (let ((filename (markdown-convert-wiki-link-to-filename name)) - (wp (when buffer-file-name - (file-name-directory buffer-file-name)))) - (if (not wp) - (user-error "Must be visiting a file") - (when other (other-window 1)) - (let ((default-directory wp)) - (find-file filename))) - (unless (derived-mode-p 'markdown-mode) - (markdown-mode)))) - -(defun markdown-follow-wiki-link-at-point (&optional arg) - "Find Wiki Link at point. -With prefix argument ARG, open the file in other window. -See `markdown-wiki-link-p' and `markdown-follow-wiki-link'." - (interactive "P") - (if (markdown-wiki-link-p) - (markdown-follow-wiki-link (markdown-wiki-link-link) arg) - (user-error "Point is not at a Wiki Link"))) - -(defun markdown-highlight-wiki-link (from to face) - "Highlight the wiki link in the region between FROM and TO using FACE." - (put-text-property from to 'font-lock-face face)) - -(defun markdown-unfontify-region-wiki-links (from to) - "Remove wiki link faces from the region specified by FROM and TO." - (interactive "*r") - (let ((modified (buffer-modified-p))) - (remove-text-properties from to '(font-lock-face markdown-link-face)) - (remove-text-properties from to '(font-lock-face markdown-missing-link-face)) - ;; remove-text-properties marks the buffer modified in emacs 24.3, - ;; undo that if it wasn't originally marked modified - (set-buffer-modified-p modified))) - -(defun markdown-fontify-region-wiki-links (from to) - "Search region given by FROM and TO for wiki links and fontify them. -If a wiki link is found check to see if the backing file exists -and highlight accordingly." - (goto-char from) - (save-match-data - (while (re-search-forward markdown-regex-wiki-link to t) - (when (not (markdown-code-block-at-point-p)) - (let ((highlight-beginning (match-beginning 1)) - (highlight-end (match-end 1)) - (file-name - (markdown-convert-wiki-link-to-filename - (markdown-wiki-link-link)))) - (if (condition-case nil (file-exists-p file-name) (error nil)) - (markdown-highlight-wiki-link - highlight-beginning highlight-end 'markdown-link-face) - (markdown-highlight-wiki-link - highlight-beginning highlight-end 'markdown-missing-link-face))))))) - -(defun markdown-extend-changed-region (from to) - "Extend region given by FROM and TO so that we can fontify all links. -The region is extended to the first newline before and the first -newline after." - ;; start looking for the first new line before 'from - (goto-char from) - (re-search-backward "\n" nil t) - (let ((new-from (point-min)) - (new-to (point-max))) - (if (not (= (point) from)) - (setq new-from (point))) - ;; do the same thing for the first new line after 'to - (goto-char to) - (re-search-forward "\n" nil t) - (if (not (= (point) to)) - (setq new-to (point))) - (cl-values new-from new-to))) - -(defun markdown-check-change-for-wiki-link (from to) - "Check region between FROM and TO for wiki links and re-fontify as needed." - (interactive "*r") - (let* ((modified (buffer-modified-p)) - (buffer-undo-list t) - (inhibit-read-only t) - deactivate-mark - buffer-file-truename) - (unwind-protect - (save-excursion - (save-match-data - (save-restriction - (cursor-intangible-mode +1) ;; inhibit-point-motion-hooks is obsoleted since Emacs 29 - ;; Extend the region to fontify so that it starts - ;; and ends at safe places. - (cl-multiple-value-bind (new-from new-to) - (markdown-extend-changed-region from to) - (goto-char new-from) - ;; Only refontify when the range contains text with a - ;; wiki link face or if the wiki link regexp matches. - (when (or (markdown-range-property-any - new-from new-to 'font-lock-face - '(markdown-link-face markdown-missing-link-face)) - (re-search-forward - markdown-regex-wiki-link new-to t)) - ;; Unfontify existing fontification (start from scratch) - (markdown-unfontify-region-wiki-links new-from new-to) - ;; Now do the fontification. - (markdown-fontify-region-wiki-links new-from new-to)))))) - (cursor-intangible-mode -1) - (and (not modified) - (buffer-modified-p) - (set-buffer-modified-p nil))))) - -(defun markdown-check-change-for-wiki-link-after-change (from to _) - "Check region between FROM and TO for wiki links and re-fontify as needed. -Designed to be used with the `after-change-functions' hook." - (markdown-check-change-for-wiki-link from to)) - -(defun markdown-fontify-buffer-wiki-links () - "Refontify all wiki links in the buffer." - (interactive) - (markdown-check-change-for-wiki-link (point-min) (point-max))) - -(defun markdown-toggle-wiki-links (&optional arg) - "Toggle support for wiki links. -With a prefix argument ARG, enable wiki link support if ARG is positive, -and disable it otherwise." - (interactive (list (or current-prefix-arg 'toggle))) - (setq markdown-enable-wiki-links - (if (eq arg 'toggle) - (not markdown-enable-wiki-links) - (> (prefix-numeric-value arg) 0))) - (when (called-interactively-p 'interactive) - (message "markdown-mode wiki link support %s" (if markdown-enable-wiki-links "enabled" "disabled"))) - (markdown-reload-extensions)) - -(defun markdown-setup-wiki-link-hooks () - "Add or remove hooks for fontifying wiki links. -These are only enabled when `markdown-wiki-link-fontify-missing' is non-nil." - ;; Anytime text changes make sure it gets fontified correctly - (if (and markdown-enable-wiki-links - markdown-wiki-link-fontify-missing) - (add-hook 'after-change-functions - #'markdown-check-change-for-wiki-link-after-change t t) - (remove-hook 'after-change-functions - #'markdown-check-change-for-wiki-link-after-change t)) - ;; If we left the buffer there is a really good chance we were - ;; creating one of the wiki link documents. Make sure we get - ;; refontified when we come back. - (if (and markdown-enable-wiki-links - markdown-wiki-link-fontify-missing) - (progn - (add-hook 'window-configuration-change-hook - #'markdown-fontify-buffer-wiki-links t t) - (markdown-fontify-buffer-wiki-links)) - (remove-hook 'window-configuration-change-hook - #'markdown-fontify-buffer-wiki-links t) - (markdown-unfontify-region-wiki-links (point-min) (point-max)))) - - -;;; Following & Doing ========================================================= - -(defun markdown-follow-thing-at-point (arg) - "Follow thing at point if possible, such as a reference link or wiki link. -Opens inline and reference links in a browser. Opens wiki links -to other files in the current window, or the another window if -ARG is non-nil. -See `markdown-follow-link-at-point' and -`markdown-follow-wiki-link-at-point'." - (interactive "P") - (cond ((markdown-link-p) - (markdown-follow-link-at-point)) - ((markdown-wiki-link-p) - (markdown-follow-wiki-link-at-point arg)) - (t - (let* ((values (markdown-link-at-pos (point))) - (url (nth 3 values))) - (unless url - (user-error "Nothing to follow at point")) - (markdown--browse-url url))))) - -(defun markdown-do () - "Do something sensible based on context at point. -Jumps between reference links and definitions; between footnote -markers and footnote text." - (interactive) - (cond - ;; Footnote definition - ((markdown-footnote-text-positions) - (markdown-footnote-return)) - ;; Footnote marker - ((markdown-footnote-marker-positions) - (markdown-footnote-goto-text)) - ;; Reference link - ((thing-at-point-looking-at markdown-regex-link-reference) - (markdown-reference-goto-definition)) - ;; Reference definition - ((thing-at-point-looking-at markdown-regex-reference-definition) - (markdown-reference-goto-link (match-string-no-properties 2))) - ;; Link - ((or (markdown-link-p) (markdown-wiki-link-p)) - (markdown-follow-thing-at-point nil)) - ;; GFM task list item - ((markdown-gfm-task-list-item-at-point) - (markdown-toggle-gfm-checkbox)) - ;; Align table - ((markdown-table-at-point-p) - (call-interactively #'markdown-table-align)) - ;; Otherwise - (t - (markdown-insert-gfm-checkbox)))) - - -;;; Miscellaneous ============================================================= - -(defun markdown-compress-whitespace-string (str) - "Compress whitespace in STR and return result. -Leading and trailing whitespace is removed. Sequences of multiple -spaces, tabs, and newlines are replaced with single spaces." - (replace-regexp-in-string "\\(^[ \t\n]+\\|[ \t\n]+$\\)" "" - (replace-regexp-in-string "[ \t\n]+" " " str))) - -(defun markdown--substitute-command-keys (string) - "Like `substitute-command-keys' but, but prefers control characters. -First pass STRING to `substitute-command-keys' and then -substitute `C-i` for `TAB` and `C-m` for `RET`." - (replace-regexp-in-string - "\\<TAB\\>" "C-i" - (replace-regexp-in-string - "\\<RET\\>" "C-m" (substitute-command-keys string) t) t)) - -(defun markdown-line-number-at-pos (&optional pos) - "Return (narrowed) buffer line number at position POS. -If POS is nil, use current buffer location. -This is an exact copy of `line-number-at-pos' for use in emacs21." - (let ((opoint (or pos (point))) start) - (save-excursion - (goto-char (point-min)) - (setq start (point)) - (goto-char opoint) - (forward-line 0) - (1+ (count-lines start (point)))))) - -(defun markdown-inside-link-p () - "Return t if point is within a link." - (save-match-data - (thing-at-point-looking-at (markdown-make-regex-link-generic)))) - -(defun markdown-line-is-reference-definition-p () - "Return whether the current line is a (non-footnote) reference definition." - (save-excursion - (move-beginning-of-line 1) - (and (looking-at-p markdown-regex-reference-definition) - (not (looking-at-p "[ \t]*\\[^"))))) - -(defun markdown-adaptive-fill-function () - "Return prefix for filling paragraph or nil if not determined." - (cond - ;; List item inside blockquote - ((looking-at "^[ \t]*>[ \t]*\\(\\(?:[0-9]+\\|#\\)\\.\\|[*+:-]\\)[ \t]+") - (replace-regexp-in-string - "[0-9\\.*+-]" " " (match-string-no-properties 0))) - ;; Blockquote - ((looking-at markdown-regex-blockquote) - (buffer-substring-no-properties (match-beginning 0) (match-end 2))) - ;; List items - ((looking-at markdown-regex-list) - (match-string-no-properties 0)) - ;; Footnote definition - ((looking-at-p markdown-regex-footnote-definition) - " ") ; four spaces - ;; No match - (t nil))) - -(defun markdown-fill-paragraph (&optional justify) - "Fill paragraph at or after point. -This function is like \\[fill-paragraph], but it skips Markdown -code blocks. If the point is in a code block, or just before one, -do not fill. Otherwise, call `fill-paragraph' as usual. If -JUSTIFY is non-nil, justify text as well. Since this function -handles filling itself, it always returns t so that -`fill-paragraph' doesn't run." - (interactive "P") - (unless (or (markdown-code-block-at-point-p) - (save-excursion - (back-to-indentation) - (skip-syntax-forward "-") - (markdown-code-block-at-point-p))) - (let ((fill-prefix (save-excursion - (goto-char (line-beginning-position)) - (when (looking-at "\\([ \t]*>[ \t]*\\(?:>[ \t]*\\)+\\)") - (match-string-no-properties 1))))) - (fill-paragraph justify))) - t) - -(defun markdown-fill-forward-paragraph (&optional arg) - "Function used by `fill-paragraph' to move over ARG paragraphs. -This is a `fill-forward-paragraph-function' for `markdown-mode'. -It is called with a single argument specifying the number of -paragraphs to move. Just like `forward-paragraph', it should -return the number of paragraphs left to move." - (or arg (setq arg 1)) - (if (> arg 0) - ;; With positive ARG, move across ARG non-code-block paragraphs, - ;; one at a time. When passing a code block, don't decrement ARG. - (while (and (not (eobp)) - (> arg 0) - (= (forward-paragraph 1) 0) - (or (markdown-code-block-at-pos (line-beginning-position 0)) - (setq arg (1- arg))))) - ;; Move backward by one paragraph with negative ARG (always -1). - (let ((start (point))) - (setq arg (forward-paragraph arg)) - (while (and (not (eobp)) - (progn (move-to-left-margin) (not (eobp))) - (looking-at-p paragraph-separate)) - (forward-line 1)) - (cond - ;; Move point past whitespace following list marker. - ((looking-at markdown-regex-list) - (goto-char (match-end 0))) - ;; Move point past whitespace following pipe at beginning of line - ;; to handle Pandoc line blocks. - ((looking-at "^|\\s-*") - (goto-char (match-end 0))) - ;; Return point if the paragraph passed was a code block. - ((markdown-code-block-at-pos (line-beginning-position 2)) - (goto-char start))))) - arg) - -(defun markdown--inhibit-electric-quote () - "Function added to `electric-quote-inhibit-functions'. -Return non-nil if the quote has been inserted inside a code block -or span." - (let ((pos (1- (point)))) - (or (markdown-inline-code-at-pos pos) - (markdown-code-block-at-pos pos)))) - - -;;; Extension Framework ======================================================= - -(defun markdown-reload-extensions () - "Check settings, update font-lock keywords and hooks, and re-fontify buffer." - (interactive) - (when (derived-mode-p 'markdown-mode) - ;; Refontify buffer - (font-lock-flush) - ;; Add or remove hooks related to extensions - (markdown-setup-wiki-link-hooks))) - -(defun markdown-handle-local-variables () - "Run in `hack-local-variables-hook' to update font lock rules. -Checks to see if there is actually a ‘markdown-mode’ file local variable -before regenerating font-lock rules for extensions." - (when (or (assoc 'markdown-enable-wiki-links file-local-variables-alist) - (assoc 'markdown-enable-math file-local-variables-alist)) - (when (assoc 'markdown-enable-math file-local-variables-alist) - (markdown-toggle-math markdown-enable-math)) - (markdown-reload-extensions))) - - -;;; Math Support ============================================================== - -(defconst markdown-mode-font-lock-keywords-math - (list - ;; Equation reference (eq:foo) - '("\\((eq:\\)\\([[:alnum:]:_]+\\)\\()\\)" . ((1 markdown-markup-face) - (2 markdown-reference-face) - (3 markdown-markup-face))) - ;; Equation reference \eqref{foo} - '("\\(\\\\eqref{\\)\\([[:alnum:]:_]+\\)\\(}\\)" . ((1 markdown-markup-face) - (2 markdown-reference-face) - (3 markdown-markup-face)))) - "Font lock keywords to add and remove when toggling math support.") - -(defun markdown-toggle-math (&optional arg) - "Toggle support for inline and display LaTeX math expressions. -With a prefix argument ARG, enable math mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." - (interactive (list (or current-prefix-arg 'toggle))) - (setq markdown-enable-math - (if (eq arg 'toggle) - (not markdown-enable-math) - (> (prefix-numeric-value arg) 0))) - (if markdown-enable-math - (font-lock-add-keywords - 'markdown-mode markdown-mode-font-lock-keywords-math) - (font-lock-remove-keywords - 'markdown-mode markdown-mode-font-lock-keywords-math)) - (when (called-interactively-p 'interactive) - (message "markdown-mode math support %s" (if markdown-enable-math "enabled" "disabled"))) - (markdown-reload-extensions)) - - -;;; GFM Checkboxes ============================================================ - -(define-button-type 'markdown-gfm-checkbox-button - 'follow-link t - 'face 'markdown-gfm-checkbox-face - 'mouse-face 'markdown-highlight-face - 'action #'markdown-toggle-gfm-checkbox-button) - -(defun markdown-gfm-task-list-item-at-point (&optional bounds) - "Return non-nil if there is a GFM task list item at the point. -Optionally, the list item BOUNDS may be given if available, as -returned by `markdown-cur-list-item-bounds'. When a task list item -is found, the return value is the same value returned by -`markdown-cur-list-item-bounds'." - (unless bounds - (setq bounds (markdown-cur-list-item-bounds))) - (> (length (nth 5 bounds)) 0)) - -(defun markdown-insert-gfm-checkbox () - "Add GFM checkbox at point. -Returns t if added. -Returns nil if non-applicable." - (interactive) - (let ((bounds (markdown-cur-list-item-bounds))) - (if bounds - (unless (cl-sixth bounds) - (let ((pos (+ (cl-first bounds) (cl-fourth bounds))) - (markup "[ ] ")) - (if (< pos (point)) - (save-excursion - (goto-char pos) - (insert markup)) - (goto-char pos) - (insert markup)) - (syntax-propertize (+ (cl-second bounds) 4)) - t)) - (unless (save-excursion - (back-to-indentation) - (or (markdown-list-item-at-point-p) - (markdown-heading-at-point) - (markdown-in-comment-p) - (markdown-code-block-at-point-p))) - (let ((pos (save-excursion - (back-to-indentation) - (point))) - (markup (concat (or (save-excursion - (beginning-of-line 0) - (cl-fifth (markdown-cur-list-item-bounds))) - markdown-unordered-list-item-prefix) - "[ ] "))) - (if (< pos (point)) - (save-excursion - (goto-char pos) - (insert markup)) - (goto-char pos) - (insert markup)) - (syntax-propertize (line-end-position)) - t))))) - -(defun markdown-toggle-gfm-checkbox () - "Toggle GFM checkbox at point. -Returns the resulting status as a string, either \"[x]\" or \"[ ]\". -Returns nil if there is no task list item at the point." - (interactive) - (save-match-data - (save-excursion - (let ((bounds (markdown-cur-list-item-bounds))) - (when bounds - ;; Move to beginning of task list item - (goto-char (cl-first bounds)) - ;; Advance to column of first non-whitespace after marker - (forward-char (cl-fourth bounds)) - (cond ((looking-at "\\[ \\]") - (replace-match - (if markdown-gfm-uppercase-checkbox "[X]" "[x]") - nil t) - (match-string-no-properties 0)) - ((looking-at "\\[[xX]\\]") - (replace-match "[ ]" nil t) - (match-string-no-properties 0)))))))) - -(defun markdown-toggle-gfm-checkbox-button (button) - "Toggle GFM checkbox BUTTON on click." - (save-match-data - (save-excursion - (goto-char (button-start button)) - (markdown-toggle-gfm-checkbox)))) - -(defun markdown-make-gfm-checkboxes-buttons (start end) - "Make GFM checkboxes buttons in region between START and END." - (save-excursion - (goto-char start) - (let ((case-fold-search t)) - (save-excursion - (while (re-search-forward markdown-regex-gfm-checkbox end t) - (make-button (match-beginning 1) (match-end 1) - :type 'markdown-gfm-checkbox-button)))))) - -;; Called when any modification is made to buffer text. -(defun markdown-gfm-checkbox-after-change-function (beg end _) - "Add to `after-change-functions' to setup GFM checkboxes as buttons. -BEG and END are the limits of scanned region." - (save-excursion - (save-match-data - ;; Rescan between start of line from `beg' and start of line after `end'. - (markdown-make-gfm-checkboxes-buttons - (progn (goto-char beg) (beginning-of-line) (point)) - (progn (goto-char end) (forward-line 1) (point)))))) - -(defun markdown-remove-gfm-checkbox-overlays () - "Remove all GFM checkbox overlays in buffer." - (save-excursion - (save-restriction - (widen) - (remove-overlays nil nil 'face 'markdown-gfm-checkbox-face)))) - - -;;; Display inline image ====================================================== - -(defvar-local markdown-inline-image-overlays nil) - -(defun markdown-remove-inline-images () - "Remove inline image overlays from image links in the buffer. -This can be toggled with `markdown-toggle-inline-images' -or \\[markdown-toggle-inline-images]." - (interactive) - (mapc #'delete-overlay markdown-inline-image-overlays) - (setq markdown-inline-image-overlays nil) - (when (fboundp 'clear-image-cache) (clear-image-cache))) - -(defcustom markdown-display-remote-images nil - "If non-nil, download and display remote images. -See also `markdown-inline-image-overlays'. - -Only image URLs specified with a protocol listed in -`markdown-remote-image-protocols' are displayed." - :group 'markdown - :type 'boolean) - -(defcustom markdown-remote-image-protocols '("https") - "List of protocols to use to download remote images. -See also `markdown-display-remote-images'." - :group 'markdown - :type '(repeat string)) - -(defvar markdown--remote-image-cache - (make-hash-table :test 'equal) - "A map from URLs to image paths.") - -(defun markdown--get-remote-image (url) - "Retrieve the image path for a given URL." - (or (gethash url markdown--remote-image-cache) - (let ((dl-path (make-temp-file "markdown-mode--image"))) - (require 'url) - (url-copy-file url dl-path t) - (puthash url dl-path markdown--remote-image-cache)))) - -(defun markdown-display-inline-images () - "Add inline image overlays to image links in the buffer. -This can be toggled with `markdown-toggle-inline-images' -or \\[markdown-toggle-inline-images]." - (interactive) - (unless (display-images-p) - (error "Cannot show images")) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward markdown-regex-link-inline nil t) - (let* ((start (match-beginning 0)) - (imagep (match-beginning 1)) - (end (match-end 0)) - (file (match-string-no-properties 6))) - (when (and imagep - (not (zerop (length file)))) - (unless (file-exists-p file) - (let* ((download-file (funcall markdown-translate-filename-function file)) - (valid-url (ignore-errors - (member (downcase (url-type (url-generic-parse-url download-file))) - markdown-remote-image-protocols)))) - (if (and markdown-display-remote-images valid-url) - (setq file (markdown--get-remote-image download-file)) - (when (not valid-url) - ;; strip query parameter - (setq file (replace-regexp-in-string "?.+\\'" "" file)) - (unless (file-exists-p file) - (setq file (url-unhex-string file))))))) - (when (file-exists-p file) - (let* ((abspath (if (file-name-absolute-p file) - file - (concat default-directory file))) - (image - (cond ((and markdown-max-image-size - (image-type-available-p 'imagemagick)) - (create-image - abspath 'imagemagick nil - :max-width (car markdown-max-image-size) - :max-height (cdr markdown-max-image-size))) - (markdown-max-image-size - (create-image abspath nil nil - :max-width (car markdown-max-image-size) - :max-height (cdr markdown-max-image-size))) - (t (create-image abspath))))) - (when image - (let ((ov (make-overlay start end))) - (overlay-put ov 'display image) - (overlay-put ov 'face 'default) - (push ov markdown-inline-image-overlays))))))))))) - -(defun markdown-toggle-inline-images () - "Toggle inline image overlays in the buffer." - (interactive) - (if markdown-inline-image-overlays - (markdown-remove-inline-images) - (markdown-display-inline-images))) - - -;;; GFM Code Block Fontification ============================================== - -(defcustom markdown-fontify-code-blocks-natively nil - "When non-nil, fontify code in code blocks using the native major mode. -This only works for fenced code blocks where the language is -specified where we can automatically determine the appropriate -mode to use. The language to mode mapping may be customized by -setting the variable `markdown-code-lang-modes'." - :group 'markdown - :type 'boolean - :safe #'booleanp - :package-version '(markdown-mode . "2.3")) - -(defcustom markdown-fontify-code-block-default-mode nil - "Default mode to use to fontify code blocks. -This mode is used when automatic detection fails, such as for GFM -code blocks with no language specified." - :group 'markdown - :type '(choice function (const :tag "None" nil)) - :package-version '(markdown-mode . "2.4")) - -(defun markdown-toggle-fontify-code-blocks-natively (&optional arg) - "Toggle the native fontification of code blocks. -With a prefix argument ARG, enable if ARG is positive, -and disable otherwise." - (interactive (list (or current-prefix-arg 'toggle))) - (setq markdown-fontify-code-blocks-natively - (if (eq arg 'toggle) - (not markdown-fontify-code-blocks-natively) - (> (prefix-numeric-value arg) 0))) - (when (called-interactively-p 'interactive) - (message "markdown-mode native code block fontification %s" - (if markdown-fontify-code-blocks-natively "enabled" "disabled"))) - (markdown-reload-extensions)) - -;; This is based on `org-src-lang-modes' from org-src.el -(defcustom markdown-code-lang-modes - '(("ocaml" . tuareg-mode) ("elisp" . emacs-lisp-mode) ("ditaa" . artist-mode) - ("asymptote" . asy-mode) ("dot" . fundamental-mode) ("sqlite" . sql-mode) - ("calc" . fundamental-mode) ("C" . c-mode) ("cpp" . c++-mode) - ("C++" . c++-mode) ("screen" . shell-script-mode) ("shell" . sh-mode) - ("bash" . sh-mode)) - "Alist mapping languages to their major mode. -The key is the language name, the value is the major mode. For -many languages this is simple, but for language where this is not -the case, this variable provides a way to simplify things on the -user side. For example, there is no ocaml-mode in Emacs, but the -mode to use is `tuareg-mode'." - :group 'markdown - :type '(repeat - (cons - (string "Language name") - (symbol "Major mode"))) - :package-version '(markdown-mode . "2.3")) - -(defun markdown-get-lang-mode (lang) - "Return major mode that should be used for LANG. -LANG is a string, and the returned major mode is a symbol." - (cl-find-if - #'markdown--lang-mode-predicate - (nconc (list (cdr (assoc lang markdown-code-lang-modes)) - (cdr (assoc (downcase lang) markdown-code-lang-modes))) - (and (fboundp 'treesit-language-available-p) - (list (and (treesit-language-available-p (intern lang)) - (intern (concat lang "-ts-mode"))) - (and (treesit-language-available-p (intern (downcase lang))) - (intern (concat (downcase lang) "-ts-mode"))))) - (list - (intern (concat lang "-mode")) - (intern (concat (downcase lang) "-mode")))))) - -(defun markdown--lang-mode-predicate (mode) - (and mode - (fboundp mode) - (or - ;; https://github.com/jrblevin/markdown-mode/issues/787 - ;; major-mode-remap-alist was introduced at Emacs 29.1 - (cl-loop for pair in (bound-and-true-p major-mode-remap-alist) - for func = (cdr pair) - thereis (and (atom func) (eq mode func))) - ;; https://github.com/jrblevin/markdown-mode/issues/761 - (cl-loop for pair in auto-mode-alist - for func = (cdr pair) - thereis (and (atom func) (eq mode func)))))) - -(defun markdown-fontify-code-blocks-generic (matcher last) - "Add text properties to next code block from point to LAST. -Use matching function MATCHER." - (when (funcall matcher last) - (save-excursion - (save-match-data - (let* ((start (match-beginning 0)) - (end (match-end 0)) - ;; Find positions outside opening and closing backquotes. - (bol-prev (progn (goto-char start) - (if (bolp) (line-beginning-position 0) (line-beginning-position)))) - (eol-next (progn (goto-char end) - (if (bolp) (line-beginning-position 2) (line-beginning-position 3)))) - lang) - (if (and markdown-fontify-code-blocks-natively - (or (setq lang (markdown-code-block-lang)) - markdown-fontify-code-block-default-mode)) - (markdown-fontify-code-block-natively lang start end) - (add-text-properties start end '(face markdown-pre-face))) - ;; Set background for block as well as opening and closing lines. - (font-lock-append-text-property - bol-prev eol-next 'face 'markdown-code-face) - ;; Set invisible property for lines before and after, including newline. - (add-text-properties bol-prev start '(invisible markdown-markup)) - (add-text-properties end eol-next '(invisible markdown-markup))))) - t)) - -(defun markdown-fontify-gfm-code-blocks (last) - "Add text properties to next GFM code block from point to LAST." - (markdown-fontify-code-blocks-generic 'markdown-match-gfm-code-blocks last)) - -(defun markdown-fontify-fenced-code-blocks (last) - "Add text properties to next tilde fenced code block from point to LAST." - (markdown-fontify-code-blocks-generic 'markdown-match-fenced-code-blocks last)) - -;; Based on `org-src-font-lock-fontify-block' from org-src.el. -(defun markdown-fontify-code-block-natively (lang start end) - "Fontify given GFM or fenced code block. -This function is called by Emacs for automatic fontification when -`markdown-fontify-code-blocks-natively' is non-nil. LANG is the -language used in the block. START and END specify the block -position." - (let ((lang-mode (if lang (markdown-get-lang-mode lang) - markdown-fontify-code-block-default-mode))) - (when (fboundp lang-mode) - (let ((string (buffer-substring-no-properties start end)) - (modified (buffer-modified-p)) - (markdown-buffer (current-buffer)) pos next) - (remove-text-properties start end '(face nil)) - (with-current-buffer - (get-buffer-create - (format " *markdown-code-fontification:%s*" (symbol-name lang-mode))) - ;; Make sure that modification hooks are not inhibited in - ;; the org-src-fontification buffer in case we're called - ;; from `jit-lock-function' (Bug#25132). - (let ((inhibit-modification-hooks nil)) - (delete-region (point-min) (point-max)) - (insert string " ")) ;; so there's a final property change - (unless (eq major-mode lang-mode) (funcall lang-mode)) - (font-lock-ensure) - (setq pos (point-min)) - (while (setq next (next-single-property-change pos 'face)) - (let ((val (get-text-property pos 'face))) - (when val - (put-text-property - (+ start (1- pos)) (1- (+ start next)) 'face - val markdown-buffer))) - (setq pos next))) - (add-text-properties - start end - '(font-lock-fontified t fontified t font-lock-multiline t)) - (set-buffer-modified-p modified))))) - -(require 'edit-indirect nil t) -(defvar edit-indirect-guess-mode-function) -(defvar edit-indirect-after-commit-functions) - -(defun markdown--edit-indirect-after-commit-function (beg end) - "Corrective logic run on code block content from lines BEG to END. -Restores code block indentation from BEG to END, and ensures trailing newlines -at the END of code blocks." - ;; ensure trailing newlines - (goto-char end) - (unless (eq (char-before) ?\n) - (insert "\n")) - ;; restore code block indentation - (goto-char (- beg 1)) - (let ((block-indentation (current-indentation))) - (when (> block-indentation 0) - (indent-rigidly beg end block-indentation))) - (font-lock-ensure)) - -(defun markdown-edit-code-block () - "Edit Markdown code block in an indirect buffer." - (interactive) - (save-excursion - (if (fboundp 'edit-indirect-region) - (let* ((bounds (markdown-get-enclosing-fenced-block-construct)) - (begin (and bounds (not (null (nth 0 bounds))) (goto-char (nth 0 bounds)) (line-beginning-position 2))) - (end (and bounds(not (null (nth 1 bounds))) (goto-char (nth 1 bounds)) (line-beginning-position 1)))) - (if (and begin end) - (let* ((indentation (and (goto-char (nth 0 bounds)) (current-indentation))) - (lang (markdown-code-block-lang)) - (mode (or (and lang (markdown-get-lang-mode lang)) - markdown-edit-code-block-default-mode)) - (edit-indirect-guess-mode-function - (lambda (_parent-buffer _beg _end) - (funcall mode))) - (indirect-buf (edit-indirect-region begin end 'display-buffer))) - ;; reset `sh-shell' when indirect buffer - (when (and (not (member system-type '(ms-dos windows-nt))) - (member mode '(shell-script-mode sh-mode)) - (member lang (append - (mapcar (lambda (e) (symbol-name (car e))) - sh-ancestor-alist) - '("csh" "rc" "sh")))) - (with-current-buffer indirect-buf - (sh-set-shell lang))) - (when (> indentation 0) ;; un-indent in edit-indirect buffer - (with-current-buffer indirect-buf - (indent-rigidly (point-min) (point-max) (- indentation))))) - (user-error "Not inside a GFM or tilde fenced code block"))) - (when (y-or-n-p "Package edit-indirect needed to edit code blocks. Install it now? ") - (progn (package-refresh-contents) - (package-install 'edit-indirect) - (markdown-edit-code-block)))))) - - -;;; Table Editing ============================================================= - -;; These functions were originally adapted from `org-table.el'. - -;; General helper functions - -(defmacro markdown--with-gensyms (symbols &rest body) - (declare (debug (sexp body)) (indent 1)) - `(let ,(mapcar (lambda (s) - `(,s (make-symbol (concat "--" (symbol-name ',s))))) - symbols) - ,@body)) - -(defun markdown--split-string (string &optional separators) - "Splits STRING into substrings at SEPARATORS. -SEPARATORS is a regular expression. If nil it defaults to -`split-string-default-separators'. This version returns no empty -strings if there are matches at the beginning and end of string." - (let ((start 0) notfirst list) - (while (and (string-match - (or separators split-string-default-separators) - string - (if (and notfirst - (= start (match-beginning 0)) - (< start (length string))) - (1+ start) start)) - (< (match-beginning 0) (length string))) - (setq notfirst t) - (or (eq (match-beginning 0) 0) - (and (eq (match-beginning 0) (match-end 0)) - (eq (match-beginning 0) start)) - (push (substring string start (match-beginning 0)) list)) - (setq start (match-end 0))) - (or (eq start (length string)) - (push (substring string start) list)) - (nreverse list))) - -(defun markdown--string-width (s) - "Return width of string S. -This version ignores characters with invisibility property -`markdown-markup'." - (let (b) - (when (or (eq t buffer-invisibility-spec) - (member 'markdown-markup buffer-invisibility-spec)) - (while (setq b (text-property-any - 0 (length s) - 'invisible 'markdown-markup s)) - (setq s (concat - (substring s 0 b) - (substring s (or (next-single-property-change - b 'invisible s) - (length s)))))))) - (string-width s)) - -(defun markdown--remove-invisible-markup (s) - "Remove Markdown markup from string S. -This version removes characters with invisibility property -`markdown-markup'." - (let (b) - (while (setq b (text-property-any - 0 (length s) - 'invisible 'markdown-markup s)) - (setq s (concat - (substring s 0 b) - (substring s (or (next-single-property-change - b 'invisible s) - (length s))))))) - s) - -;; Functions for maintaining tables - -(defvar markdown-table-at-point-p-function #'markdown--table-at-point-p - "Function to decide if point is inside a table. - -The indirection serves to differentiate between standard markdown -tables and gfm tables which are less strict about the markup.") - -(defconst markdown-table-line-regexp "^[ \t]*|" - "Regexp matching any line inside a table.") - -(defconst markdown-table-hline-regexp "^[ \t]*|[-:]" - "Regexp matching hline inside a table.") - -(defconst markdown-table-dline-regexp "^[ \t]*|[^-:]" - "Regexp matching dline inside a table.") - -(defun markdown-table-at-point-p () - "Return non-nil when point is inside a table." - (funcall markdown-table-at-point-p-function)) - -(defun markdown--table-at-point-p () - "Return non-nil when point is inside a table." - (save-excursion - (beginning-of-line) - (and (looking-at-p markdown-table-line-regexp) - (not (markdown-code-block-at-point-p))))) - -(defconst gfm-table-line-regexp "^.?*|" - "Regexp matching any line inside a table.") - -(defconst gfm-table-hline-regexp "^-+\\(|-\\)+" - "Regexp matching hline inside a table.") - -;; GFM simplified tables syntax is as follows: -;; - A header line for the column names, this is any text -;; separated by `|'. -;; - Followed by a string -|-|- ..., the number of dashes is optional -;; but must be higher than 1. The number of separators should match -;; the number of columns. -;; - Followed by the rows of data, which has the same format as the -;; header line. -;; Example: -;; -;; foo | bar -;; ------|--------- -;; bar | baz -;; bar | baz -(defun gfm--table-at-point-p () - "Return non-nil when point is inside a gfm-compatible table." - (or (markdown--table-at-point-p) - (save-excursion - (beginning-of-line) - (when (looking-at-p gfm-table-line-regexp) - ;; we might be at the first line of the table, check if the - ;; line below is the hline - (or (save-excursion - (forward-line 1) - (looking-at-p gfm-table-hline-regexp)) - ;; go up to find the header - (catch 'done - (while (looking-at-p gfm-table-line-regexp) - (cond - ((looking-at-p gfm-table-hline-regexp) - (throw 'done t)) - ((bobp) - (throw 'done nil))) - (forward-line -1)) - nil)))))) - -(defun markdown-table-hline-at-point-p () - "Return non-nil when point is on a hline in a table. -This function assumes point is on a table." - (save-excursion - (beginning-of-line) - (looking-at-p markdown-table-hline-regexp))) - -(defun markdown-table-begin () - "Find the beginning of the table and return its position. -This function assumes point is on a table." - (save-excursion - (while (and (not (bobp)) - (markdown-table-at-point-p)) - (forward-line -1)) - (unless (or (eobp) - (markdown-table-at-point-p)) - (forward-line 1)) - (point))) - -(defun markdown-table-end () - "Find the end of the table and return its position. -This function assumes point is on a table." - (save-excursion - (while (and (not (eobp)) - (markdown-table-at-point-p)) - (forward-line 1)) - (point))) - -(defun markdown-table-get-dline () - "Return index of the table data line at point. -This function assumes point is on a table." - (let ((pos (point)) (end (markdown-table-end)) (cnt 0)) - (save-excursion - (goto-char (markdown-table-begin)) - (while (and (re-search-forward - markdown-table-dline-regexp end t) - (setq cnt (1+ cnt)) - (< (line-end-position) pos)))) - cnt)) - -(defun markdown--thing-at-wiki-link (pos) - (when markdown-enable-wiki-links - (save-excursion - (save-match-data - (goto-char pos) - (thing-at-point-looking-at markdown-regex-wiki-link))))) - -(defun markdown-table-get-column () - "Return table column at point. -This function assumes point is on a table." - (let ((pos (point)) (cnt 0)) - (save-excursion - (beginning-of-line) - (while (search-forward "|" pos t) - (when (and (not (looking-back "\\\\|" (line-beginning-position))) - (not (markdown--thing-at-wiki-link (match-beginning 0)))) - (setq cnt (1+ cnt))))) - cnt)) - -(defun markdown-table-get-cell (&optional n) - "Return the content of the cell in column N of current row. -N defaults to column at point. This function assumes point is on -a table." - (and n (markdown-table-goto-column n)) - (skip-chars-backward "^|\n") (backward-char 1) - (if (looking-at "|[^|\r\n]*") - (let* ((pos (match-beginning 0)) - (val (buffer-substring (1+ pos) (match-end 0)))) - (goto-char (min (line-end-position) (+ 2 pos))) - ;; Trim whitespaces - (setq val (replace-regexp-in-string "\\`[ \t]+" "" val) - val (replace-regexp-in-string "[ \t]+\\'" "" val))) - (forward-char 1) "")) - -(defun markdown-table-goto-dline (n) - "Go to the Nth data line in the table at point. -Return t when the line exists, nil otherwise. This function -assumes point is on a table." - (goto-char (markdown-table-begin)) - (let ((end (markdown-table-end)) (cnt 0)) - (while (and (re-search-forward - markdown-table-dline-regexp end t) - (< (setq cnt (1+ cnt)) n))) - (= cnt n))) - -(defun markdown-table-goto-column (n &optional on-delim) - "Go to the Nth column in the table line at point. -With optional argument ON-DELIM, stop with point before the left -delimiter of the cell. If there are less than N cells, just go -beyond the last delimiter. This function assumes point is on a -table." - (beginning-of-line 1) - (when (> n 0) - (while (and (> n 0) (search-forward "|" (line-end-position) t)) - (when (and (not (looking-back "\\\\|" (line-beginning-position))) - (not (markdown--thing-at-wiki-link (match-beginning 0)))) - (cl-decf n))) - (if on-delim - (backward-char 1) - (when (looking-at " ") (forward-char 1))))) - -(defmacro markdown-table-save-cell (&rest body) - "Save cell at point, execute BODY and restore cell. -This function assumes point is on a table." - (declare (debug (body))) - (markdown--with-gensyms (line column) - `(let ((,line (copy-marker (line-beginning-position))) - (,column (markdown-table-get-column))) - (unwind-protect - (progn ,@body) - (goto-char ,line) - (markdown-table-goto-column ,column) - (set-marker ,line nil))))) - -(defun markdown-table-blank-line (s) - "Convert a table line S into a line with blank cells." - (if (string-match "^[ \t]*|-" s) - (setq s (mapconcat - (lambda (x) (if (member x '(?| ?+)) "|" " ")) - s "")) - (with-temp-buffer - (insert s) - (goto-char (point-min)) - (when (re-search-forward "|" nil t) - (let ((cur (point)) - ret) - (while (re-search-forward "|" nil t) - (when (and (not (eql (char-before (match-beginning 0)) ?\\)) - (not (markdown--thing-at-wiki-link (match-beginning 0)))) - (push (make-string (- (match-beginning 0) cur) ? ) ret) - (setq cur (match-end 0)))) - (format "|%s|" (string-join (nreverse ret) "|"))))))) - -(defun markdown-table-colfmt (fmtspec) - "Process column alignment specifier FMTSPEC for tables." - (when (stringp fmtspec) - (mapcar (lambda (x) - (cond ((string-match-p "^:.*:$" x) 'c) - ((string-match-p "^:" x) 'l) - ((string-match-p ":$" x) 'r) - (t 'd))) - (markdown--split-string fmtspec "\\s-*|\\s-*")))) - -(defun markdown--first-column-p (bar-pos) - (save-excursion - (save-match-data - (goto-char bar-pos) - (looking-back "^\\s-*" (line-beginning-position))))) - -(defun markdown--table-line-to-columns (line) - (with-temp-buffer - (insert line) - (goto-char (point-min)) - (let ((cur (point)) - ret) - (while (and (re-search-forward "\\s-*\\(|\\)\\s-*" nil t)) - (when (not (markdown--face-p (match-beginning 1) '(markdown-inline-code-face))) - (if (markdown--first-column-p (match-beginning 1)) - (setq cur (match-end 0)) - (cond ((eql (char-before (match-beginning 1)) ?\\) - ;; keep spaces - (goto-char (match-end 1))) - ((markdown--thing-at-wiki-link (match-beginning 1))) ;; do nothing - (t - (push (buffer-substring-no-properties cur (match-beginning 0)) ret) - (setq cur (match-end 0))))))) - (when (< cur (length line)) - (push (buffer-substring-no-properties cur (point-max)) ret)) - (nreverse ret)))) - -(defsubst markdown--is-delimiter-row (line) - (and (string-match-p "\\`[ \t]*|[ \t]*[-:]" line) - (cl-loop for c across line - always (member c '(?| ?- ?: ?\t ? ))))) - -(defun markdown-table-align () - "Align table at point. -This function assumes point is on a table." - (interactive) - (let ((begin (markdown-table-begin)) - (end (copy-marker (markdown-table-end)))) - (markdown-table-save-cell - (goto-char begin) - (let* (fmtspec - ;; Store table indent - (indent (progn (looking-at "[ \t]*") (match-string 0))) - ;; Split table in lines and save column format specifier - (lines (mapcar (lambda (line) - (if (markdown--is-delimiter-row line) - (progn (setq fmtspec (or fmtspec line)) nil) - line)) - (markdown--split-string (buffer-substring begin end) "\n"))) - ;; Split lines in cells - (cells (mapcar (lambda (l) (markdown--table-line-to-columns l)) - (remq nil lines))) - ;; Calculate maximum number of cells in a line - (maxcells (if cells - (apply #'max (mapcar #'length cells)) - (user-error "Empty table"))) - ;; Empty cells to fill short lines - (emptycells (make-list maxcells "")) - maxwidths) - ;; Calculate maximum width for each column - (dotimes (i maxcells) - (let ((column (mapcar (lambda (x) (or (nth i x) "")) cells))) - (push (apply #'max 1 (mapcar #'markdown--string-width column)) - maxwidths))) - (setq maxwidths (nreverse maxwidths)) - ;; Process column format specifier - (setq fmtspec (markdown-table-colfmt fmtspec)) - ;; Compute formats needed for output of table lines - (let ((hfmt (concat indent "|")) - (rfmt (concat indent "|")) - hfmt1 rfmt1 fmt) - (dolist (width maxwidths (setq hfmt (concat (substring hfmt 0 -1) "|"))) - (setq fmt (pop fmtspec)) - (cond ((equal fmt 'l) (setq hfmt1 ":%s-|" rfmt1 " %%-%ds |")) - ((equal fmt 'r) (setq hfmt1 "-%s:|" rfmt1 " %%%ds |")) - ((equal fmt 'c) (setq hfmt1 ":%s:|" rfmt1 " %%-%ds |")) - (t (setq hfmt1 "-%s-|" rfmt1 " %%-%ds |"))) - (setq rfmt (concat rfmt (format rfmt1 width))) - (setq hfmt (concat hfmt (format hfmt1 (make-string width ?-))))) - ;; Replace modified lines only - (dolist (line lines) - (let ((line (if line - (apply #'format rfmt (append (pop cells) emptycells)) - hfmt)) - (previous (buffer-substring (point) (line-end-position)))) - (if (equal previous line) - (forward-line) - (insert line "\n") - (delete-region (point) (line-beginning-position 2)))))) - (set-marker end nil))))) - -(defun markdown-table-insert-row (&optional arg) - "Insert a new row above the row at point into the table. -With optional argument ARG, insert below the current row." - (interactive "P") - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let* ((line (buffer-substring - (line-beginning-position) (line-end-position))) - (new (markdown-table-blank-line line))) - (beginning-of-line (if arg 2 1)) - (unless (bolp) (insert "\n")) - (insert-before-markers new "\n") - (beginning-of-line 0) - (re-search-forward "| ?" (line-end-position) t))) - -(defun markdown-table-delete-row () - "Delete row or horizontal line at point from the table." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let ((col (current-column))) - (kill-region (line-beginning-position) - (min (1+ (line-end-position)) (point-max))) - (unless (markdown-table-at-point-p) (beginning-of-line 0)) - (move-to-column col))) - -(defun markdown-table-move-row (&optional up) - "Move table line at point down. -With optional argument UP, move it up." - (interactive "P") - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let* ((col (current-column)) (pos (point)) - (tonew (if up 0 2)) txt) - (beginning-of-line tonew) - (unless (markdown-table-at-point-p) - (goto-char pos) (user-error "Cannot move row further")) - (goto-char pos) (beginning-of-line 1) (setq pos (point)) - (setq txt (buffer-substring (point) (1+ (line-end-position)))) - (delete-region (point) (1+ (line-end-position))) - (beginning-of-line tonew) - (insert txt) (beginning-of-line 0) - (move-to-column col))) - -(defun markdown-table-move-row-up () - "Move table row at point up." - (interactive) - (markdown-table-move-row 'up)) - -(defun markdown-table-move-row-down () - "Move table row at point down." - (interactive) - (markdown-table-move-row nil)) - -(defun markdown-table-insert-column () - "Insert a new table column." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let* ((col (max 1 (markdown-table-get-column))) - (begin (markdown-table-begin)) - (end (copy-marker (markdown-table-end)))) - (markdown-table-save-cell - (goto-char begin) - (while (< (point) end) - (markdown-table-goto-column col t) - (if (markdown-table-hline-at-point-p) - (insert "|---") - (insert "| ")) - (forward-line))) - (set-marker end nil) - (when markdown-table-align-p - (markdown-table-align)))) - -(defun markdown-table-delete-column () - "Delete column at point from table." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let ((col (markdown-table-get-column)) - (begin (markdown-table-begin)) - (end (copy-marker (markdown-table-end)))) - (markdown-table-save-cell - (goto-char begin) - (while (< (point) end) - (markdown-table-goto-column col t) - (and (looking-at "|\\(?:\\\\|\\|[^|\n]\\)+|") - (replace-match "|")) - (forward-line))) - (set-marker end nil) - (markdown-table-goto-column (max 1 (1- col))) - (when markdown-table-align-p - (markdown-table-align)))) - -(defun markdown-table-move-column (&optional left) - "Move table column at point to the right. -With optional argument LEFT, move it to the left." - (interactive "P") - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let* ((col (markdown-table-get-column)) - (col1 (if left (1- col) col)) - (colpos (if left (1- col) (1+ col))) - (begin (markdown-table-begin)) - (end (copy-marker (markdown-table-end)))) - (when (and left (= col 1)) - (user-error "Cannot move column further left")) - (when (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) - (user-error "Cannot move column further right")) - (markdown-table-save-cell - (goto-char begin) - (while (< (point) end) - (markdown-table-goto-column col1 t) - (when (looking-at "|\\(\\(?:\\\\|\\|[^|\n]\\|\\)+\\)|\\(\\(?:\\\\|\\|[^|\n]\\|\\)+\\)|") - (replace-match "|\\2|\\1|")) - (forward-line))) - (set-marker end nil) - (markdown-table-goto-column colpos) - (when markdown-table-align-p - (markdown-table-align)))) - -(defun markdown-table-move-column-left () - "Move table column at point to the left." - (interactive) - (markdown-table-move-column 'left)) - -(defun markdown-table-move-column-right () - "Move table column at point to the right." - (interactive) - (markdown-table-move-column nil)) - -(defun markdown-table-next-row () - "Go to the next row (same column) in the table. -Create new table lines if required." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (if (or (looking-at "[ \t]*$") - (save-excursion (skip-chars-backward " \t") (bolp))) - (newline) - (when markdown-table-align-p - (markdown-table-align)) - (let ((col (markdown-table-get-column))) - (beginning-of-line 2) - (if (or (not (markdown-table-at-point-p)) - (markdown-table-hline-at-point-p)) - (progn - (beginning-of-line 0) - (markdown-table-insert-row 'below))) - (markdown-table-goto-column col) - (skip-chars-backward "^|\n\r") - (when (looking-at " ") (forward-char 1))))) - -(defun markdown-table-forward-cell () - "Go to the next cell in the table. -Create new table lines if required." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (when markdown-table-align-p - (markdown-table-align)) - (let ((end (markdown-table-end))) - (when (markdown-table-hline-at-point-p) (end-of-line 1)) - (condition-case nil - (progn - (re-search-forward "\\(?:^\\|[^\\]\\)|" end) - (when (looking-at "[ \t]*$") - (re-search-forward "\\(?:^\\|[^\\]:\\)|" end)) - (when (and (looking-at "[-:]") - (re-search-forward "^\\(?:[ \t]*\\|[^\\]\\)|\\([^-:]\\)" end t)) - (goto-char (match-beginning 1))) - (if (looking-at "[-:]") - (progn - (beginning-of-line 0) - (markdown-table-insert-row 'below)) - (when (looking-at " ") (forward-char 1)))) - (error (markdown-table-insert-row 'below))))) - -(defun markdown-table-backward-cell () - "Go to the previous cell in the table." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (when markdown-table-align-p - (markdown-table-align)) - (when (markdown-table-hline-at-point-p) (beginning-of-line 1)) - (condition-case nil - (progn - (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin)) - ;; When this function is called while in the first cell in a - ;; table, the point will now be at the beginning of a line. In - ;; this case, we need to move past one additional table - ;; boundary, the end of the table on the previous line. - (when (= (point) (line-beginning-position)) - (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin))) - (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin))) - (error (user-error "Cannot move to previous table cell"))) - (when (looking-at "\\(?:^\\|[^\\]\\)| ?") (goto-char (match-end 0))) - - ;; This may have dropped point on the hline. - (when (markdown-table-hline-at-point-p) - (markdown-table-backward-cell))) - -(defun markdown-table-transpose () - "Transpose table at point. -Horizontal separator lines will be eliminated." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - (let* ((table (buffer-substring-no-properties - (markdown-table-begin) (markdown-table-end))) - ;; Convert table to Lisp structure - (table (delq nil - (mapcar - (lambda (x) - (unless (string-match-p - markdown-table-hline-regexp x) - (markdown--table-line-to-columns x))) - (markdown--split-string table "[ \t]*\n[ \t]*")))) - (dline_old (markdown-table-get-dline)) - (col_old (markdown-table-get-column)) - (contents (mapcar (lambda (_) - (let ((tp table)) - (mapcar - (lambda (_) - (prog1 - (pop (car tp)) - (setq tp (cdr tp)))) - table))) - (car table)))) - (goto-char (markdown-table-begin)) - (save-excursion - (re-search-forward "|") (backward-char) - (delete-region (point) (markdown-table-end)) - (insert (mapconcat - (lambda(x) - (concat "| " (mapconcat 'identity x " | " ) " |\n")) - contents ""))) - (markdown-table-goto-dline col_old) - (markdown-table-goto-column dline_old)) - (when markdown-table-align-p - (markdown-table-align))) - -(defun markdown-table-sort-lines (&optional sorting-type) - "Sort table lines according to the column at point. - -The position of point indicates the column to be used for -sorting, and the range of lines is the range between the nearest -horizontal separator lines, or the entire table of no such lines -exist. If point is before the first column, user will be prompted -for the sorting column. If there is an active region, the mark -specifies the first line and the sorting column, while point -should be in the last line to be included into the sorting. - -The command then prompts for the sorting type which can be -alphabetically or numerically. Sorting in reverse order is also -possible. - -If SORTING-TYPE is specified when this function is called from a -Lisp program, no prompting will take place. SORTING-TYPE must be -a character, any of (?a ?A ?n ?N) where the capital letters -indicate that sorting should be done in reverse order." - (interactive) - (unless (markdown-table-at-point-p) - (user-error "Not at a table")) - ;; Set sorting type and column used for sorting - (let ((column (let ((c (markdown-table-get-column))) - (cond ((> c 0) c) - ((called-interactively-p 'any) - (read-number "Use column N for sorting: ")) - (t 1)))) - (sorting-type - (or sorting-type - (progn - ;; workaround #641 - ;; Emacs < 28 hides prompt message by another message. This erases it. - (message "") - (read-char-exclusive - "Sort type: [a]lpha [n]umeric (A/N means reversed): "))))) - (save-restriction - ;; Narrow buffer to appropriate sorting area - (if (region-active-p) - (narrow-to-region - (save-excursion - (progn - (goto-char (region-beginning)) (line-beginning-position))) - (save-excursion - (progn - (goto-char (region-end)) (line-end-position)))) - (let ((start (markdown-table-begin)) - (end (markdown-table-end))) - (narrow-to-region - (save-excursion - (if (re-search-backward - markdown-table-hline-regexp start t) - (line-beginning-position 2) - start)) - (if (save-excursion (re-search-forward - markdown-table-hline-regexp end t)) - (match-beginning 0) - end)))) - ;; Determine arguments for `sort-subr' - (let* ((extract-key-from-cell - (cl-case sorting-type - ((?a ?A) #'markdown--remove-invisible-markup) ;; #'identity) - ((?n ?N) #'string-to-number) - (t (user-error "Invalid sorting type: %c" sorting-type)))) - (predicate - (cl-case sorting-type - ((?n ?N) #'<) - ((?a ?A) #'string<)))) - ;; Sort selected area - (goto-char (point-min)) - (sort-subr (memq sorting-type '(?A ?N)) - (lambda () - (forward-line) - (while (and (not (eobp)) - (not (looking-at - markdown-table-dline-regexp))) - (forward-line))) - #'end-of-line - (lambda () - (funcall extract-key-from-cell - (markdown-table-get-cell column))) - nil - predicate) - (goto-char (point-min)))))) - -(defun markdown-table-convert-region (begin end &optional separator) - "Convert region from BEGIN to END to table with SEPARATOR. - -If every line contains at least one TAB character, the function -assumes that the material is tab separated (TSV). If every line -contains a comma, comma-separated values (CSV) are assumed. If -not, lines are split at whitespace into cells. - -You can use a prefix argument to force a specific separator: -\\[universal-argument] once forces CSV, \\[universal-argument] -twice forces TAB, and \\[universal-argument] three times will -prompt for a regular expression to match the separator, and a -numeric argument N indicates that at least N consecutive -spaces, or alternatively a TAB should be used as the separator." - - (interactive "r\nP") - (let* ((begin (min begin end)) (end (max begin end)) re) - (goto-char begin) (beginning-of-line 1) - (setq begin (point-marker)) - (goto-char end) - (if (bolp) (backward-char 1) (end-of-line 1)) - (setq end (point-marker)) - (when (equal separator '(64)) - (setq separator (read-regexp "Regexp for cell separator: "))) - (unless separator - ;; Get the right cell separator - (goto-char begin) - (setq separator - (cond - ((not (re-search-forward "^[^\n\t]+$" end t)) '(16)) - ((not (re-search-forward "^[^\n,]+$" end t)) '(4)) - (t 1)))) - (goto-char begin) - (if (equal separator '(4)) - ;; Parse CSV - (while (< (point) end) - (cond - ((looking-at "^") (insert "| ")) - ((looking-at "[ \t]*$") (replace-match " |") (beginning-of-line 2)) - ((looking-at "[ \t]*\"\\([^\"\n]*\\)\"") - (replace-match "\\1") (if (looking-at "\"") (insert "\""))) - ((looking-at "[^,\n]+") (goto-char (match-end 0))) - ((looking-at "[ \t]*,") (replace-match " | ")) - (t (beginning-of-line 2)))) - (setq re - (cond - ((equal separator '(4)) "^\\|\"?[ \t]*,[ \t]*\"?") - ((equal separator '(16)) "^\\|\t") - ((integerp separator) - (if (< separator 1) - (user-error "Cell separator must contain one or more spaces") - (format "^ *\\| *\t *\\| \\{%d,\\}\\|$" separator))) - ((stringp separator) (format "^ *\\|%s" separator)) - (t (error "Invalid cell separator")))) - (let (finish) - (while (and (not finish) (re-search-forward re end t)) - (if (eolp) - (progn - (replace-match "|" t t) - (forward-line 1) - (when (eobp) - (setq finish t))) - (replace-match "| " t t))))) - (goto-char begin) - (when markdown-table-align-p - (markdown-table-align)))) - -(defun markdown-insert-table (&optional rows columns align) - "Insert an empty pipe table. -Optional arguments ROWS, COLUMNS, and ALIGN specify number of -rows and columns and the column alignment." - (interactive) - (let* ((rows (or rows (read-number "Number of Rows: "))) - (columns (or columns (read-number "Number of Columns: "))) - (align (or align (read-string "Alignment ([l]eft, [r]ight, [c]enter, or RET for default): "))) - (align (cond ((equal align "l") ":--") - ((equal align "r") "--:") - ((equal align "c") ":-:") - (t "---"))) - (pos (point)) - (indent (make-string (current-column) ?\ )) - (line (concat - (apply 'concat indent "|" - (make-list columns " |")) "\n")) - (hline (apply 'concat indent "|" - (make-list columns (concat align "|"))))) - (if (string-match - "^[ \t]*$" (buffer-substring-no-properties - (line-beginning-position) (point))) - (beginning-of-line 1) - (newline)) - (dotimes (_ rows) (insert line)) - (goto-char pos) - (if (> rows 1) - (progn - (end-of-line 1) (insert (concat "\n" hline)) (goto-char pos))) - (markdown-table-forward-cell))) - - -;;; ElDoc Support ============================================================= - -(defun markdown-eldoc-function (&rest _ignored) - "Return a helpful string when appropriate based on context. -* Report URL when point is at a hidden URL. -* Report language name when point is a code block with hidden markup." - (cond - ;; Hidden URL or reference for inline link - ((and (or (thing-at-point-looking-at markdown-regex-link-inline) - (thing-at-point-looking-at markdown-regex-link-reference)) - (or markdown-hide-urls markdown-hide-markup)) - (let* ((imagep (string-equal (match-string 1) "!")) - (referencep (string-equal (match-string 5) "[")) - (link (match-string-no-properties 6)) - (edit-keys (markdown--substitute-command-keys - (if imagep - "\\[markdown-insert-image]" - "\\[markdown-insert-link]"))) - (edit-str (propertize edit-keys 'face 'font-lock-constant-face)) - (object (if referencep "reference" "URL"))) - (format "Hidden %s (%s to edit): %s" object edit-str - (if referencep - (concat - (propertize "[" 'face 'markdown-markup-face) - (propertize link 'face 'markdown-reference-face) - (propertize "]" 'face 'markdown-markup-face)) - (propertize link 'face 'markdown-url-face))))) - ;; Hidden language name for fenced code blocks - ((and (markdown-code-block-at-point-p) - (not (get-text-property (point) 'markdown-pre)) - markdown-hide-markup) - (let ((lang (save-excursion (markdown-code-block-lang)))) - (unless lang (setq lang "[unspecified]")) - (format "Hidden code block language: %s (%s to toggle markup)" - (propertize lang 'face 'markdown-language-keyword-face) - (markdown--substitute-command-keys - "\\[markdown-toggle-markup-hiding]")))))) - -(defun markdown--image-media-handler (mimetype data) - (let* ((ext (symbol-name (mailcap-mime-type-to-extension mimetype))) - (filename (read-string "Insert filename for image: ")) - (link-text (read-string "Link text: ")) - (filepath (file-name-with-extension filename ext)) - (dir (file-name-directory filepath))) - (when (and dir (not (file-directory-p dir))) - (make-directory dir t)) - (with-temp-file filepath - (insert data)) - (when (string-match-p "\\s-" filepath) - (setq filepath (concat "<" filepath ">"))) - (markdown-insert-inline-image link-text filepath))) - -(defun markdown--file-media-handler (_mimetype data) - (let* ((data (split-string data "[\0\r\n]" t "^file://")) - (files (cdr data))) - (while (not (null files)) - (let* ((file (url-unhex-string (car files))) - (file (file-relative-name file)) - (prompt (format "Link text(%s): " (file-name-nondirectory file))) - (link-text (read-string prompt))) - (when (string-match-p "\\s-" file) - (setq file (concat "<" file ">"))) - (markdown-insert-inline-image link-text file) - (when (not (null (cdr files))) - (insert " ")) - (setq files (cdr files)))))) - -(defun markdown--dnd-local-file-handler (url _action) - (require 'mailcap) - (require 'dnd) - (let* ((filename (dnd-get-local-file-name url)) - (mimetype (mailcap-file-name-to-mime-type filename)) - (file (file-relative-name filename)) - (link-text "link text")) - (when (string-match-p "\\s-" file) - (setq file (concat "<" file ">"))) - (if (string-prefix-p "image/" mimetype) - (markdown-insert-inline-image link-text file) - (markdown-insert-inline-link link-text file)))) - - -;;; Mode Definition ========================================================== - -(defun markdown-show-version () - "Show the version number in the minibuffer." - (interactive) - (message "markdown-mode, version %s" markdown-mode-version)) - -(defun markdown-mode-info () - "Open the `markdown-mode' homepage." - (interactive) - (browse-url "https://jblevins.org/projects/markdown-mode/")) - -;;;###autoload -(define-derived-mode markdown-mode text-mode "Markdown" - "Major mode for editing Markdown files." - (when buffer-read-only - (when (or (not (buffer-file-name)) (file-writable-p (buffer-file-name))) - (setq-local buffer-read-only nil))) - ;; Natural Markdown tab width - (setq tab-width 4) - ;; Comments - (setq-local comment-start "<!-- ") - (setq-local comment-end " -->") - (setq-local comment-start-skip "<!--[ \t]*") - (setq-local comment-column 0) - (setq-local comment-auto-fill-only-comments nil) - (setq-local comment-use-syntax t) - ;; Sentence - (setq-local sentence-end-base "[.?!…‽][]\"'”’)}»›*_`~]*") - ;; Syntax - (add-hook 'syntax-propertize-extend-region-functions - #'markdown-syntax-propertize-extend-region nil t) - (add-hook 'jit-lock-after-change-extend-region-functions - #'markdown-font-lock-extend-region-function t t) - (setq-local syntax-propertize-function #'markdown-syntax-propertize) - (syntax-propertize (point-max)) ;; Propertize before hooks run, etc. - ;; Font lock. - (setq font-lock-defaults - '(markdown-mode-font-lock-keywords - nil nil nil nil - (font-lock-multiline . t) - (font-lock-syntactic-face-function . markdown-syntactic-face) - (font-lock-extra-managed-props - . (composition display invisible rear-nonsticky - keymap help-echo mouse-face)))) - (if markdown-hide-markup - (add-to-invisibility-spec 'markdown-markup) - (remove-from-invisibility-spec 'markdown-markup)) - ;; Wiki links - (markdown-setup-wiki-link-hooks) - ;; Math mode - (when markdown-enable-math (markdown-toggle-math t)) - ;; Add a buffer-local hook to reload after file-local variables are read - (add-hook 'hack-local-variables-hook #'markdown-handle-local-variables nil t) - ;; For imenu support - (setq imenu-create-index-function - (if markdown-nested-imenu-heading-index - #'markdown-imenu-create-nested-index - #'markdown-imenu-create-flat-index)) - - ;; Defun movement - (setq-local beginning-of-defun-function #'markdown-beginning-of-defun) - (setq-local end-of-defun-function #'markdown-end-of-defun) - ;; Paragraph filling - (setq-local fill-paragraph-function #'markdown-fill-paragraph) - (setq-local paragraph-start - ;; Should match start of lines that start or separate paragraphs - (mapconcat #'identity - '( - "\f" ; starts with a literal line-feed - "[ \t\f]*$" ; space-only line - "\\(?:[ \t]*>\\)+[ \t\f]*$"; empty line in blockquote - "[ \t]*[*+-][ \t]+" ; unordered list item - "[ \t]*\\(?:[0-9]+\\|#\\)\\.[ \t]+" ; ordered list item - "[ \t]*\\[\\S-*\\]:[ \t]+" ; link ref def - "[ \t]*:[ \t]+" ; definition - "^|" ; table or Pandoc line block - ) - "\\|")) - (setq-local paragraph-separate - ;; Should match lines that separate paragraphs without being - ;; part of any paragraph: - (mapconcat #'identity - '("[ \t\f]*$" ; space-only line - "\\(?:[ \t]*>\\)+[ \t\f]*$"; empty line in blockquote - ;; The following is not ideal, but the Fill customization - ;; options really only handle paragraph-starting prefixes, - ;; not paragraph-ending suffixes: - ".* $" ; line ending in two spaces - "^#+" - "^\\(?: \\)?[-=]+[ \t]*$" ;; setext - "[ \t]*\\[\\^\\S-*\\]:[ \t]*$") ; just the start of a footnote def - "\\|")) - (setq-local adaptive-fill-first-line-regexp "\\`[ \t]*[A-Z]?>[ \t]*?\\'") - (setq-local adaptive-fill-regexp "\\s-*") - (setq-local adaptive-fill-function #'markdown-adaptive-fill-function) - (setq-local fill-forward-paragraph-function #'markdown-fill-forward-paragraph) - ;; Outline mode - (setq-local outline-regexp markdown-regex-header) - (setq-local outline-level #'markdown-outline-level) - ;; Cause use of ellipses for invisible text. - (add-to-invisibility-spec '(outline . t)) - ;; ElDoc support - (if (boundp 'eldoc-documentation-functions) - (add-hook 'eldoc-documentation-functions #'markdown-eldoc-function nil t) - (add-function :before-until (local 'eldoc-documentation-function) - #'markdown-eldoc-function)) - ;; Inhibiting line-breaking: - ;; Separating out each condition into a separate function so that users can - ;; override if desired (with remove-hook) - (add-hook 'fill-nobreak-predicate - #'markdown-line-is-reference-definition-p nil t) - (add-hook 'fill-nobreak-predicate - #'markdown-pipe-at-bol-p nil t) - - ;; Indentation - (setq-local indent-line-function markdown-indent-function) - (setq-local indent-region-function #'markdown--indent-region) - - ;; Flyspell - (setq-local flyspell-generic-check-word-predicate - #'markdown-flyspell-check-word-p) - - ;; Electric quoting - (add-hook 'electric-quote-inhibit-functions - #'markdown--inhibit-electric-quote nil :local) - - ;; drag and drop handler - (setq-local dnd-protocol-alist (cons '("^file:///" . markdown--dnd-local-file-handler) - dnd-protocol-alist)) - - ;; media handler - (when (version< "29" emacs-version) - (yank-media-handler "image/.*" #'markdown--image-media-handler) - ;; TODO support other than GNOME, like KDE etc - (yank-media-handler "x-special/gnome-copied-files" #'markdown--file-media-handler)) - - ;; Make checkboxes buttons - (when markdown-make-gfm-checkboxes-buttons - (markdown-make-gfm-checkboxes-buttons (point-min) (point-max)) - (add-hook 'after-change-functions #'markdown-gfm-checkbox-after-change-function t t) - (add-hook 'change-major-mode-hook #'markdown-remove-gfm-checkbox-overlays t t)) - - ;; edit-indirect - (add-hook 'edit-indirect-after-commit-functions - #'markdown--edit-indirect-after-commit-function - nil 'local) - - ;; Marginalized headings - (when markdown-marginalize-headers - (add-hook 'window-configuration-change-hook - #'markdown-marginalize-update-current nil t)) - - ;; add live preview export hook - (add-hook 'after-save-hook #'markdown-live-preview-if-markdown t t) - (add-hook 'kill-buffer-hook #'markdown-live-preview-remove-on-kill t t) - - ;; Add a custom keymap for `visual-line-mode' so that activating - ;; this minor mode does not override markdown-mode's keybindings. - ;; FIXME: Probably `visual-line-mode' should take care of this. - (let ((oldmap (cdr (assoc 'visual-line-mode minor-mode-map-alist))) - (newmap (make-sparse-keymap))) - (set-keymap-parent newmap oldmap) - (define-key newmap [remap move-beginning-of-line] nil) - (define-key newmap [remap move-end-of-line] nil) - (make-local-variable 'minor-mode-overriding-map-alist) - (push `(visual-line-mode . ,newmap) minor-mode-overriding-map-alist))) - -;;;###autoload -(add-to-list 'auto-mode-alist - '("\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'" . markdown-mode)) - - -;;; GitHub Flavored Markdown Mode ============================================ - -(defun gfm--electric-pair-fence-code-block () - (when (and electric-pair-mode - (not markdown-gfm-use-electric-backquote) - (eql last-command-event ?`) - (let ((count 0)) - (while (eql (char-before (- (point) count)) ?`) - (cl-incf count)) - (= count 3)) - (eql (char-after) ?`)) - (save-excursion (insert (make-string 2 ?`))))) - -(defvar gfm-mode-hook nil - "Hook run when entering GFM mode.") - -;;;###autoload -(define-derived-mode gfm-mode markdown-mode "GFM" - "Major mode for editing GitHub Flavored Markdown files." - (setq markdown-link-space-sub-char "-") - (setq markdown-wiki-link-search-subdirectories t) - (setq-local markdown-table-at-point-p-function #'gfm--table-at-point-p) - (setq-local paragraph-separate - (concat paragraph-separate - "\\|" - ;; GFM alert syntax - "^>\s-*\\[!\\(?:NOTE\\|TIP\\|IMPORTANT\\|WARNING\\|CAUTION\\)\\]")) - (add-hook 'post-self-insert-hook #'gfm--electric-pair-fence-code-block 'append t) - (markdown-gfm-parse-buffer-for-languages)) - - -;;; Viewing modes ============================================================= - -(defcustom markdown-hide-markup-in-view-modes t - "Enable hidden markup mode in `markdown-view-mode' and `gfm-view-mode'." - :group 'markdown - :type 'boolean - :safe #'booleanp) - -(defvar markdown-view-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "p") #'markdown-outline-previous) - (define-key map (kbd "n") #'markdown-outline-next) - (define-key map (kbd "f") #'markdown-outline-next-same-level) - (define-key map (kbd "b") #'markdown-outline-previous-same-level) - (define-key map (kbd "u") #'markdown-outline-up) - (define-key map (kbd "DEL") #'scroll-down-command) - (define-key map (kbd "SPC") #'scroll-up-command) - (define-key map (kbd ">") #'end-of-buffer) - (define-key map (kbd "<") #'beginning-of-buffer) - (define-key map (kbd "q") #'kill-this-buffer) - (define-key map (kbd "?") #'describe-mode) - map) - "Keymap for `markdown-view-mode'.") - -(defun markdown--filter-visible (beg end &optional delete) - (let ((result "") - (invisible-faces '(markdown-header-delimiter-face markdown-header-rule-face))) - (while (< beg end) - (when (markdown--face-p beg invisible-faces) - (cl-incf beg) - (while (and (markdown--face-p beg invisible-faces) (< beg end)) - (cl-incf beg))) - (let ((next (next-single-char-property-change beg 'invisible))) - (unless (get-char-property beg 'invisible) - (setq result (concat result (buffer-substring beg (min end next))))) - (setq beg next))) - (prog1 result - (when delete - (let ((inhibit-read-only t)) - (delete-region beg end)))))) - -;;;###autoload -(define-derived-mode markdown-view-mode markdown-mode "Markdown-View" - "Major mode for viewing Markdown content." - (setq-local markdown-hide-markup markdown-hide-markup-in-view-modes) - (add-to-invisibility-spec 'markdown-markup) - (setq-local filter-buffer-substring-function #'markdown--filter-visible) - (read-only-mode 1)) - -(defvar gfm-view-mode-map - markdown-view-mode-map - "Keymap for `gfm-view-mode'.") - -;;;###autoload -(define-derived-mode gfm-view-mode gfm-mode "GFM-View" - "Major mode for viewing GitHub Flavored Markdown content." - (setq-local markdown-hide-markup markdown-hide-markup-in-view-modes) - (setq-local markdown-fontify-code-blocks-natively t) - (setq-local filter-buffer-substring-function #'markdown--filter-visible) - (add-to-invisibility-spec 'markdown-markup) - (read-only-mode 1)) - - -;;; Live Preview Mode ======================================================== -;;;###autoload -(define-minor-mode markdown-live-preview-mode - "Toggle native previewing on save for a specific markdown file." - :lighter " MD-Preview" - (if markdown-live-preview-mode - (if (markdown-live-preview-get-filename) - (markdown-display-buffer-other-window (markdown-live-preview-export)) - (markdown-live-preview-mode -1) - (user-error "Buffer %s does not visit a file" (current-buffer))) - (markdown-live-preview-remove))) - - -(provide 'markdown-mode) - -;; Local Variables: -;; indent-tabs-mode: nil -;; coding: utf-8 -;; End: -;;; markdown-mode.el ends here diff --git a/emacs/elpa/markdown-mode-20241107.349/markdown-mode.elc b/emacs/elpa/markdown-mode-20241107.349/markdown-mode.elc Binary files differ. diff --git a/emacs/elpa/markdown-mode-20241107.349/markdown-mode-autoloads.el b/emacs/elpa/markdown-mode-20241117.307/markdown-mode-autoloads.el diff --git a/emacs/elpa/markdown-mode-20241117.307/markdown-mode-pkg.el b/emacs/elpa/markdown-mode-20241117.307/markdown-mode-pkg.el @@ -0,0 +1,10 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "markdown-mode" "20241117.307" + "Major mode for Markdown-formatted text." + '((emacs "27.1")) + :url "https://github.com/jrblevin/markdown-mode" + :commit "1716694217bfb802f768d2353cb801459027c294" + :revdesc "1716694217bf" + :keywords '("markdown" "github flavored markdown" "itex") + :authors '(("Jason R. Blevins" . "jblevins@xbeta.org")) + :maintainers '(("Jason R. Blevins" . "jblevins@xbeta.org"))) diff --git a/emacs/elpa/markdown-mode-20241117.307/markdown-mode.el b/emacs/elpa/markdown-mode-20241117.307/markdown-mode.el @@ -0,0 +1,10401 @@ +;;; markdown-mode.el --- Major mode for Markdown-formatted text -*- lexical-binding: t; -*- + +;; Copyright (C) 2007-2023 Jason R. Blevins and markdown-mode +;; contributors (see the commit log for details). + +;; Author: Jason R. Blevins <jblevins@xbeta.org> +;; Maintainer: Jason R. Blevins <jblevins@xbeta.org> +;; Created: May 24, 2007 +;; Package-Version: 20241117.307 +;; Package-Revision: 1716694217bf +;; Package-Requires: ((emacs "27.1")) +;; Keywords: Markdown, GitHub Flavored Markdown, itex +;; URL: https://jblevins.org/projects/markdown-mode/ + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See the README.md file for details. + + +;;; Code: + +(require 'easymenu) +(require 'outline) +(require 'thingatpt) +(require 'cl-lib) +(require 'url-parse) +(require 'button) +(require 'color) +(require 'rx) +(require 'subr-x) + +(defvar jit-lock-start) +(defvar jit-lock-end) +(defvar flyspell-generic-check-word-predicate) +(defvar electric-pair-pairs) +(defvar sh-ancestor-alist) + +(declare-function project-roots "project") +(declare-function sh-set-shell "sh-script") +(declare-function mailcap-file-name-to-mime-type "mailcap") +(declare-function dnd-get-local-file-name "dnd") + +;; for older emacs<29 +(declare-function mailcap-mime-type-to-extension "mailcap") +(declare-function file-name-with-extension "files") +(declare-function yank-media-handler "yank-media") + + +;;; Constants ================================================================= + +(defconst markdown-mode-version "2.7-alpha" + "Markdown mode version number.") + +(defconst markdown-output-buffer-name "*markdown-output*" + "Name of temporary buffer for markdown command output.") + + +;;; Global Variables ========================================================== + +(defvar markdown-reference-label-history nil + "History of used reference labels.") + +(defvar markdown-live-preview-mode nil + "Sentinel variable for command `markdown-live-preview-mode'.") + +(defvar markdown-gfm-language-history nil + "History list of languages used in the current buffer in GFM code blocks.") + +(defvar markdown-follow-link-functions nil + "Functions used to follow a link. +Each function is called with one argument, the link's URL. It +should return non-nil if it followed the link, or nil if not. +Functions are called in order until one of them returns non-nil; +otherwise the default link-following function is used.") + + +;;; Customizable Variables ==================================================== + +(defvar markdown-mode-hook nil + "Hook run when entering Markdown mode.") + +(defvar markdown-before-export-hook nil + "Hook run before running Markdown to export XHTML output. +The hook may modify the buffer, which will be restored to it's +original state after exporting is complete.") + +(defvar markdown-after-export-hook nil + "Hook run after XHTML output has been saved. +Any changes to the output buffer made by this hook will be saved.") + +(defgroup markdown nil + "Major mode for editing text files in Markdown format." + :prefix "markdown-" + :group 'text + :link '(url-link "https://jblevins.org/projects/markdown-mode/")) + +(defcustom markdown-command (let ((command (cl-loop for cmd in '("markdown" "pandoc" "markdown_py") + when (executable-find cmd) + return (file-name-nondirectory it)))) + (or command "markdown")) + "Command to run markdown." + :group 'markdown + :type '(choice (string :tag "Shell command") (repeat (string)) function)) + +(defcustom markdown-command-needs-filename nil + "Set to non-nil if `markdown-command' does not accept input from stdin. +Instead, it will be passed a filename as the final command line +option. As a result, you will only be able to run Markdown from +buffers which are visiting a file." + :group 'markdown + :type 'boolean) + +(defcustom markdown-open-command nil + "Command used for opening Markdown files directly. +For example, a standalone Markdown previewer. This command will +be called with a single argument: the filename of the current +buffer. It can also be a function, which will be called without +arguments." + :group 'markdown + :type '(choice file function (const :tag "None" nil))) + +(defcustom markdown-open-image-command nil + "Command used for opening image files directly. +This is used at `markdown-follow-link-at-point'." + :group 'markdown + :type '(choice file function (const :tag "None" nil))) + +(defcustom markdown-hr-strings + '("-------------------------------------------------------------------------------" + "* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" + "---------------------------------------" + "* * * * * * * * * * * * * * * * * * * *" + "---------" + "* * * * *") + "Strings to use when inserting horizontal rules. +The first string in the list will be the default when inserting a +horizontal rule. Strings should be listed in decreasing order of +prominence (as in headings from level one to six) for use with +promotion and demotion functions." + :group 'markdown + :type '(repeat string)) + +(defcustom markdown-bold-underscore nil + "Use two underscores when inserting bold text instead of two asterisks." + :group 'markdown + :type 'boolean) + +(defcustom markdown-italic-underscore nil + "Use underscores when inserting italic text instead of asterisks." + :group 'markdown + :type 'boolean) + +(defcustom markdown-marginalize-headers nil + "When non-nil, put opening atx header markup in a left margin. + +This setting goes well with `markdown-asymmetric-header'. But +sadly it conflicts with `linum-mode' since they both use the +same margin." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-marginalize-headers-margin-width 6 + "Character width of margin used for marginalized headers. +The default value is based on there being six heading levels +defined by Markdown and HTML. Increasing this produces extra +whitespace on the left. Decreasing it may be preferred when +fewer than six nested heading levels are used." + :group 'markdown + :type 'integer + :safe 'natnump + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-asymmetric-header nil + "Determines if atx header style will be asymmetric. +Set to a non-nil value to use asymmetric header styling, placing +header markup only at the beginning of the line. By default, +balanced markup will be inserted at the beginning and end of the +line around the header title." + :group 'markdown + :type 'boolean) + +(defcustom markdown-indent-function 'markdown-indent-line + "Function to use to indent." + :group 'markdown + :type 'function) + +(defcustom markdown-indent-on-enter t + "Determines indentation behavior when pressing \\[newline]. +Possible settings are nil, t, and \\='indent-and-new-item. + +When non-nil, pressing \\[newline] will call `newline-and-indent' +to indent the following line according to the context using +`markdown-indent-function'. In this case, note that +\\[electric-newline-and-maybe-indent] can still be used to insert +a newline without indentation. + +When set to \\='indent-and-new-item and the point is in a list item +when \\[newline] is pressed, the list will be continued on the next +line, where a new item will be inserted. + +When set to nil, simply call `newline' as usual. In this case, +you can still indent lines using \\[markdown-cycle] and continue +lists with \\[markdown-insert-list-item]. + +Note that this assumes the variable `electric-indent-mode' is +non-nil (enabled). When it is *disabled*, the behavior of +\\[newline] and `\\[electric-newline-and-maybe-indent]' are +reversed." + :group 'markdown + :type '(choice (const :tag "Don't automatically indent" nil) + (const :tag "Automatically indent" t) + (const :tag "Automatically indent and insert new list items" indent-and-new-item))) + +(defcustom markdown-enable-wiki-links nil + "Syntax highlighting for wiki links. +Set this to a non-nil value to turn on wiki link support by default. +Support can be toggled later using the `markdown-toggle-wiki-links' +function or \\[markdown-toggle-wiki-links]." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-alias-first t + "When non-nil, treat aliased wiki links like [[alias text|PageName]]. +Otherwise, they will be treated as [[PageName|alias text]]." + :group 'markdown + :type 'boolean + :safe 'booleanp) + +(defcustom markdown-wiki-link-search-subdirectories nil + "When non-nil, search for wiki link targets in subdirectories. +This is the default search behavior for GitHub and is +automatically set to t in `gfm-mode'." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-search-parent-directories nil + "When non-nil, search for wiki link targets in parent directories. +This is the default search behavior of Ikiwiki." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-wiki-link-search-type nil + "Searching type for markdown wiki link. + +sub-directories: search for wiki link targets in sub directories +parent-directories: search for wiki link targets in parent directories +project: search for wiki link targets under project root" + :group 'markdown + :type '(set + (const :tag "search wiki link from subdirectories" sub-directories) + (const :tag "search wiki link from parent directories" parent-directories) + (const :tag "search wiki link under project root" project)) + :package-version '(markdown-mode . "2.5")) + +(make-obsolete-variable 'markdown-wiki-link-search-subdirectories 'markdown-wiki-link-search-type "2.5") +(make-obsolete-variable 'markdown-wiki-link-search-parent-directories 'markdown-wiki-link-search-type "2.5") + +(defcustom markdown-wiki-link-fontify-missing nil + "When non-nil, change wiki link face according to existence of target files. +This is expensive because it requires checking for the file each time the buffer +changes or the user switches windows. It is disabled by default because it may +cause lag when typing on slower machines." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-uri-types + '("acap" "cid" "data" "dav" "fax" "file" "ftp" + "geo" "gopher" "http" "https" "imap" "ldap" "mailto" + "mid" "message" "modem" "news" "nfs" "nntp" + "pop" "prospero" "rtsp" "service" "sip" "tel" + "telnet" "tip" "urn" "vemmi" "wais") + "Link types for syntax highlighting of URIs." + :group 'markdown + :type '(repeat (string :tag "URI scheme"))) + +(defcustom markdown-url-compose-char + '(?∞ ?… ?⋯ ?# ?★ ?⚓) + "Placeholder character for hidden URLs. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :type '(choice + (character :tag "Single URL replacement character") + (repeat :tag "List of possible URL replacement characters" + character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-blockquote-display-char + '("▌" "┃" ">") + "String to display when hiding blockquote markup. +This may be a single string or a list of string. In case of a +list, the first one that satisfies `char-displayable-p' will be +used." + :type '(choice + (string :tag "Single blockquote display string") + (repeat :tag "List of possible blockquote display strings" string)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-hr-display-char + '(?─ ?━ ?-) + "Character for hiding horizontal rule markup. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :group 'markdown + :type '(choice + (character :tag "Single HR display character") + (repeat :tag "List of possible HR display characters" character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-definition-display-char + '(?⁘ ?⁙ ?≡ ?⌑ ?◊ ?:) + "Character for replacing definition list markup. +This may be a single character or a list of characters. In case +of a list, the first one that satisfies `char-displayable-p' will +be used." + :type '(choice + (character :tag "Single definition list character") + (repeat :tag "List of possible definition list characters" character)) + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-enable-math nil + "Syntax highlighting for inline LaTeX and itex expressions. +Set this to a non-nil value to turn on math support by default. +Math support can be enabled, disabled, or toggled later using +`markdown-toggle-math' or \\[markdown-toggle-math]." + :group 'markdown + :type 'boolean + :safe 'booleanp) +(make-variable-buffer-local 'markdown-enable-math) + +(defcustom markdown-enable-html t + "Enable font-lock support for HTML tags and attributes." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-enable-highlighting-syntax nil + "Enable highlighting syntax." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-css-paths nil + "List of URLs of CSS files to link to in the output XHTML." + :group 'markdown + :safe (apply-partially #'seq-every-p #'stringp) + :type '(repeat (string :tag "CSS File Path"))) + +(defcustom markdown-content-type "text/html" + "Content type string for the http-equiv header in XHTML output. +When set to an empty string, this attribute is omitted. Defaults to +`text/html'." + :group 'markdown + :type 'string) + +(defcustom markdown-coding-system nil + "Character set string for the http-equiv header in XHTML output. +Defaults to `buffer-file-coding-system' (and falling back to +`utf-8' when not available). Common settings are `iso-8859-1' +and `iso-latin-1'. Use `list-coding-systems' for more choices." + :group 'markdown + :type 'coding-system) + +(defcustom markdown-export-kill-buffer t + "Kill output buffer after HTML export. +When non-nil, kill the HTML output buffer after +exporting with `markdown-export'." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-header-content "" + "Additional content to include in the XHTML <head> block." + :group 'markdown + :type 'string) + +(defcustom markdown-xhtml-body-preamble "" + "Content to include in the XHTML <body> block, before the output." + :group 'markdown + :type 'string + :safe 'stringp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-body-epilogue "" + "Content to include in the XHTML <body> block, after the output." + :group 'markdown + :type 'string + :safe 'stringp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-xhtml-standalone-regexp + "^\\(<\\?xml\\|<!DOCTYPE\\|<html\\)" + "Regexp indicating whether `markdown-command' output is standalone XHTML." + :group 'markdown + :type 'regexp) + +(defcustom markdown-link-space-sub-char "_" + "Character to use instead of spaces when mapping wiki links to filenames." + :group 'markdown + :type 'string) + +(defcustom markdown-reference-location 'header + "Position where new reference definitions are inserted in the document." + :group 'markdown + :type '(choice (const :tag "At the end of the document" end) + (const :tag "Immediately after the current block" immediately) + (const :tag "At the end of the subtree" subtree) + (const :tag "Before next header" header))) + +(defcustom markdown-footnote-location 'end + "Position where new footnotes are inserted in the document." + :group 'markdown + :type '(choice (const :tag "At the end of the document" end) + (const :tag "Immediately after the current block" immediately) + (const :tag "At the end of the subtree" subtree) + (const :tag "Before next header" header))) + +(defcustom markdown-footnote-display '((raise 0.2) (height 0.8)) + "Display specification for footnote markers and inline footnotes. +By default, footnote text is reduced in size and raised. Set to +nil to disable this." + :group 'markdown + :type '(choice (sexp :tag "Display specification") + (const :tag "Don't set display property" nil)) + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-sub-superscript-display + '(((raise -0.3) (height 0.7)) . ((raise 0.3) (height 0.7))) + "Display specification for subscript and superscripts. +The car is used for subscript, the cdr is used for superscripts." + :group 'markdown + :type '(cons (choice (sexp :tag "Subscript form") + (const :tag "No lowering" nil)) + (choice (sexp :tag "Superscript form") + (const :tag "No raising" nil))) + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-unordered-list-item-prefix " * " + "String inserted before unordered list items." + :group 'markdown + :type 'string) + +(defcustom markdown-ordered-list-enumeration t + "When non-nil, use enumerated numbers(1. 2. 3. etc.) for ordered list marker. +While nil, always uses '1.' for the marker" + :group 'markdown + :type 'boolean + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-nested-imenu-heading-index t + "Use nested or flat imenu heading index. +A nested index may provide more natural browsing from the menu, +but a flat list may allow for faster keyboard navigation via tab +completion." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-add-footnotes-to-imenu t + "Add footnotes to end of imenu heading index." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-make-gfm-checkboxes-buttons t + "When non-nil, make GFM checkboxes into buttons." + :group 'markdown + :type 'boolean) + +(defcustom markdown-use-pandoc-style-yaml-metadata nil + "When non-nil, allow YAML metadata anywhere in the document." + :group 'markdown + :type 'boolean) + +(defcustom markdown-split-window-direction 'any + "Preference for splitting windows for static and live preview. +The default value is \\='any, which instructs Emacs to use +`split-window-sensibly' to automatically choose how to split +windows based on the values of `split-width-threshold' and +`split-height-threshold' and the available windows. To force +vertically split (left and right) windows, set this to \\='vertical +or \\='right. To force horizontally split (top and bottom) windows, +set this to \\='horizontal or \\='below. + +If this value is \\='any and `display-buffer-alist' is set then +`display-buffer' is used for open buffer function" + :group 'markdown + :type '(choice (const :tag "Automatic" any) + (const :tag "Right (vertical)" right) + (const :tag "Below (horizontal)" below)) + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-live-preview-window-function + #'markdown-live-preview-window-eww + "Function to display preview of Markdown output within Emacs. +Function must update the buffer containing the preview and return +the buffer." + :group 'markdown + :type 'function) + +(defcustom markdown-live-preview-delete-export 'delete-on-destroy + "Delete exported HTML file when using `markdown-live-preview-export'. +If set to \\='delete-on-export, delete on every export. When set to +\\='delete-on-destroy delete when quitting from command +`markdown-live-preview-mode'. Never delete if set to nil." + :group 'markdown + :type '(choice + (const :tag "Delete on every export" delete-on-export) + (const :tag "Delete when quitting live preview" delete-on-destroy) + (const :tag "Never delete" nil))) + +(defcustom markdown-list-indent-width 4 + "Depth of indentation for markdown lists. +Used in `markdown-demote-list-item' and +`markdown-promote-list-item'." + :group 'markdown + :type 'integer) + +(defcustom markdown-enable-prefix-prompts t + "Display prompts for certain prefix commands. +Set to nil to disable these prompts." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-gfm-additional-languages nil + "Extra languages made available when inserting GFM code blocks. +Language strings must have be trimmed of whitespace and not +contain any curly braces. They may be of arbitrary +capitalization, though." + :group 'markdown + :type '(repeat (string :validate markdown-validate-language-string))) + +(defcustom markdown-gfm-use-electric-backquote t + "Use `markdown-electric-backquote' when backquote is hit three times." + :group 'markdown + :type 'boolean) + +(defcustom markdown-gfm-downcase-languages t + "If non-nil, downcase suggested languages. +This applies to insertions done with +`markdown-electric-backquote'." + :group 'markdown + :type 'boolean) + +(defcustom markdown-edit-code-block-default-mode 'normal-mode + "Default mode to use for editing code blocks. +This mode is used when automatic detection fails, such as for GFM +code blocks with no language specified." + :group 'markdown + :type '(choice function (const :tag "None" nil)) + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-gfm-uppercase-checkbox nil + "If non-nil, use [X] for completed checkboxes, [x] otherwise." + :group 'markdown + :type 'boolean + :safe 'booleanp) + +(defcustom markdown-hide-urls nil + "Hide URLs of inline links and reference tags of reference links. +Such URLs will be replaced by a single customizable +character, defined by `markdown-url-compose-char', but are still part +of the buffer. Links can be edited interactively with +\\[markdown-insert-link] or, for example, by deleting the final +parenthesis to remove the invisibility property. You can also +hover your mouse pointer over the link text to see the URL. +Set this to a non-nil value to turn this feature on by default. +You can interactively set the value of this variable by calling +`markdown-toggle-url-hiding', pressing \\[markdown-toggle-url-hiding], +or from the menu Markdown > Links & Images menu." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.3")) +(make-variable-buffer-local 'markdown-hide-urls) + +(defcustom markdown-translate-filename-function #'identity + "Function to use to translate filenames when following links. +\\<markdown-mode-map>\\[markdown-follow-thing-at-point] and \\[markdown-follow-link-at-point] +call this function with the filename as only argument whenever +they encounter a filename (instead of a URL) to be visited and +use its return value instead of the filename in the link. For +example, if absolute filenames are actually relative to a server +root directory, you can set +`markdown-translate-filename-function' to a function that +prepends the root directory to the given filename." + :group 'markdown + :type 'function + :risky t + :package-version '(markdown-mode . "2.4")) + +(defcustom markdown-max-image-size nil + "Maximum width and height for displayed inline images. +This variable may be nil or a cons cell (MAX-WIDTH . MAX-HEIGHT). +When nil, use the actual size. Otherwise, use ImageMagick to +resize larger images to be of the given maximum dimensions. This +requires Emacs to be built with ImageMagick support." + :group 'markdown + :package-version '(markdown-mode . "2.4") + :type '(choice + (const :tag "Use actual image width" nil) + (cons (choice (sexp :tag "Maximum width in pixels") + (const :tag "No maximum width" nil)) + (choice (sexp :tag "Maximum height in pixels") + (const :tag "No maximum height" nil))))) + +(defcustom markdown-mouse-follow-link t + "Non-nil means mouse on a link will follow the link. +This variable must be set before loading markdown-mode." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-table-align-p t + "Non-nil means that table is aligned after table operation." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-fontify-whole-heading-line nil + "Non-nil means fontify the whole line for headings. +This is useful when setting a background color for the +markdown-header-face-* faces." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-special-ctrl-a/e nil + "Non-nil means `C-a' and `C-e' behave specially in headlines and items. + +When t, `C-a' will bring back the cursor to the beginning of the +headline text. In an item, this will be the position after bullet +and check-box, if any. When the cursor is already at that +position, another `C-a' will bring it to the beginning of the +line. + +`C-e' will jump to the end of the headline, ignoring the presence +of closing tags in the headline. A second `C-e' will then jump to +the true end of the line, after closing tags. This also means +that, when this variable is non-nil, `C-e' also will never jump +beyond the end of the heading of a folded section, i.e. not after +the ellipses. + +When set to the symbol `reversed', the first `C-a' or `C-e' works +normally, going to the true line boundary first. Only a directly +following, identical keypress will bring the cursor to the +special positions. + +This may also be a cons cell where the behavior for `C-a' and +`C-e' is set separately." + :group 'markdown + :type '(choice + (const :tag "off" nil) + (const :tag "on: after hashes/bullet and before closing tags first" t) + (const :tag "reversed: true line boundary first" reversed) + (cons :tag "Set C-a and C-e separately" + (choice :tag "Special C-a" + (const :tag "off" nil) + (const :tag "on: after hashes/bullet first" t) + (const :tag "reversed: before hashes/bullet first" reversed)) + (choice :tag "Special C-e" + (const :tag "off" nil) + (const :tag "on: before closing tags first" t) + (const :tag "reversed: after closing tags first" reversed)))) + :package-version '(markdown-mode . "2.7")) + +;;; Markdown-Specific `rx' Macro ============================================== + +;; Based on python-rx from python.el. +(defmacro markdown-rx (&rest regexps) + "Markdown mode specialized rx macro. +This variant of `rx' supports common Markdown named REGEXPS." + `(rx-let ((newline "\n") + ;; Note: #405 not consider markdown-list-indent-width however this is never used + (indent (or (repeat 4 " ") "\t")) + (block-end (and (or (one-or-more (zero-or-more blank) "\n") line-end))) + (numeral (and (one-or-more (any "0-9#")) ".")) + (bullet (any "*+:-")) + (list-marker (or (and (one-or-more (any "0-9#")) ".") + (any "*+:-"))) + (checkbox (seq "[" (any " xX") "]"))) + (rx ,@regexps))) + + +;;; Regular Expressions ======================================================= + +(defconst markdown-regex-comment-start + "<!--" + "Regular expression matches HTML comment opening.") + +(defconst markdown-regex-comment-end + "--[ \t]*>" + "Regular expression matches HTML comment closing.") + +(defconst markdown-regex-link-inline + "\\(?1:!\\)?\\(?2:\\[\\)\\(?3:\\^?\\(?:\\\\\\]\\|[^]]\\)*\\|\\)\\(?4:\\]\\)\\(?5:(\\)\\s-*\\(?6:[^)]*?\\)\\(?:\\s-+\\(?7:\"[^\"]*\"\\)\\)?\\s-*\\(?8:)\\)" + "Regular expression for a [text](file) or an image link . +Group 1 matches the leading exclamation point (optional). +Group 2 matches the opening square bracket. +Group 3 matches the text inside the square brackets. +Group 4 matches the closing square bracket. +Group 5 matches the opening parenthesis. +Group 6 matches the URL. +Group 7 matches the title (optional). +Group 8 matches the closing parenthesis.") + +(defconst markdown-regex-link-reference + "\\(?1:!\\)?\\(?2:\\[\\)\\(?3:[^]^][^]]*\\|\\)\\(?4:\\]\\)\\(?5:\\[\\)\\(?6:[^]]*?\\)\\(?7:\\]\\)" + "Regular expression for a reference link [text][id]. +Group 1 matches the leading exclamation point (optional). +Group 2 matches the opening square bracket for the link text. +Group 3 matches the text inside the square brackets. +Group 4 matches the closing square bracket for the link text. +Group 5 matches the opening square bracket for the reference label. +Group 6 matches the reference label. +Group 7 matches the closing square bracket for the reference label.") + +(defconst markdown-regex-reference-definition + "^ \\{0,3\\}\\(?1:\\[\\)\\(?2:[^]\n]+?\\)\\(?3:\\]\\)\\(?4::\\)\\s *\\(?5:.*?\\)\\s *\\(?6: \"[^\"]*\"$\\|$\\)" + "Regular expression for a reference definition. +Group 1 matches the opening square bracket. +Group 2 matches the reference label. +Group 3 matches the closing square bracket. +Group 4 matches the colon. +Group 5 matches the URL. +Group 6 matches the title attribute (optional).") + +(defconst markdown-regex-footnote + "\\(?1:\\[\\^\\)\\(?2:.+?\\)\\(?3:\\]\\)" + "Regular expression for a footnote marker [^fn]. +Group 1 matches the opening square bracket and carat. +Group 2 matches only the label, without the surrounding markup. +Group 3 matches the closing square bracket.") + +(defconst markdown-regex-header + "^\\(?:\\(?1:[^\r\n\t -].*\\)\n\\(?:\\(?2:=+\\)\\|\\(?3:-+\\)\\)\\|\\(?4:#+[ \t]+\\)\\(?5:.*?\\)\\(?6:[ \t]+#+\\)?\\)$" + "Regexp identifying Markdown headings. +Group 1 matches the text of a setext heading. +Group 2 matches the underline of a level-1 setext heading. +Group 3 matches the underline of a level-2 setext heading. +Group 4 matches the opening hash marks of an atx heading and whitespace. +Group 5 matches the text, without surrounding whitespace, of an atx heading. +Group 6 matches the closing whitespace and hash marks of an atx heading.") + +(defconst markdown-regex-header-setext + "^\\([^\r\n\t -].*\\)\n\\(=+\\|-+\\)$" + "Regular expression for generic setext-style (underline) headers.") + +(defconst markdown-regex-header-atx + "^\\(#+\\)[ \t]+\\(.*?\\)[ \t]*\\(#*\\)$" + "Regular expression for generic atx-style (hash mark) headers.") + +(defconst markdown-regex-hr + (rx line-start + (group (or (and (repeat 3 (and "*" (? " "))) (* (any "* "))) + (and (repeat 3 (and "-" (? " "))) (* (any "- "))) + (and (repeat 3 (and "_" (? " "))) (* (any "_ "))))) + line-end) + "Regular expression for matching Markdown horizontal rules.") + +(defconst markdown-regex-code + "\\(?:\\`\\|[^\\]\\)\\(?1:\\(?2:`+\\)\\(?3:\\(?:.\\|\n[^\n]\\)*?[^`]\\)\\(?4:\\2\\)\\)\\(?:[^`]\\|\\'\\)" + "Regular expression for matching inline code fragments. + +Group 1 matches the entire code fragment including the backquotes. +Group 2 matches the opening backquotes. +Group 3 matches the code fragment itself, without backquotes. +Group 4 matches the closing backquotes. + +The leading, unnumbered group ensures that the leading backquote +character is not escaped. +The last group, also unnumbered, requires that the character +following the code fragment is not a backquote. +Note that \\(?:.\\|\n[^\n]\\) matches any character, including newlines, +but not two newlines in a row.") + +(defconst markdown-regex-kbd + "\\(?1:<kbd>\\)\\(?2:\\(?:.\\|\n[^\n]\\)*?\\)\\(?3:</kbd>\\)" + "Regular expression for matching <kbd> tags. +Groups 1 and 3 match the opening and closing tags. +Group 2 matches the key sequence.") + +(defconst markdown-regex-gfm-code-block-open + "^[[:blank:]]*\\(?1:```\\)\\(?2:[[:blank:]]*{?[[:blank:]]*\\)\\(?3:[^`[:space:]]+?\\)?\\(?:[[:blank:]]+\\(?4:.+?\\)\\)?\\(?5:[[:blank:]]*}?[[:blank:]]*\\)$" + "Regular expression matching opening of GFM code blocks. +Group 1 matches the opening three backquotes and any following whitespace. +Group 2 matches the opening brace (optional) and surrounding whitespace. +Group 3 matches the language identifier (optional). +Group 4 matches the info string (optional). +Group 5 matches the closing brace (optional), whitespace, and newline. +Groups need to agree with `markdown-regex-tilde-fence-begin'.") + +(defconst markdown-regex-gfm-code-block-close + "^[[:blank:]]*\\(?1:```\\)\\(?2:\\s *?\\)$" + "Regular expression matching closing of GFM code blocks. +Group 1 matches the closing three backquotes. +Group 2 matches any whitespace and the final newline.") + +(defconst markdown-regex-pre + "^\\( \\|\t\\).*$" + "Regular expression for matching preformatted text sections.") + +(defconst markdown-regex-list + (markdown-rx line-start + ;; 1. Leading whitespace + (group (* blank)) + ;; 2. List marker: a numeral, bullet, or colon + (group list-marker) + ;; 3. Trailing whitespace + (group (+ blank)) + ;; 4. Optional checkbox for GFM task list items + (opt (group (and checkbox (* blank))))) + "Regular expression for matching list items.") + +(defconst markdown-regex-bold + "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:\\*\\*\\|__\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:\\3\\)\\)" + "Regular expression for matching bold text. +Group 1 matches the character before the opening asterisk or +underscore, if any, ensuring that it is not a backslash escape. +Group 2 matches the entire expression, including delimiters. +Groups 3 and 5 matches the opening and closing delimiters. +Group 4 matches the text inside the delimiters.") + +(defconst markdown-regex-italic + "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:[*_]\\)\\(?3:[^ \n\t\\]\\|[^ \n\t*]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?4:\\2\\)\\)" + "Regular expression for matching italic text. +The leading unnumbered matches the character before the opening +asterisk or underscore, if any, ensuring that it is not a +backslash escape. +Group 1 matches the entire expression, including delimiters. +Groups 2 and 4 matches the opening and closing delimiters. +Group 3 matches the text inside the delimiters.") + +(defconst markdown-regex-strike-through + "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:~~\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:~~\\)\\)" + "Regular expression for matching strike-through text. +Group 1 matches the character before the opening tilde, if any, +ensuring that it is not a backslash escape. +Group 2 matches the entire expression, including delimiters. +Groups 3 and 5 matches the opening and closing delimiters. +Group 4 matches the text inside the delimiters.") + +(defconst markdown-regex-gfm-italic + "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:[*_]\\)\\(?3:[^ \\]\\2\\|[^ ]\\(?:.\\|\n[^\n]\\)*?\\)\\(?4:\\2\\)\\)" + "Regular expression for matching italic text in GitHub Flavored Markdown. +Underscores in words are not treated as special. +Group 1 matches the entire expression, including delimiters. +Groups 2 and 4 matches the opening and closing delimiters. +Group 3 matches the text inside the delimiters.") + +(defconst markdown-regex-blockquote + "^[ \t]*\\(?1:[A-Z]?>\\)\\(?2:[ \t]*\\)\\(?3:.*\\)$" + "Regular expression for matching blockquote lines. +Also accounts for a potential capital letter preceding the angle +bracket, for use with Leanpub blocks (asides, warnings, info +blocks, etc.). +Group 1 matches the leading angle bracket. +Group 2 matches the separating whitespace. +Group 3 matches the text.") + +(defconst markdown-regex-line-break + "[^ \n\t][ \t]*\\( \\)\n" + "Regular expression for matching line breaks.") + +(defconst markdown-regex-escape + "\\(\\\\\\)." + "Regular expression for matching escape sequences.") + +(defconst markdown-regex-wiki-link + "\\(?:^\\|[^\\]\\)\\(?1:\\(?2:\\[\\[\\)\\(?3:[^]|]+\\)\\(?:\\(?4:|\\)\\(?5:[^]]+\\)\\)?\\(?6:\\]\\]\\)\\)" + "Regular expression for matching wiki links. +This matches typical bracketed [[WikiLinks]] as well as \\='aliased +wiki links of the form [[PageName|link text]]. +The meanings of the first and second components depend +on the value of `markdown-wiki-link-alias-first'. + +Group 1 matches the entire link. +Group 2 matches the opening square brackets. +Group 3 matches the first component of the wiki link. +Group 4 matches the pipe separator, when present. +Group 5 matches the second component of the wiki link, when present. +Group 6 matches the closing square brackets.") + +(defconst markdown-regex-uri + (concat "\\(" (regexp-opt markdown-uri-types) ":[^]\t\n\r<>; ]+\\)") + "Regular expression for matching inline URIs.") + +;; CommanMark specification says scheme length is 2-32 characters +(defconst markdown-regex-angle-uri + (concat "\\(<\\)\\([a-z][a-z0-9.+-]\\{1,31\\}:[^]\t\n\r<>,;()]+\\)\\(>\\)") + "Regular expression for matching inline URIs in angle brackets.") + +(defconst markdown-regex-email + "<\\(\\(?:\\sw\\|\\s_\\|\\s.\\)+@\\(?:\\sw\\|\\s_\\|\\s.\\)+\\)>" + "Regular expression for matching inline email addresses.") + +(defsubst markdown-make-regex-link-generic () + "Make regular expression for matching any recognized link." + (concat "\\(?:" markdown-regex-link-inline + (when markdown-enable-wiki-links + (concat "\\|" markdown-regex-wiki-link)) + "\\|" markdown-regex-link-reference + "\\|" markdown-regex-angle-uri "\\)")) + +(defconst markdown-regex-gfm-checkbox + " \\(\\[[ xX]\\]\\) " + "Regular expression for matching GFM checkboxes. +Group 1 matches the text to become a button.") + +(defconst markdown-regex-blank-line + "^[[:blank:]]*$" + "Regular expression that matches a blank line.") + +(defconst markdown-regex-block-separator + "\n[\n\t\f ]*\n" + "Regular expression for matching block boundaries.") + +(defconst markdown-regex-block-separator-noindent + (concat "\\(\\`\\|\\(" markdown-regex-block-separator "\\)[^\n\t\f ]\\)") + "Regexp for block separators before lines with no indentation.") + +(defconst markdown-regex-math-inline-single + "\\(?:^\\|[^\\]\\)\\(?1:\\$\\)\\(?2:\\(?:[^\\$]\\|\\\\.\\)*\\)\\(?3:\\$\\)" + "Regular expression for itex $..$ math mode expressions. +Groups 1 and 3 match the opening and closing dollar signs. +Group 2 matches the mathematical expression contained within.") + +(defconst markdown-regex-math-inline-double + "\\(?:^\\|[^\\]\\)\\(?1:\\$\\$\\)\\(?2:\\(?:[^\\$]\\|\\\\.\\)*\\)\\(?3:\\$\\$\\)" + "Regular expression for itex $$..$$ math mode expressions. +Groups 1 and 3 match opening and closing dollar signs. +Group 2 matches the mathematical expression contained within.") + +(defconst markdown-regex-math-display + (rx line-start (* blank) + (group (group (repeat 1 2 "\\")) "[") + (group (*? anything)) + (group (backref 2) "]") + line-end) + "Regular expression for \[..\] or \\[..\\] display math. +Groups 1 and 4 match the opening and closing markup. +Group 3 matches the mathematical expression contained within. +Group 2 matches the opening slashes, and is used internally to +match the closing slashes.") + +(defsubst markdown-make-tilde-fence-regex (num-tildes &optional end-of-line) + "Return regexp matching a tilde code fence at least NUM-TILDES long. +END-OF-LINE is the regexp construct to indicate end of line; $ if +missing." + (format "%s%d%s%s" "^[[:blank:]]*\\([~]\\{" num-tildes ",\\}\\)" + (or end-of-line "$"))) + +(defconst markdown-regex-tilde-fence-begin + (markdown-make-tilde-fence-regex + 3 "\\([[:blank:]]*{?\\)[[:blank:]]*\\([^[:space:]]+?\\)?\\(?:[[:blank:]]+\\(.+?\\)\\)?\\([[:blank:]]*}?[[:blank:]]*\\)$") + "Regular expression for matching tilde-fenced code blocks. +Group 1 matches the opening tildes. +Group 2 matches (optional) opening brace and surrounding whitespace. +Group 3 matches the language identifier (optional). +Group 4 matches the info string (optional). +Group 5 matches the closing brace (optional) and any surrounding whitespace. +Groups need to agree with `markdown-regex-gfm-code-block-open'.") + +(defconst markdown-regex-declarative-metadata + "^[ \t]*\\(?:-[ \t]*\\)?\\([[:alpha:]][[:alpha:] _-]*?\\)\\([:=][ \t]*\\)\\(.*\\)$" + "Regular expression for matching declarative metadata statements. +This matches MultiMarkdown metadata as well as YAML and TOML +assignments such as the following: + + variable: value + +or + + variable = value") + +(defconst markdown-regex-pandoc-metadata + "^\\(%\\)\\([ \t]*\\)\\(.*\\(?:\n[ \t]+.*\\)*\\)" + "Regular expression for matching Pandoc metadata.") + +(defconst markdown-regex-yaml-metadata-border + "\\(-\\{3\\}\\)$" + "Regular expression for matching YAML metadata.") + +(defconst markdown-regex-yaml-pandoc-metadata-end-border + "^\\(\\.\\{3\\}\\|\\-\\{3\\}\\)$" + "Regular expression for matching YAML metadata end borders.") + +(defsubst markdown-get-yaml-metadata-start-border () + "Return YAML metadata start border depending upon whether Pandoc is used." + (concat + (if markdown-use-pandoc-style-yaml-metadata "^" "\\`") + markdown-regex-yaml-metadata-border)) + +(defsubst markdown-get-yaml-metadata-end-border (_) + "Return YAML metadata end border depending upon whether Pandoc is used." + (if markdown-use-pandoc-style-yaml-metadata + markdown-regex-yaml-pandoc-metadata-end-border + markdown-regex-yaml-metadata-border)) + +(defconst markdown-regex-inline-attributes + "[ \t]*\\(?:{:?\\)[ \t]*\\(?:\\(?:#[[:alpha:]_.:-]+\\|\\.[[:alpha:]_.:-]+\\|\\w+=['\"]?[^\n'\"}]*['\"]?\\),?[ \t]*\\)+\\(?:}\\)[ \t]*$" + "Regular expression for matching inline identifiers or attribute lists. +Compatible with Pandoc, Python Markdown, PHP Markdown Extra, and Leanpub.") + +(defconst markdown-regex-leanpub-sections + (concat + "^\\({\\)\\(" + (regexp-opt '("frontmatter" "mainmatter" "backmatter" "appendix" "pagebreak")) + "\\)\\(}\\)[ \t]*\n") + "Regular expression for Leanpub section markers and related syntax.") + +(defconst markdown-regex-sub-superscript + "\\(?:^\\|[^\\~^]\\)\\(?1:\\(?2:[~^]\\)\\(?3:[+-\u2212]?[[:alnum:]]+\\)\\(?4:\\2\\)\\)" + "The regular expression matching a sub- or superscript. +The leading un-numbered group matches the character before the +opening tilde or carat, if any, ensuring that it is not a +backslash escape, carat, or tilde. +Group 1 matches the entire expression, including markup. +Group 2 matches the opening markup--a tilde or carat. +Group 3 matches the text inside the delimiters. +Group 4 matches the closing markup--a tilde or carat.") + +(defconst markdown-regex-include + "^\\(?1:<<\\)\\(?:\\(?2:\\[\\)\\(?3:.*\\)\\(?4:\\]\\)\\)?\\(?:\\(?5:(\\)\\(?6:.*\\)\\(?7:)\\)\\)?\\(?:\\(?8:{\\)\\(?9:.*\\)\\(?10:}\\)\\)?$" + "Regular expression matching common forms of include syntax. +Marked 2, Leanpub, and other processors support some of these forms: + +<<[sections/section1.md] +<<(folder/filename) +<<[Code title](folder/filename) +<<{folder/raw_file.html} + +Group 1 matches the opening two angle brackets. +Groups 2-4 match the opening square bracket, the text inside, +and the closing square bracket, respectively. +Groups 5-7 match the opening parenthesis, the text inside, and +the closing parenthesis. +Groups 8-10 match the opening brace, the text inside, and the brace.") + +(defconst markdown-regex-pandoc-inline-footnote + "\\(?1:\\^\\)\\(?2:\\[\\)\\(?3:\\(?:.\\|\n[^\n]\\)*?\\)\\(?4:\\]\\)" + "Regular expression for Pandoc inline footnote^[footnote text]. +Group 1 matches the opening caret. +Group 2 matches the opening square bracket. +Group 3 matches the footnote text, without the surrounding markup. +Group 4 matches the closing square bracket.") + +(defconst markdown-regex-html-attr + "\\(\\<[[:alpha:]:-]+\\>\\)\\(\\s-*\\(=\\)\\s-*\\(\".*?\"\\|'.*?'\\|[^'\">[:space:]]+\\)?\\)?" + "Regular expression for matching HTML attributes and values. +Group 1 matches the attribute name. +Group 2 matches the following whitespace, equals sign, and value, if any. +Group 3 matches the equals sign, if any. +Group 4 matches single-, double-, or un-quoted attribute values.") + +(defconst markdown-regex-html-tag + (concat "\\(</?\\)\\(\\w+\\)\\(\\(\\s-+" markdown-regex-html-attr + "\\)+\\s-*\\|\\s-*\\)\\(/?>\\)") + "Regular expression for matching HTML tags. +Groups 1 and 9 match the beginning and ending angle brackets and slashes. +Group 2 matches the tag name. +Group 3 matches all attributes and whitespace following the tag name.") + +(defconst markdown-regex-html-entity + "\\(&#?[[:alnum:]]+;\\)" + "Regular expression for matching HTML entities.") + +(defconst markdown-regex-highlighting + "\\(?1:^\\|[^\\]\\)\\(?2:\\(?3:==\\)\\(?4:[^ \n\t\\]\\|[^ \n\t]\\(?:.\\|\n[^\n]\\)*?[^\\ ]\\)\\(?5:==\\)\\)" +"Regular expression for matching highlighting text. +Group 1 matches the character before the opening equal, if any, +ensuring that it is not a backslash escape. +Group 2 matches the entire expression, including delimiters. +Groups 3 and 5 matches the opening and closing delimiters. +Group 4 matches the text inside the delimiters.") + + +;;; Syntax ==================================================================== + +(defvar markdown--syntax-properties + (list 'markdown-tilde-fence-begin nil + 'markdown-tilde-fence-end nil + 'markdown-fenced-code nil + 'markdown-yaml-metadata-begin nil + 'markdown-yaml-metadata-end nil + 'markdown-yaml-metadata-section nil + 'markdown-gfm-block-begin nil + 'markdown-gfm-block-end nil + 'markdown-gfm-code nil + 'markdown-list-item nil + 'markdown-pre nil + 'markdown-blockquote nil + 'markdown-hr nil + 'markdown-comment nil + 'markdown-heading nil + 'markdown-heading-1-setext nil + 'markdown-heading-2-setext nil + 'markdown-heading-1-atx nil + 'markdown-heading-2-atx nil + 'markdown-heading-3-atx nil + 'markdown-heading-4-atx nil + 'markdown-heading-5-atx nil + 'markdown-heading-6-atx nil + 'markdown-metadata-key nil + 'markdown-metadata-value nil + 'markdown-metadata-markup nil) + "Property list of all Markdown syntactic properties.") + +(defvar markdown-literal-faces + '(markdown-code-face + markdown-inline-code-face + markdown-pre-face + markdown-math-face + markdown-url-face + markdown-plain-url-face + markdown-language-keyword-face + markdown-language-info-face + markdown-metadata-key-face + markdown-metadata-value-face + markdown-html-entity-face + markdown-html-tag-name-face + markdown-html-tag-delimiter-face + markdown-html-attr-name-face + markdown-html-attr-value-face + markdown-reference-face + markdown-footnote-marker-face + markdown-line-break-face + markdown-comment-face) + "A list of markdown-mode faces that contain literal text. +Literal text treats backslashes literally, rather than as an +escape character (see `markdown-match-escape').") + +(defsubst markdown-in-comment-p (&optional pos) + "Return non-nil if POS is in a comment. +If POS is not given, use point instead." + (get-text-property (or pos (point)) 'markdown-comment)) + +(defun markdown--face-p (pos faces) + "Return non-nil if face of POS contain FACES." + (let ((face-prop (get-text-property pos 'face))) + (if (listp face-prop) + (cl-loop for face in face-prop + thereis (memq face faces)) + (memq face-prop faces)))) + +(defsubst markdown--math-block-p (&optional pos) + (when markdown-enable-math + (markdown--face-p (or pos (point)) '(markdown-math-face)))) + +(defun markdown-syntax-propertize-extend-region (start end) + "Extend START to END region to include an entire block of text. +This helps improve syntax analysis for block constructs. +Returns a cons (NEW-START . NEW-END) or nil if no adjustment should be made. +Function is called repeatedly until it returns nil. For details, see +`syntax-propertize-extend-region-functions'." + (save-match-data + (save-excursion + (let* ((new-start (progn (goto-char start) + (skip-chars-forward "\n") + (if (re-search-backward "\n\n" nil t) + (min start (match-end 0)) + (point-min)))) + (new-end (progn (goto-char end) + (skip-chars-backward "\n") + (if (re-search-forward "\n\n" nil t) + (max end (match-beginning 0)) + (point-max)))) + (code-match (markdown-code-block-at-pos new-start)) + ;; FIXME: The `code-match' can return bogus values + ;; when text has been inserted/deleted! + (new-start (min (or (and code-match (cl-first code-match)) + (point-max)) + new-start)) + (code-match (and (< end (point-max)) + (markdown-code-block-at-pos end))) + (new-end (max (or (and code-match (cl-second code-match)) 0) + new-end))) + + (unless (and (eq new-start start) (eq new-end end)) + (cons new-start (min new-end (point-max)))))))) + +(defun markdown-font-lock-extend-region-function (start end _) + "Used in `jit-lock-after-change-extend-region-functions'. +Delegates to `markdown-syntax-propertize-extend-region'. START +and END are the previous region to refontify." + (let ((res (markdown-syntax-propertize-extend-region start end))) + (when res + ;; syntax-propertize-function is not called when character at + ;; (point-max) is deleted, but font-lock-extend-region-functions + ;; are called. Force a syntax property update in that case. + (when (= end (point-max)) + ;; This function is called in a buffer modification hook. + ;; `markdown-syntax-propertize' doesn't save the match data, + ;; so we have to do it here. + (save-match-data + (markdown-syntax-propertize (car res) (cdr res)))) + (setq jit-lock-start (car res) + jit-lock-end (cdr res))))) + +(defun markdown--cur-list-item-bounds () + "Return a list describing the list item at point. +Assumes that match data is set for `markdown-regex-list'. See the +documentation for `markdown-cur-list-item-bounds' for the format of +the returned list." + (save-excursion + (let* ((begin (match-beginning 0)) + (indent (length (match-string-no-properties 1))) + (nonlist-indent (- (match-end 3) (match-beginning 0))) + (marker (buffer-substring-no-properties + (match-beginning 2) (match-end 3))) + (checkbox (match-string-no-properties 4)) + (match (butlast (match-data t))) + (end (markdown-cur-list-item-end nonlist-indent))) + (list begin end indent nonlist-indent marker checkbox match)))) + +(defun markdown--append-list-item-bounds (marker indent cur-bounds bounds) + "Update list item BOUNDS given list MARKER, block INDENT, and CUR-BOUNDS. +Here, MARKER is a string representing the type of list and INDENT +is an integer giving the indentation, in spaces, of the current +block. CUR-BOUNDS is a list of the form returned by +`markdown-cur-list-item-bounds' and BOUNDS is a list of bounds +values for parent list items. When BOUNDS is nil, it means we are +at baseline (not inside of a nested list)." + (let ((prev-indent (or (cl-third (car bounds)) 0))) + (cond + ;; New list item at baseline. + ((and marker (null bounds)) + (list cur-bounds)) + ;; List item with greater indentation (four or more spaces). + ;; Increase list level by consing CUR-BOUNDS onto BOUNDS. + ((and marker (>= indent (+ prev-indent markdown-list-indent-width))) + (cons cur-bounds bounds)) + ;; List item with greater or equal indentation (less than four spaces). + ;; Keep list level the same by replacing the car of BOUNDS. + ((and marker (>= indent prev-indent)) + (cons cur-bounds (cdr bounds))) + ;; Lesser indentation level. + ;; Pop appropriate number of elements off BOUNDS list (e.g., lesser + ;; indentation could move back more than one list level). Note + ;; that this block need not be the beginning of list item. + ((< indent prev-indent) + (while (and (> (length bounds) 1) + (setq prev-indent (cl-third (cadr bounds))) + (< indent (+ prev-indent markdown-list-indent-width))) + (setq bounds (cdr bounds))) + (cons cur-bounds bounds)) + ;; Otherwise, do nothing. + (t bounds)))) + +(defun markdown-syntax-propertize-list-items (start end) + "Propertize list items from START to END. +Stores nested list item information in the `markdown-list-item' +text property to make later syntax analysis easier. The value of +this property is a list with elements of the form (begin . end) +giving the bounds of the current and parent list items." + (save-excursion + (goto-char start) + (let ((prev-list-line -100) + bounds level pre-regexp) + ;; Find a baseline point with zero list indentation + (markdown-search-backward-baseline) + ;; Search for all list items between baseline and END + (while (and (< (point) end) + (re-search-forward markdown-regex-list end 'limit)) + ;; Level of list nesting + (setq level (length bounds)) + ;; Pre blocks need to be indented one level past the list level + (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" (1+ level))) + (beginning-of-line) + (cond + ;; Reset at headings, horizontal rules, and top-level blank lines. + ;; Propertize baseline when in range. + ((markdown-new-baseline) + (setq bounds nil)) + ;; Make sure this is not a line from a pre block + ((and (looking-at-p pre-regexp) + ;; too indented line is also treated as list if previous line is list + (>= (- (line-number-at-pos) prev-list-line) 2))) + ;; If not, then update levels and propertize list item when in range. + (t + (let* ((indent (current-indentation)) + (cur-bounds (markdown--cur-list-item-bounds)) + (first (cl-first cur-bounds)) + (last (cl-second cur-bounds)) + (marker (cl-fifth cur-bounds))) + (setq bounds (markdown--append-list-item-bounds + marker indent cur-bounds bounds)) + (when (and (<= start (point)) (<= (point) end)) + (setq prev-list-line (line-number-at-pos first)) + (put-text-property first last 'markdown-list-item bounds))))) + (end-of-line))))) + +(defun markdown-syntax-propertize-pre-blocks (start end) + "Match preformatted text blocks from START to END." + (save-excursion + (goto-char start) + (let (finish) + ;; Use loop for avoiding too many recursive calls + ;; https://github.com/jrblevin/markdown-mode/issues/512 + (while (not finish) + (let ((levels (markdown-calculate-list-levels)) + indent pre-regexp close-regexp open close) + (while (and (< (point) end) (not close)) + ;; Search for a region with sufficient indentation + (if (null levels) + (setq indent 1) + (setq indent (1+ (length levels)))) + (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" indent)) + (setq close-regexp (format "^\\( \\|\t\\)\\{0,%d\\}\\([^ \t]\\)" (1- indent))) + + (cond + ;; If not at the beginning of a line, move forward + ((not (bolp)) (forward-line)) + ;; Move past blank lines + ((markdown-cur-line-blank-p) (forward-line)) + ;; At headers and horizontal rules, reset levels + ((markdown-new-baseline) (forward-line) (setq levels nil)) + ;; If the current line has sufficient indentation, mark out pre block + ;; The opening should be preceded by a blank line. + ((and (markdown-prev-line-blank) (looking-at pre-regexp)) + (setq open (match-beginning 0)) + (while (and (or (looking-at-p pre-regexp) (markdown-cur-line-blank-p)) + (not (eobp))) + (forward-line)) + (skip-syntax-backward "-") + (forward-line) + (setq close (point))) + ;; If current line has a list marker, update levels, move to end of block + ((looking-at markdown-regex-list) + (setq levels (markdown-update-list-levels + (match-string 2) (current-indentation) levels)) + (markdown-end-of-text-block)) + ;; If this is the end of the indentation level, adjust levels accordingly. + ;; Only match end of indentation level if levels is not the empty list. + ((and (car levels) (looking-at-p close-regexp)) + (setq levels (markdown-update-list-levels + nil (current-indentation) levels)) + (markdown-end-of-text-block)) + (t (markdown-end-of-text-block)))) + + (if (and open close) + ;; Set text property data and continue to search + (put-text-property open close 'markdown-pre (list open close)) + (setq finish t)))) + nil))) + +(defconst markdown-fenced-block-pairs + `(((,markdown-regex-tilde-fence-begin markdown-tilde-fence-begin) + (markdown-make-tilde-fence-regex markdown-tilde-fence-end) + markdown-fenced-code) + ((markdown-get-yaml-metadata-start-border markdown-yaml-metadata-begin) + (markdown-get-yaml-metadata-end-border markdown-yaml-metadata-end) + markdown-yaml-metadata-section) + ((,markdown-regex-gfm-code-block-open markdown-gfm-block-begin) + (,markdown-regex-gfm-code-block-close markdown-gfm-block-end) + markdown-gfm-code)) + "Mapping of regular expressions to \"fenced-block\" constructs. +These constructs are distinguished by having a distinctive start +and end pattern, both of which take up an entire line of text, +but no special pattern to identify text within the fenced +blocks (unlike blockquotes and indented-code sections). + +Each element within this list takes the form: + + ((START-REGEX-OR-FUN START-PROPERTY) + (END-REGEX-OR-FUN END-PROPERTY) + MIDDLE-PROPERTY) + +Each *-REGEX-OR-FUN element can be a regular expression as a string, or a +function which evaluates to same. Functions for START-REGEX-OR-FUN accept no +arguments, but functions for END-REGEX-OR-FUN accept a single numerical argument +which is the length of the first group of the START-REGEX-OR-FUN match, which +can be ignored if unnecessary. `markdown-maybe-funcall-regexp' is used to +evaluate these into \"real\" regexps. + +The *-PROPERTY elements are the text properties applied to each part of the +block construct when it is matched using +`markdown-syntax-propertize-fenced-block-constructs'. START-PROPERTY is applied +to the text matching START-REGEX-OR-FUN, END-PROPERTY to END-REGEX-OR-FUN, and +MIDDLE-PROPERTY to the text in between the two. The value of *-PROPERTY is the +`match-data' when the regexp was matched to the text. In the case of +MIDDLE-PROPERTY, the value is a false match data of the form \\='(begin end), with +begin and end set to the edges of the \"middle\" text. This makes fontification +easier.") + +(defun markdown-text-property-at-point (prop) + (get-text-property (point) prop)) + +(defsubst markdown-maybe-funcall-regexp (object &optional arg) + (cond ((functionp object) + (if arg (funcall object arg) (funcall object))) + ((stringp object) object) + (t (error "Object cannot be turned into regex")))) + +(defsubst markdown-get-start-fence-regexp () + "Return regexp to find all \"start\" sections of fenced block constructs. +Which construct is actually contained in the match must be found separately." + (mapconcat + #'identity + (mapcar (lambda (entry) (markdown-maybe-funcall-regexp (caar entry))) + markdown-fenced-block-pairs) + "\\|")) + +(defun markdown-get-fenced-block-begin-properties () + (cl-mapcar (lambda (entry) (cl-cadar entry)) markdown-fenced-block-pairs)) + +(defun markdown-get-fenced-block-end-properties () + (cl-mapcar (lambda (entry) (cl-cadadr entry)) markdown-fenced-block-pairs)) + +(defun markdown-get-fenced-block-middle-properties () + (cl-mapcar #'cl-third markdown-fenced-block-pairs)) + +(defun markdown-find-previous-prop (prop &optional lim) + "Find previous place where property PROP is non-nil, up to LIM. +Return a cons of (pos . property). pos is point if point contains +non-nil PROP." + (let ((res + (if (get-text-property (point) prop) (point) + (previous-single-property-change + (point) prop nil (or lim (point-min)))))) + (when (and (not (get-text-property res prop)) + (> res (point-min)) + (get-text-property (1- res) prop)) + (cl-decf res)) + (when (and res (get-text-property res prop)) (cons res prop)))) + +(defun markdown-find-next-prop (prop &optional lim) + "Find next place where property PROP is non-nil, up to LIM. +Return a cons of (POS . PROPERTY) where POS is point if point +contains non-nil PROP." + (let ((res + (if (get-text-property (point) prop) (point) + (next-single-property-change + (point) prop nil (or lim (point-max)))))) + (when (and res (get-text-property res prop)) (cons res prop)))) + +(defun markdown-min-of-seq (map-fn seq) + "Apply MAP-FN to SEQ and return element of SEQ with minimum value of MAP-FN." + (cl-loop for el in seq + with min = 1.0e+INF ; infinity + with min-el = nil + do (let ((res (funcall map-fn el))) + (when (< res min) + (setq min res) + (setq min-el el))) + finally return min-el)) + +(defun markdown-max-of-seq (map-fn seq) + "Apply MAP-FN to SEQ and return element of SEQ with maximum value of MAP-FN." + (cl-loop for el in seq + with max = -1.0e+INF ; negative infinity + with max-el = nil + do (let ((res (funcall map-fn el))) + (when (and res (> res max)) + (setq max res) + (setq max-el el))) + finally return max-el)) + +(defun markdown-find-previous-block () + "Find previous block. +Detect whether `markdown-syntax-propertize-fenced-block-constructs' was +unable to propertize the entire block, but was able to propertize the beginning +of the block. If so, return a cons of (pos . property) where the beginning of +the block was propertized." + (let ((start-pt (point)) + (closest-open + (markdown-max-of-seq + #'car + (cl-remove-if + #'null + (cl-mapcar + #'markdown-find-previous-prop + (markdown-get-fenced-block-begin-properties)))))) + (when closest-open + (let* ((length-of-open-match + (let ((match-d + (get-text-property (car closest-open) (cdr closest-open)))) + (- (cl-fourth match-d) (cl-third match-d)))) + (end-regexp + (markdown-maybe-funcall-regexp + (cl-caadr + (cl-find-if + (lambda (entry) (eq (cl-cadar entry) (cdr closest-open))) + markdown-fenced-block-pairs)) + length-of-open-match)) + (end-prop-loc + (save-excursion + (save-match-data + (goto-char (car closest-open)) + (and (re-search-forward end-regexp start-pt t) + (match-beginning 0)))))) + (and (not end-prop-loc) closest-open))))) + +(defun markdown-get-fenced-block-from-start (prop) + "Return limits of an enclosing fenced block from its start, using PROP. +Return value is a list usable as `match-data'." + (catch 'no-rest-of-block + (let* ((correct-entry + (cl-find-if + (lambda (entry) (eq (cl-cadar entry) prop)) + markdown-fenced-block-pairs)) + (begin-of-begin (cl-first (markdown-text-property-at-point prop))) + (middle-prop (cl-third correct-entry)) + (end-prop (cl-cadadr correct-entry)) + (end-of-end + (save-excursion + (goto-char (match-end 0)) ; end of begin + (unless (eobp) (forward-char)) + (let ((mid-prop-v (markdown-text-property-at-point middle-prop))) + (if (not mid-prop-v) ; no middle + (progn + ;; try to find end by advancing one + (let ((end-prop-v + (markdown-text-property-at-point end-prop))) + (if end-prop-v (cl-second end-prop-v) + (throw 'no-rest-of-block nil)))) + (set-match-data mid-prop-v) + (goto-char (match-end 0)) ; end of middle + (beginning-of-line) ; into end + (cl-second (markdown-text-property-at-point end-prop))))))) + (list begin-of-begin end-of-end)))) + +(defun markdown-get-fenced-block-from-middle (prop) + "Return limits of an enclosing fenced block from its middle, using PROP. +Return value is a list usable as `match-data'." + (let* ((correct-entry + (cl-find-if + (lambda (entry) (eq (cl-third entry) prop)) + markdown-fenced-block-pairs)) + (begin-prop (cl-cadar correct-entry)) + (begin-of-begin + (save-excursion + (goto-char (match-beginning 0)) + (unless (bobp) (forward-line -1)) + (beginning-of-line) + (cl-first (markdown-text-property-at-point begin-prop)))) + (end-prop (cl-cadadr correct-entry)) + (end-of-end + (save-excursion + (goto-char (match-end 0)) + (beginning-of-line) + (cl-second (markdown-text-property-at-point end-prop))))) + (list begin-of-begin end-of-end))) + +(defun markdown-get-fenced-block-from-end (prop) + "Return limits of an enclosing fenced block from its end, using PROP. +Return value is a list usable as `match-data'." + (let* ((correct-entry + (cl-find-if + (lambda (entry) (eq (cl-cadadr entry) prop)) + markdown-fenced-block-pairs)) + (end-of-end (cl-second (markdown-text-property-at-point prop))) + (middle-prop (cl-third correct-entry)) + (begin-prop (cl-cadar correct-entry)) + (begin-of-begin + (save-excursion + (goto-char (match-beginning 0)) ; beginning of end + (unless (bobp) (backward-char)) ; into middle + (let ((mid-prop-v (markdown-text-property-at-point middle-prop))) + (if (not mid-prop-v) + (progn + (beginning-of-line) + (cl-first (markdown-text-property-at-point begin-prop))) + (set-match-data mid-prop-v) + (goto-char (match-beginning 0)) ; beginning of middle + (unless (bobp) (forward-line -1)) ; into beginning + (beginning-of-line) + (cl-first (markdown-text-property-at-point begin-prop))))))) + (list begin-of-begin end-of-end))) + +(defun markdown-get-enclosing-fenced-block-construct (&optional pos) + "Get \"fake\" match data for block enclosing POS. +Returns fake match data which encloses the start, middle, and end +of the block construct enclosing POS, if it exists. Used in +`markdown-code-block-at-pos'." + (save-excursion + (when pos (goto-char pos)) + (beginning-of-line) + (car + (cl-remove-if + #'null + (cl-mapcar + (lambda (fun-and-prop) + (cl-destructuring-bind (fun prop) fun-and-prop + (when prop + (save-match-data + (set-match-data (markdown-text-property-at-point prop)) + (funcall fun prop))))) + `((markdown-get-fenced-block-from-start + ,(cl-find-if + #'markdown-text-property-at-point + (markdown-get-fenced-block-begin-properties))) + (markdown-get-fenced-block-from-middle + ,(cl-find-if + #'markdown-text-property-at-point + (markdown-get-fenced-block-middle-properties))) + (markdown-get-fenced-block-from-end + ,(cl-find-if + #'markdown-text-property-at-point + (markdown-get-fenced-block-end-properties))))))))) + +(defun markdown-propertize-end-match (reg end fence-spec middle-begin) + "Get match for REG up to END, if exists, and propertize appropriately. +FENCE-SPEC is an entry in `markdown-fenced-block-pairs' and +MIDDLE-BEGIN is the start of the \"middle\" section of the block." + (when (re-search-forward reg end t) + (let ((close-begin (match-beginning 0)) ; Start of closing line. + (close-end (match-end 0)) ; End of closing line. + (close-data (match-data t))) ; Match data for closing line. + ;; Propertize middle section of fenced block. + (put-text-property middle-begin close-begin + (cl-third fence-spec) + (list middle-begin close-begin)) + ;; If the block is a YAML block, propertize the declarations inside + (when (< middle-begin close-begin) ;; workaround #634 + (markdown-syntax-propertize-yaml-metadata middle-begin close-begin)) + ;; Propertize closing line of fenced block. + (put-text-property close-begin close-end + (cl-cadadr fence-spec) close-data)))) + +(defun markdown--triple-quote-single-line-p (begin) + (save-excursion + (goto-char begin) + (save-match-data + (and (search-forward "```" nil t) + (search-forward "```" (line-end-position) t))))) + +(defun markdown-syntax-propertize-fenced-block-constructs (start end) + "Propertize according to `markdown-fenced-block-pairs' from START to END. +If unable to propertize an entire block (if the start of a block is within START +and END, but the end of the block is not), propertize the start section of a +block, then in a subsequent call propertize both middle and end by finding the +start which was previously propertized." + (let ((start-reg (markdown-get-start-fence-regexp))) + (save-excursion + (goto-char start) + ;; start from previous unclosed block, if exists + (let ((prev-begin-block (markdown-find-previous-block))) + (when prev-begin-block + (let* ((correct-entry + (cl-find-if (lambda (entry) + (eq (cdr prev-begin-block) (cl-cadar entry))) + markdown-fenced-block-pairs)) + (enclosed-text-start (1+ (car prev-begin-block))) + (start-length + (save-excursion + (goto-char (car prev-begin-block)) + (string-match + (markdown-maybe-funcall-regexp + (caar correct-entry)) + (buffer-substring + (line-beginning-position) (line-end-position))) + (- (match-end 1) (match-beginning 1)))) + (end-reg (markdown-maybe-funcall-regexp + (cl-caadr correct-entry) start-length))) + (markdown-propertize-end-match + end-reg end correct-entry enclosed-text-start)))) + ;; find all new blocks within region + (while (re-search-forward start-reg end t) + ;; we assume the opening constructs take up (only) an entire line, + ;; so we re-check the current line + (let* ((block-start (match-beginning 0)) + (cur-line (buffer-substring (line-beginning-position) (line-end-position))) + ;; find entry in `markdown-fenced-block-pairs' corresponding + ;; to regex which was matched + (correct-entry + (cl-find-if + (lambda (fenced-pair) + (string-match-p + (markdown-maybe-funcall-regexp (caar fenced-pair)) + cur-line)) + markdown-fenced-block-pairs)) + (enclosed-text-start + (save-excursion (1+ (line-end-position)))) + (end-reg + (markdown-maybe-funcall-regexp + (cl-caadr correct-entry) + (if (and (match-beginning 1) (match-end 1)) + (- (match-end 1) (match-beginning 1)) + 0))) + (prop (cl-cadar correct-entry))) + (when (or (not (eq prop 'markdown-gfm-block-begin)) + (not (markdown--triple-quote-single-line-p block-start))) + ;; get correct match data + (save-excursion + (beginning-of-line) + (re-search-forward + (markdown-maybe-funcall-regexp (caar correct-entry)) + (line-end-position))) + ;; mark starting, even if ending is outside of region + (put-text-property (match-beginning 0) (match-end 0) prop (match-data t)) + (markdown-propertize-end-match + end-reg end correct-entry enclosed-text-start))))))) + +(defun markdown-syntax-propertize-blockquotes (start end) + "Match blockquotes from START to END." + (save-excursion + (goto-char start) + (while (and (re-search-forward markdown-regex-blockquote end t) + (not (markdown-code-block-at-pos (match-beginning 0)))) + (put-text-property (match-beginning 0) (match-end 0) + 'markdown-blockquote + (match-data t))))) + +(defun markdown-syntax-propertize-hrs (start end) + "Match horizontal rules from START to END." + (save-excursion + (goto-char start) + (while (re-search-forward markdown-regex-hr end t) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (goto-char beg) + (unless (or (markdown-on-heading-p) + (markdown-code-block-at-point-p)) + (put-text-property beg end 'markdown-hr (match-data t))) + (goto-char end))))) + +(defun markdown-syntax-propertize-yaml-metadata (start end) + "Propertize elements inside YAML metadata blocks from START to END. +Assumes region from START and END is already known to be the interior +region of a YAML metadata block as propertized by +`markdown-syntax-propertize-fenced-block-constructs'." + (save-excursion + (goto-char start) + (cl-loop + while (re-search-forward markdown-regex-declarative-metadata end t) + do (progn + (put-text-property (match-beginning 1) (match-end 1) + 'markdown-metadata-key (match-data t)) + (put-text-property (match-beginning 2) (match-end 2) + 'markdown-metadata-markup (match-data t)) + (put-text-property (match-beginning 3) (match-end 3) + 'markdown-metadata-value (match-data t)))))) + +(defun markdown-syntax-propertize-headings (start end) + "Match headings of type SYMBOL with REGEX from START to END." + (goto-char start) + (while (re-search-forward markdown-regex-header end t) + (unless (markdown-code-block-at-pos (match-beginning 0)) + (put-text-property + (match-beginning 0) (match-end 0) 'markdown-heading + (match-data t)) + (put-text-property + (match-beginning 0) (match-end 0) + (cond ((match-string-no-properties 2) 'markdown-heading-1-setext) + ((match-string-no-properties 3) 'markdown-heading-2-setext) + (t (let ((atx-level (length (markdown-trim-whitespace + (match-string-no-properties 4))))) + (intern (format "markdown-heading-%d-atx" atx-level))))) + (match-data t))))) + +(defun markdown-syntax-propertize-comments (start end) + "Match HTML comments from the START to END." + ;; Implement by loop instead of recursive call for avoiding + ;; exceed max-lisp-eval-depth issue + ;; https://github.com/jrblevin/markdown-mode/issues/536 + (let (finish) + (goto-char start) + (while (not finish) + (let* ((in-comment (nth 4 (syntax-ppss))) + (comment-begin (nth 8 (syntax-ppss)))) + (cond + ;; Comment start + ((and (not in-comment) + (re-search-forward markdown-regex-comment-start end t) + (not (markdown-inline-code-at-point-p)) + (not (markdown-code-block-at-point-p))) + (let ((open-beg (match-beginning 0))) + (put-text-property open-beg (1+ open-beg) + 'syntax-table (string-to-syntax "<")) + (goto-char (min (1+ (match-end 0)) end (point-max))))) + ;; Comment end + ((and in-comment comment-begin + (re-search-forward markdown-regex-comment-end end t)) + (let ((comment-end (match-end 0))) + (put-text-property (1- comment-end) comment-end + 'syntax-table (string-to-syntax ">")) + ;; Remove any other text properties inside the comment + (remove-text-properties comment-begin comment-end + markdown--syntax-properties) + (put-text-property comment-begin comment-end + 'markdown-comment (list comment-begin comment-end)) + (goto-char (min comment-end end (point-max))))) + ;; Nothing found + (t (setq finish t))))) + nil)) + +(defun markdown-syntax-propertize (start end) + "Function used as `syntax-propertize-function'. +START and END delimit region to propertize." + (with-silent-modifications + (save-excursion + (remove-text-properties start end markdown--syntax-properties) + (markdown-syntax-propertize-fenced-block-constructs start end) + (markdown-syntax-propertize-list-items start end) + (markdown-syntax-propertize-pre-blocks start end) + (markdown-syntax-propertize-blockquotes start end) + (markdown-syntax-propertize-headings start end) + (markdown-syntax-propertize-hrs start end) + (markdown-syntax-propertize-comments start end)))) + + +;;; Markup Hiding ============================================================= + +(defconst markdown-markup-properties + '(face markdown-markup-face invisible markdown-markup) + "List of properties and values to apply to markup.") + +(defconst markdown-line-break-properties + '(face markdown-line-break-face invisible markdown-markup) + "List of properties and values to apply to line break markup.") + +(defconst markdown-language-keyword-properties + '(face markdown-language-keyword-face invisible markdown-markup) + "List of properties and values to apply to code block language names.") + +(defconst markdown-language-info-properties + '(face markdown-language-info-face invisible markdown-markup) + "List of properties and values to apply to code block language info strings.") + +(defconst markdown-include-title-properties + '(face markdown-link-title-face invisible markdown-markup) + "List of properties and values to apply to included code titles.") + +(defcustom markdown-hide-markup nil + "Determines whether markup in the buffer will be hidden. +When set to nil, all markup is displayed in the buffer as it +appears in the file. An exception is when `markdown-hide-urls' +is non-nil. +Set this to a non-nil value to turn this feature on by default. +You can interactively toggle the value of this variable with +`markdown-toggle-markup-hiding', \\[markdown-toggle-markup-hiding], +or from the Markdown > Show & Hide menu. + +Markup hiding works by adding text properties to positions in the +buffer---either the `invisible' property or the `display' property +in cases where alternative glyphs are used (e.g., list bullets). +This does not, however, affect printing or other output. +Functions such as `htmlfontify-buffer' and `ps-print-buffer' will +not honor these text properties. For printing, it would be better +to first convert to HTML or PDF (e.g,. using Pandoc)." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.3")) +(make-variable-buffer-local 'markdown-hide-markup) + +(defun markdown-toggle-markup-hiding (&optional arg) + "Toggle the display or hiding of markup. +With a prefix argument ARG, enable markup hiding if ARG is positive, +and disable it otherwise. +See `markdown-hide-markup' for additional details." + (interactive (list (or current-prefix-arg 'toggle))) + (setq markdown-hide-markup + (if (eq arg 'toggle) + (not markdown-hide-markup) + (> (prefix-numeric-value arg) 0))) + (if markdown-hide-markup + (add-to-invisibility-spec 'markdown-markup) + (remove-from-invisibility-spec 'markdown-markup)) + (when (called-interactively-p 'interactive) + (message "markdown-mode markup hiding %s" (if markdown-hide-markup "enabled" "disabled"))) + (markdown-reload-extensions)) + + +;;; Font Lock ================================================================= + +(require 'font-lock) + +(defgroup markdown-faces nil + "Faces used in Markdown Mode." + :group 'markdown + :group 'faces) + +(defface markdown-italic-face + '((t (:inherit italic))) + "Face for italic text." + :group 'markdown-faces) + +(defface markdown-bold-face + '((t (:inherit bold))) + "Face for bold text." + :group 'markdown-faces) + +(defface markdown-strike-through-face + '((t (:strike-through t))) + "Face for strike-through text." + :group 'markdown-faces) + +(defface markdown-markup-face + '((t (:inherit shadow :slant normal :weight normal))) + "Face for markup elements." + :group 'markdown-faces) + +(defface markdown-header-rule-face + '((t (:inherit markdown-markup-face))) + "Base face for headers rules." + :group 'markdown-faces) + +(defface markdown-header-delimiter-face + '((t (:inherit markdown-markup-face))) + "Base face for headers hash delimiter." + :group 'markdown-faces) + +(defface markdown-list-face + '((t (:inherit markdown-markup-face))) + "Face for list item markers." + :group 'markdown-faces) + +(defface markdown-blockquote-face + '((t (:inherit font-lock-doc-face))) + "Face for blockquote sections." + :group 'markdown-faces) + +(defface markdown-code-face + '((t (:inherit fixed-pitch))) + "Face for inline code, pre blocks, and fenced code blocks. +This may be used, for example, to add a contrasting background to +inline code fragments and code blocks." + :group 'markdown-faces) + +(defface markdown-inline-code-face + '((t (:inherit (markdown-code-face font-lock-constant-face)))) + "Face for inline code." + :group 'markdown-faces) + +(defface markdown-pre-face + '((t (:inherit (markdown-code-face font-lock-constant-face)))) + "Face for preformatted text." + :group 'markdown-faces) + +(defface markdown-table-face + '((t (:inherit (markdown-code-face)))) + "Face for tables." + :group 'markdown-faces) + +(defface markdown-language-keyword-face + '((t (:inherit font-lock-type-face))) + "Face for programming language identifiers." + :group 'markdown-faces) + +(defface markdown-language-info-face + '((t (:inherit font-lock-string-face))) + "Face for programming language info strings." + :group 'markdown-faces) + +(defface markdown-link-face + '((t (:inherit link))) + "Face for links." + :group 'markdown-faces) + +(defface markdown-missing-link-face + '((t (:inherit font-lock-warning-face))) + "Face for missing links." + :group 'markdown-faces) + +(defface markdown-reference-face + '((t (:inherit markdown-markup-face))) + "Face for link references." + :group 'markdown-faces) + +(defface markdown-footnote-marker-face + '((t (:inherit markdown-markup-face))) + "Face for footnote markers." + :group 'markdown-faces) + +(defface markdown-footnote-text-face + '((t (:inherit font-lock-comment-face))) + "Face for footnote text." + :group 'markdown-faces) + +(defface markdown-url-face + '((t (:inherit font-lock-string-face))) + "Face for URLs that are part of markup. +For example, this applies to URLs in inline links: +[link text](http://example.com/)." + :group 'markdown-faces) + +(defface markdown-plain-url-face + '((t (:inherit markdown-link-face))) + "Face for URLs that are also links. +For example, this applies to plain angle bracket URLs: +<http://example.com/>." + :group 'markdown-faces) + +(defface markdown-link-title-face + '((t (:inherit font-lock-comment-face))) + "Face for reference link titles." + :group 'markdown-faces) + +(defface markdown-line-break-face + '((t (:inherit font-lock-constant-face :underline t))) + "Face for hard line breaks." + :group 'markdown-faces) + +(defface markdown-comment-face + '((t (:inherit font-lock-comment-face))) + "Face for HTML comments." + :group 'markdown-faces) + +(defface markdown-math-face + '((t (:inherit font-lock-string-face))) + "Face for LaTeX expressions." + :group 'markdown-faces) + +(defface markdown-metadata-key-face + '((t (:inherit font-lock-variable-name-face))) + "Face for metadata keys." + :group 'markdown-faces) + +(defface markdown-metadata-value-face + '((t (:inherit font-lock-string-face))) + "Face for metadata values." + :group 'markdown-faces) + +(defface markdown-gfm-checkbox-face + '((t (:inherit font-lock-builtin-face))) + "Face for GFM checkboxes." + :group 'markdown-faces) + +(defface markdown-highlight-face + '((t (:inherit highlight))) + "Face for mouse highlighting." + :group 'markdown-faces) + +(defface markdown-hr-face + '((t (:inherit markdown-markup-face))) + "Face for horizontal rules." + :group 'markdown-faces) + +(defface markdown-html-tag-name-face + '((t (:inherit font-lock-type-face))) + "Face for HTML tag names." + :group 'markdown-faces) + +(defface markdown-html-tag-delimiter-face + '((t (:inherit markdown-markup-face))) + "Face for HTML tag delimiters." + :group 'markdown-faces) + +(defface markdown-html-attr-name-face + '((t (:inherit font-lock-variable-name-face))) + "Face for HTML attribute names." + :group 'markdown-faces) + +(defface markdown-html-attr-value-face + '((t (:inherit font-lock-string-face))) + "Face for HTML attribute values." + :group 'markdown-faces) + +(defface markdown-html-entity-face + '((t (:inherit font-lock-variable-name-face))) + "Face for HTML entities." + :group 'markdown-faces) + +(defface markdown-highlighting-face + '((t (:background "yellow" :foreground "black"))) + "Face for highlighting." + :group 'markdown-faces) + +(defcustom markdown-header-scaling nil + "Whether to use variable-height faces for headers. +When non-nil, `markdown-header-face' will inherit from +`variable-pitch' and the scaling values in +`markdown-header-scaling-values' will be applied to +headers of levels one through six respectively." + :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + (markdown-update-header-faces value)) + :group 'markdown-faces + :package-version '(markdown-mode . "2.2")) + +(defcustom markdown-header-scaling-values + '(2.0 1.7 1.4 1.1 1.0 1.0) + "List of scaling values for headers of level one through six. +Used when `markdown-header-scaling' is non-nil." + :type '(repeat float) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + (markdown-update-header-faces markdown-header-scaling value))) + +(defmacro markdown--dotimes-when-compile (i-n body) + (declare (indent 1) (debug ((symbolp form) form))) + (let ((var (car i-n)) + (n (cadr i-n)) + (code ())) + (dotimes (i (eval n t)) + (push (eval body `((,var . ,i))) code)) + `(progn ,@(nreverse code)))) + +(defface markdown-header-face + `((t (:inherit (,@(when markdown-header-scaling '(variable-pitch)) + font-lock-function-name-face) + :weight bold))) + "Base face for headers.") + +(markdown--dotimes-when-compile (num 6) + (let* ((num1 (1+ num)) + (face-name (intern (format "markdown-header-face-%s" num1)))) + `(defface ,face-name + (,'\` ((t (:inherit markdown-header-face + :height + (,'\, (if markdown-header-scaling + (float (nth ,num markdown-header-scaling-values)) + 1.0)))))) + (format "Face for level %s headers. +You probably don't want to customize this face directly. Instead +you can customize the base face `markdown-header-face' or the +variable-height variable `markdown-header-scaling'." ,num1)))) + +(defun markdown-update-header-faces (&optional scaling scaling-values) + "Update header faces, depending on if header SCALING is desired. +If so, use given list of SCALING-VALUES relative to the baseline +size of `markdown-header-face'." + (dotimes (num 6) + (let* ((face-name (intern (format "markdown-header-face-%s" (1+ num)))) + (scale (cond ((not scaling) 1.0) + (scaling-values (float (nth num scaling-values))) + (t (float (nth num markdown-header-scaling-values)))))) + (unless (get face-name 'saved-face) ; Don't update customized faces + (set-face-attribute face-name nil :height scale))))) + +(defun markdown-syntactic-face (state) + "Return font-lock face for characters with given STATE. +See `font-lock-syntactic-face-function' for details." + (let ((in-comment (nth 4 state))) + (cond + (in-comment 'markdown-comment-face) + (t nil)))) + +(defcustom markdown-list-item-bullets + '("●" "◎" "○" "◆" "◇" "►" "•") + "List of bullets to use for unordered lists. +It can contain any number of symbols, which will be repeated. +Depending on your font, some reasonable choices are: +♥ ● ◇ ✚ ✜ ☯ ◆ ♠ ♣ ♦ ❀ ◆ ◖ ▶ ► • ★ ▸." + :group 'markdown + :type '(repeat (string :tag "Bullet character")) + :package-version '(markdown-mode . "2.3")) + +(defun markdown--footnote-marker-properties () + "Return a font-lock facespec expression for footnote marker text." + `(face markdown-footnote-marker-face + ,@(when markdown-hide-markup + `(display ,markdown-footnote-display)))) + +(defun markdown--pandoc-inline-footnote-properties () + "Return a font-lock facespec expression for Pandoc inline footnote text." + `(face markdown-footnote-text-face + ,@(when markdown-hide-markup + `(display ,markdown-footnote-display)))) + +(defvar markdown-mode-font-lock-keywords + `((markdown-match-yaml-metadata-begin . ((1 'markdown-markup-face))) + (markdown-match-yaml-metadata-end . ((1 'markdown-markup-face))) + (markdown-match-yaml-metadata-key . ((1 'markdown-metadata-key-face) + (2 'markdown-markup-face) + (3 'markdown-metadata-value-face))) + (markdown-match-gfm-open-code-blocks . ((1 markdown-markup-properties) + (2 markdown-markup-properties nil t) + (3 markdown-language-keyword-properties nil t) + (4 markdown-language-info-properties nil t) + (5 markdown-markup-properties nil t))) + (markdown-match-gfm-close-code-blocks . ((0 markdown-markup-properties))) + (markdown-fontify-gfm-code-blocks) + (markdown-fontify-tables) + (markdown-match-fenced-start-code-block . ((1 markdown-markup-properties) + (2 markdown-markup-properties nil t) + (3 markdown-language-keyword-properties nil t) + (4 markdown-language-info-properties nil t) + (5 markdown-markup-properties nil t))) + (markdown-match-fenced-end-code-block . ((0 markdown-markup-properties))) + (markdown-fontify-fenced-code-blocks) + (markdown-match-pre-blocks . ((0 'markdown-pre-face))) + (markdown-fontify-headings) + (markdown-match-declarative-metadata . ((1 'markdown-metadata-key-face) + (2 'markdown-markup-face) + (3 'markdown-metadata-value-face))) + (markdown-match-pandoc-metadata . ((1 'markdown-markup-face) + (2 'markdown-markup-face) + (3 'markdown-metadata-value-face))) + (markdown-fontify-hrs) + (markdown-match-code . ((1 markdown-markup-properties prepend) + (2 'markdown-inline-code-face prepend) + (3 markdown-markup-properties prepend))) + (,markdown-regex-kbd . ((1 markdown-markup-properties) + (2 'markdown-inline-code-face) + (3 markdown-markup-properties))) + (markdown-fontify-angle-uris) + (,markdown-regex-email . 'markdown-plain-url-face) + (markdown-match-html-tag . ((1 'markdown-html-tag-delimiter-face t) + (2 'markdown-html-tag-name-face t) + (3 'markdown-html-tag-delimiter-face t) + ;; Anchored matcher for HTML tag attributes + (,markdown-regex-html-attr + ;; Before searching, move past tag + ;; name; set limit at tag close. + (progn + (goto-char (match-end 2)) (match-end 3)) + nil + . ((1 'markdown-html-attr-name-face) + (3 'markdown-html-tag-delimiter-face nil t) + (4 'markdown-html-attr-value-face nil t))))) + (,markdown-regex-html-entity . 'markdown-html-entity-face) + (markdown-fontify-list-items) + (,markdown-regex-footnote . ((1 markdown-markup-properties) ; [^ + (2 (markdown--footnote-marker-properties)) ; label + (3 markdown-markup-properties))) ; ] + (,markdown-regex-pandoc-inline-footnote . ((1 markdown-markup-properties) ; ^ + (2 markdown-markup-properties) ; [ + (3 (markdown--pandoc-inline-footnote-properties)) ; text + (4 markdown-markup-properties))) ; ] + (markdown-match-includes . ((1 markdown-markup-properties) + (2 markdown-markup-properties nil t) + (3 markdown-include-title-properties nil t) + (4 markdown-markup-properties nil t) + (5 markdown-markup-properties) + (6 'markdown-url-face) + (7 markdown-markup-properties))) + (markdown-fontify-inline-links) + (markdown-fontify-reference-links) + (,markdown-regex-reference-definition . ((1 'markdown-markup-face) ; [ + (2 'markdown-reference-face) ; label + (3 'markdown-markup-face) ; ] + (4 'markdown-markup-face) ; : + (5 'markdown-url-face) ; url + (6 'markdown-link-title-face))) ; "title" (optional) + (markdown-fontify-plain-uris) + ;; Math mode $..$ + (markdown-match-math-single . ((1 'markdown-markup-face prepend) + (2 'markdown-math-face append) + (3 'markdown-markup-face prepend))) + ;; Math mode $$..$$ + (markdown-match-math-double . ((1 'markdown-markup-face prepend) + (2 'markdown-math-face append) + (3 'markdown-markup-face prepend))) + ;; Math mode \[..\] and \\[..\\] + (markdown-match-math-display . ((1 'markdown-markup-face prepend) + (3 'markdown-math-face append) + (4 'markdown-markup-face prepend))) + (markdown-match-bold . ((1 markdown-markup-properties prepend) + (2 'markdown-bold-face append) + (3 markdown-markup-properties prepend))) + (markdown-match-italic . ((1 markdown-markup-properties prepend) + (2 'markdown-italic-face append) + (3 markdown-markup-properties prepend))) + (,markdown-regex-strike-through . ((3 markdown-markup-properties) + (4 'markdown-strike-through-face) + (5 markdown-markup-properties))) + (markdown--match-highlighting . ((3 markdown-markup-properties) + (4 'markdown-highlighting-face) + (5 markdown-markup-properties))) + (,markdown-regex-line-break . (1 markdown-line-break-properties prepend)) + (markdown-match-escape . ((1 markdown-markup-properties prepend))) + (markdown-fontify-sub-superscripts) + (markdown-match-inline-attributes . ((0 markdown-markup-properties prepend))) + (markdown-match-leanpub-sections . ((0 markdown-markup-properties))) + (markdown-fontify-blockquotes) + (markdown-match-wiki-link . ((0 'markdown-link-face prepend)))) + "Syntax highlighting for Markdown files.") + +;; Footnotes +(defvar-local markdown-footnote-counter 0 + "Counter for footnote numbers.") + +(defconst markdown-footnote-chars + "[[:alnum:]-]" + "Regular expression matching any character for a footnote identifier.") + +(defconst markdown-regex-footnote-definition + (concat "^ \\{0,3\\}\\[\\(\\^" markdown-footnote-chars "*?\\)\\]:\\(?:[ \t]+\\|$\\)") + "Regular expression matching a footnote definition, capturing the label.") + + +;;; Compatibility ============================================================= + +(defun markdown--pandoc-reference-p () + (let ((bounds (bounds-of-thing-at-point 'word))) + (when (and bounds (char-before (car bounds))) + (= (char-before (car bounds)) ?@)))) + +(defun markdown-flyspell-check-word-p () + "Return t if `flyspell' should check word just before point. +Used for `flyspell-generic-check-word-predicate'." + (save-excursion + (goto-char (1- (point))) + ;; https://github.com/jrblevin/markdown-mode/issues/560 + ;; enable spell check YAML meta data + (if (or (and (markdown-code-block-at-point-p) + (not (markdown-text-property-at-point 'markdown-yaml-metadata-section))) + (markdown-inline-code-at-point-p) + (markdown-in-comment-p) + (markdown--face-p (point) '(markdown-reference-face + markdown-markup-face + markdown-plain-url-face + markdown-inline-code-face + markdown-url-face)) + (markdown--pandoc-reference-p)) + (prog1 nil + ;; If flyspell overlay is put, then remove it + (let ((bounds (bounds-of-thing-at-point 'word))) + (when bounds + (cl-loop for ov in (overlays-in (car bounds) (cdr bounds)) + when (overlay-get ov 'flyspell-overlay) + do + (delete-overlay ov))))) + t))) + + +;;; Markdown Parsing Functions ================================================ + +(defun markdown-cur-line-blank-p () + "Return t if the current line is blank and nil otherwise." + (save-excursion + (beginning-of-line) + (looking-at-p markdown-regex-blank-line))) + +(defun markdown-prev-line-blank () + "Return t if the previous line is blank and nil otherwise. +If we are at the first line, then consider the previous line to be blank." + (or (= (line-beginning-position) (point-min)) + (save-excursion + (forward-line -1) + (looking-at markdown-regex-blank-line)))) + +(defun markdown-prev-line-blank-p () + "Like `markdown-prev-line-blank', but preserve `match-data'." + (save-match-data (markdown-prev-line-blank))) + +(defun markdown-next-line-blank-p () + "Return t if the next line is blank and nil otherwise. +If we are at the last line, then consider the next line to be blank." + (or (= (line-end-position) (point-max)) + (save-excursion + (forward-line 1) + (markdown-cur-line-blank-p)))) + +(defun markdown-prev-line-indent () + "Return the number of leading whitespace characters in the previous line. +Return 0 if the current line is the first line in the buffer." + (save-excursion + (if (= (line-beginning-position) (point-min)) + 0 + (forward-line -1) + (current-indentation)))) + +(defun markdown-next-line-indent () + "Return the number of leading whitespace characters in the next line. +Return 0 if line is the last line in the buffer." + (save-excursion + (if (= (line-end-position) (point-max)) + 0 + (forward-line 1) + (current-indentation)))) + +(defun markdown-new-baseline () + "Determine if the current line begins a new baseline level. +Assume point is positioned at beginning of line." + (or (looking-at markdown-regex-header) + (looking-at markdown-regex-hr) + (and (= (current-indentation) 0) + (not (looking-at markdown-regex-list)) + (markdown-prev-line-blank)))) + +(defun markdown-search-backward-baseline () + "Search backward baseline point with no indentation and not a list item." + (end-of-line) + (let (stop) + (while (not (or stop (bobp))) + (re-search-backward markdown-regex-block-separator-noindent nil t) + (when (match-end 2) + (goto-char (match-end 2)) + (cond + ((markdown-new-baseline) + (setq stop t)) + ((looking-at-p markdown-regex-list) + (setq stop nil)) + (t (setq stop t))))))) + +(defun markdown-update-list-levels (marker indent levels) + "Update list levels given list MARKER, block INDENT, and current LEVELS. +Here, MARKER is a string representing the type of list, INDENT is an integer +giving the indentation, in spaces, of the current block, and LEVELS is a +list of the indentation levels of parent list items. When LEVELS is nil, +it means we are at baseline (not inside of a nested list)." + (cond + ;; New list item at baseline. + ((and marker (null levels)) + (setq levels (list indent))) + ;; List item with greater indentation (four or more spaces). + ;; Increase list level. + ((and marker (>= indent (+ (car levels) markdown-list-indent-width))) + (setq levels (cons indent levels))) + ;; List item with greater or equal indentation (less than four spaces). + ;; Do not increase list level. + ((and marker (>= indent (car levels))) + levels) + ;; Lesser indentation level. + ;; Pop appropriate number of elements off LEVELS list (e.g., lesser + ;; indentation could move back more than one list level). Note + ;; that this block need not be the beginning of list item. + ((< indent (car levels)) + (while (and (> (length levels) 1) + (< indent (+ (cadr levels) markdown-list-indent-width))) + (setq levels (cdr levels))) + levels) + ;; Otherwise, do nothing. + (t levels))) + +(defun markdown-calculate-list-levels () + "Calculate list levels at point. +Return a list of the form (n1 n2 n3 ...) where n1 is the +indentation of the deepest nested list item in the branch of +the list at the point, n2 is the indentation of the parent +list item, and so on. The depth of the list item is therefore +the length of the returned list. If the point is not at or +immediately after a list item, return nil." + (save-excursion + (let ((first (point)) levels indent pre-regexp) + ;; Find a baseline point with zero list indentation + (markdown-search-backward-baseline) + ;; Search for all list items between baseline and LOC + (while (and (< (point) first) + (re-search-forward markdown-regex-list first t)) + (setq pre-regexp (format "^\\( \\|\t\\)\\{%d\\}" (1+ (length levels)))) + (beginning-of-line) + (cond + ;; Make sure this is not a header or hr + ((markdown-new-baseline) (setq levels nil)) + ;; Make sure this is not a line from a pre block + ((looking-at-p pre-regexp)) + ;; If not, then update levels + (t + (setq indent (current-indentation)) + (setq levels (markdown-update-list-levels (match-string 2) + indent levels)))) + (end-of-line)) + levels))) + +(defun markdown-prev-list-item (level) + "Search backward from point for a list item with indentation LEVEL. +Set point to the beginning of the item, and return point, or nil +upon failure." + (let (bounds indent prev) + (setq prev (point)) + (forward-line -1) + (setq indent (current-indentation)) + (while + (cond + ;; List item + ((and (looking-at-p markdown-regex-list) + (setq bounds (markdown-cur-list-item-bounds))) + (cond + ;; Stop and return point at item of equal indentation + ((= (nth 3 bounds) level) + (setq prev (point)) + nil) + ;; Stop and return nil at item with lesser indentation + ((< (nth 3 bounds) level) + (setq prev nil) + nil) + ;; Stop at beginning of buffer + ((bobp) (setq prev nil)) + ;; Continue at item with greater indentation + ((> (nth 3 bounds) level) t))) + ;; Stop at beginning of buffer + ((bobp) (setq prev nil)) + ;; Continue if current line is blank + ((markdown-cur-line-blank-p) t) + ;; Continue while indentation is the same or greater + ((>= indent level) t) + ;; Stop if current indentation is less than list item + ;; and the next is blank + ((and (< indent level) + (markdown-next-line-blank-p)) + (setq prev nil)) + ;; Stop at a header + ((looking-at-p markdown-regex-header) (setq prev nil)) + ;; Stop at a horizontal rule + ((looking-at-p markdown-regex-hr) (setq prev nil)) + ;; Otherwise, continue. + (t t)) + (forward-line -1) + (setq indent (current-indentation))) + prev)) + +(defun markdown-next-list-item (level) + "Search forward from point for the next list item with indentation LEVEL. +Set point to the beginning of the item, and return point, or nil +upon failure." + (let (bounds indent next) + (setq next (point)) + (if (looking-at markdown-regex-header-setext) + (goto-char (match-end 0))) + (forward-line) + (setq indent (current-indentation)) + (while + (cond + ;; Stop at end of the buffer. + ((eobp) nil) + ;; Continue if the current line is blank + ((markdown-cur-line-blank-p) t) + ;; List item + ((and (looking-at-p markdown-regex-list) + (setq bounds (markdown-cur-list-item-bounds))) + (cond + ;; Continue at item with greater indentation + ((> (nth 3 bounds) level) t) + ;; Stop and return point at item of equal indentation + ((= (nth 3 bounds) level) + (setq next (point)) + nil) + ;; Stop and return nil at item with lesser indentation + ((< (nth 3 bounds) level) + (setq next nil) + nil))) + ;; Continue while indentation is the same or greater + ((>= indent level) t) + ;; Stop if current indentation is less than list item + ;; and the previous line was blank. + ((and (< indent level) + (markdown-prev-line-blank-p)) + (setq next nil)) + ;; Stop at a header + ((looking-at-p markdown-regex-header) (setq next nil)) + ;; Stop at a horizontal rule + ((looking-at-p markdown-regex-hr) (setq next nil)) + ;; Otherwise, continue. + (t t)) + (forward-line) + (setq indent (current-indentation))) + next)) + +(defun markdown-cur-list-item-end (level) + "Move to end of list item with pre-marker indentation LEVEL. +Return the point at the end when a list item was found at the +original point. If the point is not in a list item, do nothing." + (let (indent) + (forward-line) + (setq indent (current-indentation)) + (while + (cond + ;; Stop at end of the buffer. + ((eobp) nil) + ;; Continue while indentation is the same or greater + ((>= indent level) t) + ;; Continue if the current line is blank + ((looking-at markdown-regex-blank-line) t) + ;; Stop if current indentation is less than list item + ;; and the previous line was blank. + ((and (< indent level) + (markdown-prev-line-blank)) + nil) + ;; Stop at a new list items of the same or lesser + ;; indentation, headings, and horizontal rules. + ((looking-at (concat "\\(?:" markdown-regex-list + "\\|" markdown-regex-header + "\\|" markdown-regex-hr "\\)")) + nil) + ;; Otherwise, continue. + (t t)) + (forward-line) + (setq indent (current-indentation))) + ;; Don't skip over whitespace for empty list items (marker and + ;; whitespace only), just move to end of whitespace. + (if (save-excursion + (beginning-of-line) + (looking-at (concat markdown-regex-list "[ \t]*$"))) + (goto-char (match-end 3)) + (skip-chars-backward " \t\n")) + (end-of-line) + (point))) + +(defun markdown-cur-list-item-bounds () + "Return bounds for list item at point. +Return a list of the following form: + + (begin end indent nonlist-indent marker checkbox match) + +The named components are: + + - begin: Position of beginning of list item, including leading indentation. + - end: Position of the end of the list item, including list item text. + - indent: Number of characters of indentation before list marker (an integer). + - nonlist-indent: Number characters of indentation, list + marker, and whitespace following list marker (an integer). + - marker: String containing the list marker and following whitespace + (e.g., \"- \" or \"* \"). + - checkbox: String containing the GFM checkbox portion, if any, + including any trailing whitespace before the text + begins (e.g., \"[x] \"). + - match: match data for markdown-regex-list + +As an example, for the following unordered list item + + - item + +the returned list would be + + (1 14 3 5 \"- \" nil (1 6 1 4 4 5 5 6)) + +If the point is not inside a list item, return nil." + (car (get-text-property (line-beginning-position) 'markdown-list-item))) + +(defun markdown-list-item-at-point-p () + "Return t if there is a list item at the point and nil otherwise." + (save-match-data (markdown-cur-list-item-bounds))) + +(defun markdown-prev-list-item-bounds () + "Return bounds of previous item in the same list of any level. +The return value has the same form as that of +`markdown-cur-list-item-bounds'." + (save-excursion + (let ((cur-bounds (markdown-cur-list-item-bounds)) + (beginning-of-list (save-excursion (markdown-beginning-of-list))) + stop) + (when cur-bounds + (goto-char (nth 0 cur-bounds)) + (while (and (not stop) (not (bobp)) + (re-search-backward markdown-regex-list + beginning-of-list t)) + (unless (or (looking-at markdown-regex-hr) + (markdown-code-block-at-point-p)) + (setq stop (point)))) + (markdown-cur-list-item-bounds))))) + +(defun markdown-next-list-item-bounds () + "Return bounds of next item in the same list of any level. +The return value has the same form as that of +`markdown-cur-list-item-bounds'." + (save-excursion + (let ((cur-bounds (markdown-cur-list-item-bounds)) + (end-of-list (save-excursion (markdown-end-of-list))) + stop) + (when cur-bounds + (goto-char (nth 0 cur-bounds)) + (end-of-line) + (while (and (not stop) (not (eobp)) + (re-search-forward markdown-regex-list + end-of-list t)) + (unless (or (looking-at markdown-regex-hr) + (markdown-code-block-at-point-p)) + (setq stop (point)))) + (when stop + (markdown-cur-list-item-bounds)))))) + +(defun markdown-beginning-of-list () + "Move point to beginning of list at point, if any." + (interactive) + (let ((orig-point (point)) + (list-begin (save-excursion + (markdown-search-backward-baseline) + ;; Stop at next list item, regardless of the indentation. + (markdown-next-list-item (point-max)) + (when (looking-at markdown-regex-list) + (point))))) + (when (and list-begin (<= list-begin orig-point)) + (goto-char list-begin)))) + +(defun markdown-end-of-list () + "Move point to end of list at point, if any." + (interactive) + (let ((start (point)) + (end (save-excursion + (when (markdown-beginning-of-list) + ;; Items can't have nonlist-indent <= 1, so this + ;; moves past all list items. + (markdown-next-list-item 1) + (skip-syntax-backward "-") + (unless (eobp) (forward-char 1)) + (point))))) + (when (and end (>= end start)) + (goto-char end)))) + +(defun markdown-up-list () + "Move point to beginning of parent list item." + (interactive) + (let ((cur-bounds (markdown-cur-list-item-bounds))) + (when cur-bounds + (markdown-prev-list-item (1- (nth 3 cur-bounds))) + (let ((up-bounds (markdown-cur-list-item-bounds))) + (when (and up-bounds (< (nth 3 up-bounds) (nth 3 cur-bounds))) + (point)))))) + +(defun markdown-bounds-of-thing-at-point (thing) + "Call `bounds-of-thing-at-point' for THING with slight modifications. +Does not include trailing newlines when THING is \\='line. Handles the +end of buffer case by setting both endpoints equal to the value of +`point-max', since an empty region will trigger empty markup insertion. +Return bounds of form (beg . end) if THING is found, or nil otherwise." + (let* ((bounds (bounds-of-thing-at-point thing)) + (a (car bounds)) + (b (cdr bounds))) + (when bounds + (when (eq thing 'line) + (cond ((and (eobp) (markdown-cur-line-blank-p)) + (setq a b)) + ((char-equal (char-before b) ?\^J) + (setq b (1- b))))) + (cons a b)))) + +(defun markdown-reference-definition (reference) + "Find out whether Markdown REFERENCE is defined. +REFERENCE should not include the square brackets. +When REFERENCE is defined, return a list of the form (text start end) +containing the definition text itself followed by the start and end +locations of the text. Otherwise, return nil. +Leave match data for `markdown-regex-reference-definition' +intact additional processing." + (let ((reference (downcase reference))) + (save-excursion + (goto-char (point-min)) + (catch 'found + (while (re-search-forward markdown-regex-reference-definition nil t) + (when (string= reference (downcase (match-string-no-properties 2))) + (throw 'found + (list (match-string-no-properties 5) + (match-beginning 5) (match-end 5))))))))) + +(defun markdown-get-defined-references () + "Return all defined reference labels and their line numbers. +They does not include square brackets)." + (save-excursion + (goto-char (point-min)) + (let (refs) + (while (re-search-forward markdown-regex-reference-definition nil t) + (let ((target (match-string-no-properties 2))) + (cl-pushnew + (cons (downcase target) + (markdown-line-number-at-pos (match-beginning 2))) + refs :test #'equal :key #'car))) + (reverse refs)))) + +(defun markdown-get-used-uris () + "Return a list of all used URIs in the buffer." + (save-excursion + (goto-char (point-min)) + (let (uris) + (while (re-search-forward + (concat "\\(?:" markdown-regex-link-inline + "\\|" markdown-regex-angle-uri + "\\|" markdown-regex-uri + "\\|" markdown-regex-email + "\\)") + nil t) + (unless (or (markdown-inline-code-at-point-p) + (markdown-code-block-at-point-p)) + (cl-pushnew (or (match-string-no-properties 6) + (match-string-no-properties 10) + (match-string-no-properties 12) + (match-string-no-properties 13)) + uris :test #'equal))) + (reverse uris)))) + +(defun markdown-inline-code-at-pos (pos &optional from) + "Return non-nil if there is an inline code fragment at POS starting at FROM. +Uses the beginning of the block if FROM is nil. +Return nil otherwise. Set match data according to +`markdown-match-code' upon success. +This function searches the block for a code fragment that +contains the point using `markdown-match-code'. We do this +because `thing-at-point-looking-at' does not work reliably with +`markdown-regex-code'. + +The match data is set as follows: +Group 1 matches the opening backquotes. +Group 2 matches the code fragment itself, without backquotes. +Group 3 matches the closing backquotes." + (save-excursion + (goto-char pos) + (let ((old-point (point)) + (end-of-block (progn (markdown-end-of-text-block) (point))) + found) + (if from + (goto-char from) + (markdown-beginning-of-text-block)) + (while (and (markdown-match-code end-of-block) + (setq found t) + (< (match-end 0) old-point))) + (let ((match-group (if (eq (char-after (match-beginning 0)) ?`) 0 1))) + (and found ; matched something + (<= (match-beginning match-group) old-point) ; match contains old-point + (> (match-end 0) old-point)))))) + +(defun markdown-inline-code-at-pos-p (pos) + "Return non-nil if there is an inline code fragment at POS. +Like `markdown-inline-code-at-pos`, but preserves match data." + (save-match-data (markdown-inline-code-at-pos pos))) + +(defun markdown-inline-code-at-point () + "Return non-nil if the point is at an inline code fragment. +See `markdown-inline-code-at-pos' for details." + (markdown-inline-code-at-pos (point))) + +(defun markdown-inline-code-at-point-p (&optional pos) + "Return non-nil if there is inline code at the POS. +This is a predicate function counterpart to +`markdown-inline-code-at-point' which does not modify the match +data. See `markdown-code-block-at-point-p' for code blocks." + (save-match-data (markdown-inline-code-at-pos (or pos (point))))) + +(defun markdown-code-block-at-pos (pos) + "Return match data list if there is a code block at POS. +Uses text properties at the beginning of the line position. +This includes pre blocks, tilde-fenced code blocks, and GFM +quoted code blocks. Return nil otherwise." + (let ((bol (save-excursion (goto-char pos) (line-beginning-position)))) + (or (get-text-property bol 'markdown-pre) + (let* ((bounds (markdown-get-enclosing-fenced-block-construct pos)) + (second (cl-second bounds))) + (if second + ;; chunks are right open + (when (< pos second) + bounds) + bounds))))) + +;; Function was renamed to emphasize that it does not modify match-data. +(defalias 'markdown-code-block-at-point 'markdown-code-block-at-point-p) + +(defun markdown-code-block-at-point-p (&optional pos) + "Return non-nil if there is a code block at the POS. +This includes pre blocks, tilde-fenced code blocks, and GFM +quoted code blocks. This function does not modify the match +data. See `markdown-inline-code-at-point-p' for inline code." + (save-match-data (markdown-code-block-at-pos (or pos (point))))) + +(defun markdown-heading-at-point (&optional pos) + "Return non-nil if there is a heading at the POS. +Set match data for `markdown-regex-header'." + (let ((match-data (get-text-property (or pos (point)) 'markdown-heading))) + (when match-data + (set-match-data match-data) + t))) + +(defun markdown-pipe-at-bol-p () + "Return non-nil if the line begins with a pipe symbol. +This may be useful for tables and Pandoc's line_blocks extension." + (char-equal (char-after (line-beginning-position)) ?|)) + + +;;; Markdown Font Lock Matching Functions ===================================== + +(defun markdown-range-property-any (begin end prop prop-values) + "Return t if PROP from BEGIN to END is equal to one of the given PROP-VALUES. +Also returns t if PROP is a list containing one of the PROP-VALUES. +Return nil otherwise." + (let (props) + (catch 'found + (dolist (loc (number-sequence begin end)) + (when (setq props (get-text-property loc prop)) + (cond ((listp props) + ;; props is a list, check for membership + (dolist (val prop-values) + (when (memq val props) (throw 'found loc)))) + (t + ;; props is a scalar, check for equality + (dolist (val prop-values) + (when (eq val props) (throw 'found loc)))))))))) + +(defun markdown-range-properties-exist (begin end props) + (cl-loop + for loc in (number-sequence begin end) + with result = nil + while (not + (setq result + (cl-some (lambda (prop) (get-text-property loc prop)) props))) + finally return result)) + +(defun markdown-match-inline-generic (regex last &optional faceless) + "Match inline REGEX from the point to LAST. +When FACELESS is non-nil, do not return matches where faces have been applied." + (when (re-search-forward regex last t) + (let ((bounds (markdown-code-block-at-pos (match-beginning 1))) + (face (and faceless (text-property-not-all + (match-beginning 0) (match-end 0) 'face nil)))) + (cond + ;; In code block: move past it and recursively search again + (bounds + (when (< (goto-char (cl-second bounds)) last) + (markdown-match-inline-generic regex last faceless))) + ;; When faces are found in the match range, skip over the match and + ;; recursively search again. + (face + (when (< (goto-char (match-end 0)) last) + (markdown-match-inline-generic regex last faceless))) + ;; Keep match data and return t when in bounds. + (t + (<= (match-end 0) last)))))) + +(defun markdown-match-code (last) + "Match inline code fragments from point to LAST." + (unless (bobp) + (backward-char 1)) + (when (markdown-search-until-condition + (lambda () + (and + ;; Advance point in case of failure, but without exceeding last. + (goto-char (min (1+ (match-beginning 1)) last)) + (not (markdown-in-comment-p (match-beginning 1))) + (not (markdown-in-comment-p (match-end 1))) + (not (markdown-code-block-at-pos (match-beginning 1))))) + markdown-regex-code last t) + (set-match-data (list (match-beginning 1) (match-end 1) + (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) + (match-beginning 4) (match-end 4))) + (goto-char (min (1+ (match-end 0)) last (point-max))) + t)) + +(defun markdown--gfm-markup-underscore-p (begin end) + (let ((is-underscore (eql (char-after begin) ?_))) + (if (not is-underscore) + t + (save-excursion + (save-match-data + (goto-char begin) + (and (looking-back "\\(?:^\\|[[:blank:][:punct:]]\\)" (1- begin)) + (progn + (goto-char end) + (looking-at-p "\\(?:[[:blank:][:punct:]]\\|$\\)")))))))) + +(defun markdown-match-bold (last) + "Match inline bold from the point to LAST." + (let (done + retval + last-inline-code) + (while (not done) + (if (markdown-match-inline-generic markdown-regex-bold last) + (let ((is-gfm (derived-mode-p 'gfm-mode)) + (begin (match-beginning 2)) + (end (match-end 2))) + (if (or + (and last-inline-code + (>= begin (car last-inline-code)) + (< begin (cdr last-inline-code))) + (save-match-data + (when (markdown-inline-code-at-pos begin (cdr last-inline-code)) + (setq last-inline-code `(,(match-beginning 0) . ,(match-end 0))))) + (markdown-inline-code-at-pos-p end) + (markdown-in-comment-p) + (markdown-range-property-any + begin begin 'face '(markdown-url-face + markdown-plain-url-face)) + (markdown-range-property-any + begin end 'face '(markdown-hr-face + markdown-math-face)) + (and is-gfm (not (markdown--gfm-markup-underscore-p begin end)))) + (progn (goto-char (min (1+ begin) last)) + (unless (< (point) last) + (setq + done t))) + (set-match-data (list (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) + (match-beginning 4) (match-end 4) + (match-beginning 5) (match-end 5))) + (setq done t + retval t))) + (setq done t))) + retval)) + +(defun markdown-match-italic (last) + "Match inline italics from the point to LAST." + (let* ((is-gfm (derived-mode-p 'gfm-mode)) + (regex (if is-gfm + markdown-regex-gfm-italic + markdown-regex-italic))) + (let (done + retval + last-inline-code) + (while (not done) + (if (and (markdown-match-inline-generic regex last) + (not (markdown--face-p + (match-beginning 1) + '(markdown-html-attr-name-face markdown-html-attr-value-face)))) + (let ((begin (match-beginning 1)) + (end (match-end 1)) + (close-end (match-end 4))) + (if (or (eql (char-before begin) (char-after begin)) + (and last-inline-code + (>= begin (car last-inline-code)) + (< begin (cdr last-inline-code))) + (save-match-data + (when (markdown-inline-code-at-pos begin (cdr last-inline-code)) + (setq last-inline-code `(,(match-beginning 0) . ,(match-end 0))))) + + (markdown-inline-code-at-pos-p (1- end)) + (markdown-in-comment-p) + (markdown-range-property-any + begin begin 'face '(markdown-url-face + markdown-plain-url-face + markdown-markup-face)) + (markdown-range-property-any + begin end 'face '(markdown-bold-face + markdown-list-face + markdown-hr-face + markdown-math-face)) + (and is-gfm + (or (char-equal (char-after begin) (char-after (1+ begin))) ;; check bold case + (not (markdown--gfm-markup-underscore-p begin close-end))))) + (progn (goto-char (min (1+ begin) last)) + (unless (< (point) last) + (setq + done t))) + (set-match-data (list (match-beginning 1) (match-end 1) + (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) + (match-beginning 4) (match-end 4))) + (setq done t + retval t))) + (setq done t))) + retval))) + +(defun markdown--match-highlighting (last) + (when markdown-enable-highlighting-syntax + (re-search-forward markdown-regex-highlighting last t))) + +(defun markdown-match-escape (last) + "Match escape characters (backslashes) from point to LAST. +Backlashes only count as escape characters outside of literal +regions (e.g. code blocks). See `markdown-literal-faces'." + (catch 'found + (while (search-forward-regexp markdown-regex-escape last t) + (let* ((face (get-text-property (match-beginning 1) 'face)) + (face-list (if (listp face) face (list face)))) + ;; Ignore any backslashes with a literal face. + (unless (cl-intersection face-list markdown-literal-faces) + (throw 'found t)))))) + +(defun markdown-match-math-generic (regex last) + "Match REGEX from point to LAST. +REGEX is either `markdown-regex-math-inline-single' for matching +$..$ or `markdown-regex-math-inline-double' for matching $$..$$." + (when (markdown-match-inline-generic regex last) + (let ((begin (match-beginning 1)) (end (match-end 1))) + (prog1 + (if (or (markdown-range-property-any + begin end 'face + '(markdown-inline-code-face markdown-bold-face)) + (markdown-range-properties-exist + begin end + (markdown-get-fenced-block-middle-properties))) + (markdown-match-math-generic regex last) + t) + (goto-char (1+ (match-end 0))))))) + +(defun markdown-match-list-items (last) + "Match list items from point to LAST." + (let* ((first (point)) + (pos first) + (prop 'markdown-list-item) + (bounds (car (get-text-property pos prop)))) + (while + (and (or (null (setq bounds (car (get-text-property pos prop)))) + (< (cl-first bounds) pos)) + (< (point) last) + (setq pos (next-single-property-change pos prop nil last)) + (goto-char pos))) + (when bounds + (set-match-data (cl-seventh bounds)) + ;; Step at least one character beyond point. Otherwise + ;; `font-lock-fontify-keywords-region' infloops. + (goto-char (min (1+ (max (line-end-position) first)) + (point-max))) + t))) + +(defun markdown-match-math-single (last) + "Match single quoted $..$ math from point to LAST." + (when markdown-enable-math + (when (and (char-equal (char-after) ?$) + (not (bolp)) + (not (char-equal (char-before) ?\\)) + (not (char-equal (char-before) ?$))) + (forward-char -1)) + (markdown-match-math-generic markdown-regex-math-inline-single last))) + +(defun markdown-match-math-double (last) + "Match double quoted $$..$$ math from point to LAST." + (when markdown-enable-math + (when (and (< (1+ (point)) (point-max)) + (char-equal (char-after) ?$) + (char-equal (char-after (1+ (point))) ?$) + (not (bolp)) + (not (char-equal (char-before) ?\\)) + (not (char-equal (char-before) ?$))) + (forward-char -1)) + (markdown-match-math-generic markdown-regex-math-inline-double last))) + +(defun markdown-match-math-display (last) + "Match bracketed display math \[..\] and \\[..\\] from point to LAST." + (when markdown-enable-math + (markdown-match-math-generic markdown-regex-math-display last))) + +(defun markdown-match-propertized-text (property last) + "Match text with PROPERTY from point to LAST. +Restore match data previously stored in PROPERTY." + (let ((saved (get-text-property (point) property)) + pos) + (unless saved + (setq pos (next-single-property-change (point) property nil last)) + (unless (= pos last) + (setq saved (get-text-property pos property)))) + (when saved + (set-match-data saved) + ;; Step at least one character beyond point. Otherwise + ;; `font-lock-fontify-keywords-region' infloops. + (goto-char (min (1+ (max (match-end 0) (point))) + (point-max))) + saved))) + +(defun markdown-match-pre-blocks (last) + "Match preformatted blocks from point to LAST. +Use data stored in \\='markdown-pre text property during syntax +analysis." + (markdown-match-propertized-text 'markdown-pre last)) + +(defun markdown-match-gfm-code-blocks (last) + "Match GFM quoted code blocks from point to LAST. +Use data stored in \\='markdown-gfm-code text property during syntax +analysis." + (markdown-match-propertized-text 'markdown-gfm-code last)) + +(defun markdown-match-gfm-open-code-blocks (last) + (markdown-match-propertized-text 'markdown-gfm-block-begin last)) + +(defun markdown-match-gfm-close-code-blocks (last) + (markdown-match-propertized-text 'markdown-gfm-block-end last)) + +(defun markdown-match-fenced-code-blocks (last) + "Match fenced code blocks from the point to LAST." + (markdown-match-propertized-text 'markdown-fenced-code last)) + +(defun markdown-match-fenced-start-code-block (last) + (markdown-match-propertized-text 'markdown-tilde-fence-begin last)) + +(defun markdown-match-fenced-end-code-block (last) + (markdown-match-propertized-text 'markdown-tilde-fence-end last)) + +(defun markdown-match-blockquotes (last) + "Match blockquotes from point to LAST. +Use data stored in \\='markdown-blockquote text property during syntax +analysis." + (markdown-match-propertized-text 'markdown-blockquote last)) + +(defun markdown-match-hr (last) + "Match horizontal rules comments from the point to LAST." + (markdown-match-propertized-text 'markdown-hr last)) + +(defun markdown-match-comments (last) + "Match HTML comments from the point to LAST." + (when (and (skip-syntax-forward "^<" last)) + (let ((beg (point))) + (when (and (skip-syntax-forward "^>" last) (< (point) last)) + (forward-char) + (set-match-data (list beg (point))) + t)))) + +(defun markdown-match-generic-links (last ref) + "Match inline links from point to LAST. +When REF is non-nil, match reference links instead of standard +links with URLs. +This function should only be used during font-lock, as it +determines syntax based on the presence of faces for previously +processed elements." + ;; Search for the next potential link (not in a code block). + (let ((prohibited-faces '(markdown-pre-face + markdown-code-face + markdown-inline-code-face + markdown-comment-face)) + found) + (while + (and (not found) (< (point) last) + (progn + ;; Clear match data to test for a match after functions returns. + (set-match-data nil) + ;; Preliminary regular expression search so we can return + ;; quickly upon failure. This doesn't handle malformed links + ;; or nested square brackets well, so if it passes we back up + ;; continue with a more precise search. + (re-search-forward + (if ref + markdown-regex-link-reference + markdown-regex-link-inline) + last 'limit))) + ;; Keep searching if this is in a code block, inline code, or a + ;; comment, or if it is include syntax. The link text portion + ;; (group 3) may contain inline code or comments, but the + ;; markup, URL, and title should not be part of such elements. + (if (or (markdown-range-property-any + (match-beginning 0) (match-end 2) 'face prohibited-faces) + (markdown-range-property-any + (match-beginning 4) (match-end 0) 'face prohibited-faces) + (and (char-equal (char-after (line-beginning-position)) ?<) + (char-equal (char-after (1+ (line-beginning-position))) ?<))) + (set-match-data nil) + (setq found t)))) + ;; Match opening exclamation point (optional) and left bracket. + (when (match-beginning 2) + (let* ((bang (match-beginning 1)) + (first-begin (match-beginning 2)) + ;; Find end of block to prevent matching across blocks. + (end-of-block (save-excursion + (progn + (goto-char (match-beginning 2)) + (markdown-end-of-text-block) + (point)))) + ;; Move over balanced expressions to closing right bracket. + ;; Catch unbalanced expression errors and return nil. + (first-end (condition-case nil + (and (goto-char first-begin) + (scan-sexps (point) 1)) + (error nil))) + ;; Continue with point at CONT-POINT upon failure. + (cont-point (min (1+ first-begin) last)) + second-begin second-end url-begin url-end + title-begin title-end) + ;; When bracket found, in range, and followed by a left paren/bracket... + (when (and first-end (< first-end end-of-block) (goto-char first-end) + (char-equal (char-after (point)) (if ref ?\[ ?\())) + ;; Scan across balanced expressions for closing parenthesis/bracket. + (setq second-begin (point) + second-end (condition-case nil + (scan-sexps (point) 1) + (error nil))) + ;; Check that closing parenthesis/bracket is in range. + (if (and second-end (<= second-end end-of-block) (<= second-end last)) + (progn + ;; Search for (optional) title inside closing parenthesis + (when (and (not ref) (search-forward "\"" second-end t)) + (setq title-begin (1- (point)) + title-end (and (goto-char second-end) + (search-backward "\"" (1+ title-begin) t)) + title-end (and title-end (1+ title-end)))) + ;; Store URL/reference range + (setq url-begin (1+ second-begin) + url-end (1- (or title-begin second-end))) + ;; Set match data, move point beyond link, and return + (set-match-data + (list (or bang first-begin) second-end ; 0 - all + bang (and bang (1+ bang)) ; 1 - bang + first-begin (1+ first-begin) ; 2 - markup + (1+ first-begin) (1- first-end) ; 3 - link text + (1- first-end) first-end ; 4 - markup + second-begin (1+ second-begin) ; 5 - markup + url-begin url-end ; 6 - url/reference + title-begin title-end ; 7 - title + (1- second-end) second-end)) ; 8 - markup + ;; Nullify cont-point and leave point at end and + (setq cont-point nil) + (goto-char second-end)) + ;; If no closing parenthesis in range, update continuation point + (setq cont-point (min end-of-block second-begin)))) + (cond + ;; On failure, continue searching at cont-point + ((and cont-point (< cont-point last)) + (goto-char cont-point) + (markdown-match-generic-links last ref)) + ;; No more text, return nil + ((and cont-point (= cont-point last)) + nil) + ;; Return t if a match occurred + (t t))))) + +(defun markdown-match-angle-uris (last) + "Match angle bracket URIs from point to LAST." + (when (markdown-match-inline-generic markdown-regex-angle-uri last) + (goto-char (1+ (match-end 0))))) + +(defun markdown-match-plain-uris (last) + "Match plain URIs from point to LAST." + (when (markdown-match-inline-generic markdown-regex-uri last t) + (goto-char (1+ (match-end 0))))) + +(defvar markdown-conditional-search-function #'re-search-forward + "Conditional search function used in `markdown-search-until-condition'. +Made into a variable to allow for dynamic let-binding.") + +(defun markdown-search-until-condition (condition &rest args) + (let (ret) + (while (and (not ret) (apply markdown-conditional-search-function args)) + (setq ret (funcall condition))) + ret)) + +(defun markdown-metadata-line-p (pos regexp) + (save-excursion + (or (= (line-number-at-pos pos) 1) + (progn + (forward-line -1) + ;; skip multi-line metadata + (while (and (looking-at-p "^\\s-+[[:alpha:]]") + (> (line-number-at-pos (point)) 1)) + (forward-line -1)) + (looking-at-p regexp))))) + +(defun markdown-match-generic-metadata (regexp last) + "Match metadata declarations specified by REGEXP from point to LAST. +These declarations must appear inside a metadata block that begins at +the beginning of the buffer and ends with a blank line (or the end of +the buffer)." + (let* ((first (point)) + (end-re "\n[ \t]*\n\\|\n\\'\\|\\'") + (block-begin (goto-char 1)) + (block-end (re-search-forward end-re nil t))) + (if (and block-end (> first block-end)) + ;; Don't match declarations if there is no metadata block or if + ;; the point is beyond the block. Move point to point-max to + ;; prevent additional searches and return return nil since nothing + ;; was found. + (progn (goto-char (point-max)) nil) + ;; If a block was found that begins before LAST and ends after + ;; point, search for declarations inside it. If the starting is + ;; before the beginning of the block, start there. Otherwise, + ;; move back to FIRST. + (goto-char (if (< first block-begin) block-begin first)) + (if (and (re-search-forward regexp (min last block-end) t) + (markdown-metadata-line-p (point) regexp)) + ;; If a metadata declaration is found, set match-data and return t. + (let ((key-beginning (match-beginning 1)) + (key-end (match-end 1)) + (markup-begin (match-beginning 2)) + (markup-end (match-end 2)) + (value-beginning (match-beginning 3))) + (set-match-data (list key-beginning (point) ; complete metadata + key-beginning key-end ; key + markup-begin markup-end ; markup + value-beginning (point))) ; value + t) + ;; Otherwise, move the point to last and return nil + (goto-char last) + nil)))) + +(defun markdown-match-declarative-metadata (last) + "Match declarative metadata from the point to LAST." + (markdown-match-generic-metadata markdown-regex-declarative-metadata last)) + +(defun markdown-match-pandoc-metadata (last) + "Match Pandoc metadata from the point to LAST." + (markdown-match-generic-metadata markdown-regex-pandoc-metadata last)) + +(defun markdown-match-yaml-metadata-begin (last) + (markdown-match-propertized-text 'markdown-yaml-metadata-begin last)) + +(defun markdown-match-yaml-metadata-end (last) + (markdown-match-propertized-text 'markdown-yaml-metadata-end last)) + +(defun markdown-match-yaml-metadata-key (last) + (markdown-match-propertized-text 'markdown-metadata-key last)) + +(defun markdown-match-wiki-link (last) + "Match wiki links from point to LAST." + (when (and markdown-enable-wiki-links + (not markdown-wiki-link-fontify-missing) + (markdown-match-inline-generic markdown-regex-wiki-link last)) + (let ((begin (match-beginning 1)) (end (match-end 1))) + (if (or (markdown-in-comment-p begin) + (markdown-in-comment-p end) + (markdown-inline-code-at-pos-p begin) + (markdown-inline-code-at-pos-p end) + (markdown-code-block-at-pos begin)) + (progn (goto-char (min (1+ begin) last)) + (when (< (point) last) + (markdown-match-wiki-link last))) + (set-match-data (list begin end)) + t)))) + +(defun markdown-match-inline-attributes (last) + "Match inline attributes from point to LAST." + ;; #428 re-search-forward markdown-regex-inline-attributes is very slow. + ;; So use simple regex for re-search-forward and use markdown-regex-inline-attributes + ;; against matched string. + (when (markdown-match-inline-generic "[ \t]*\\({\\)\\([^\n]*\\)}[ \t]*$" last) + (if (not (string-match-p markdown-regex-inline-attributes (match-string 0))) + (markdown-match-inline-attributes last) + (unless (or (markdown-inline-code-at-pos-p (match-beginning 0)) + (markdown-inline-code-at-pos-p (match-end 0)) + (markdown-in-comment-p)) + t)))) + +(defun markdown-match-leanpub-sections (last) + "Match Leanpub section markers from point to LAST." + (when (markdown-match-inline-generic markdown-regex-leanpub-sections last) + (unless (or (markdown-inline-code-at-pos-p (match-beginning 0)) + (markdown-inline-code-at-pos-p (match-end 0)) + (markdown-in-comment-p)) + t))) + +(defun markdown-match-includes (last) + "Match include statements from point to LAST. +Sets match data for the following seven groups: +Group 1: opening two angle brackets +Group 2: opening title delimiter (optional) +Group 3: title text (optional) +Group 4: closing title delimiter (optional) +Group 5: opening filename delimiter +Group 6: filename +Group 7: closing filename delimiter" + (when (markdown-match-inline-generic markdown-regex-include last) + (let ((valid (not (or (markdown-in-comment-p (match-beginning 0)) + (markdown-in-comment-p (match-end 0)) + (markdown-code-block-at-pos (match-beginning 0)))))) + (cond + ;; Parentheses and maybe square brackets, but no curly braces: + ;; match optional title in square brackets and file in parentheses. + ((and valid (match-beginning 5) + (not (match-beginning 8))) + (set-match-data (list (match-beginning 1) (match-end 7) + (match-beginning 1) (match-end 1) + (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) + (match-beginning 4) (match-end 4) + (match-beginning 5) (match-end 5) + (match-beginning 6) (match-end 6) + (match-beginning 7) (match-end 7)))) + ;; Only square brackets present: match file in square brackets. + ((and valid (match-beginning 2) + (not (match-beginning 5)) + (not (match-beginning 7))) + (set-match-data (list (match-beginning 1) (match-end 4) + (match-beginning 1) (match-end 1) + nil nil + nil nil + nil nil + (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) + (match-beginning 4) (match-end 4)))) + ;; Only curly braces present: match file in curly braces. + ((and valid (match-beginning 8) + (not (match-beginning 2)) + (not (match-beginning 5))) + (set-match-data (list (match-beginning 1) (match-end 10) + (match-beginning 1) (match-end 1) + nil nil + nil nil + nil nil + (match-beginning 8) (match-end 8) + (match-beginning 9) (match-end 9) + (match-beginning 10) (match-end 10)))) + (t + ;; Not a valid match, move to next line and search again. + (forward-line) + (when (< (point) last) + (setq valid (markdown-match-includes last))))) + valid))) + +(defun markdown-match-html-tag (last) + "Match HTML tags from point to LAST." + (when (and markdown-enable-html + (markdown-match-inline-generic markdown-regex-html-tag last t)) + (set-match-data (list (match-beginning 0) (match-end 0) + (match-beginning 1) (match-end 1) + (match-beginning 2) (match-end 2) + (match-beginning 9) (match-end 9))) + t)) + + +;;; Markdown Font Fontification Functions ===================================== + +(defvar markdown--first-displayable-cache (make-hash-table :test #'equal)) + +(defun markdown--first-displayable (seq) + "Return the first displayable character or string in SEQ. +SEQ may be an atom or a sequence." + (let ((c (gethash seq markdown--first-displayable-cache t))) + (if (not (eq c t)) + c + (puthash seq + (let ((seq (if (listp seq) seq (list seq)))) + (cond ((stringp (car seq)) + (cl-find-if + (lambda (str) + (and (mapcar #'char-displayable-p (string-to-list str)))) + seq)) + ((characterp (car seq)) + (cl-find-if #'char-displayable-p seq)))) + markdown--first-displayable-cache)))) + +(defun markdown--marginalize-string (level) + "Generate atx markup string of given LEVEL for left margin." + (let ((margin-left-space-count + (- markdown-marginalize-headers-margin-width level))) + (concat (make-string margin-left-space-count ? ) + (make-string level ?#)))) + +(defun markdown-marginalize-update-current () + "Update the window configuration to create a left margin." + (if window-system + (let* ((header-delimiter-font-width + (window-font-width nil 'markdown-header-delimiter-face)) + (margin-pixel-width (* markdown-marginalize-headers-margin-width + header-delimiter-font-width)) + (margin-char-width (/ margin-pixel-width (default-font-width)))) + (set-window-margins nil margin-char-width)) + ;; As a fallback, simply set margin based on character count. + (set-window-margins nil (1+ markdown-marginalize-headers-margin-width)))) + +(defun markdown-fontify-headings (last) + "Add text properties to headings from point to LAST." + (when (markdown-match-propertized-text 'markdown-heading last) + (let* ((level (markdown-outline-level)) + (heading-face + (intern (format "markdown-header-face-%d" level))) + (heading-props `(face ,heading-face)) + (left-markup-props + `(face markdown-header-delimiter-face + ,@(cond + (markdown-hide-markup + `(display "")) + (markdown-marginalize-headers + `(display ((margin left-margin) + ,(markdown--marginalize-string level))))))) + (right-markup-props + `(face markdown-header-delimiter-face + ,@(when markdown-hide-markup `(display "")))) + (rule-props `(face markdown-header-rule-face + ,@(when markdown-hide-markup `(display ""))))) + (if (match-end 1) + ;; Setext heading + (progn (add-text-properties + (match-beginning 1) (match-end 1) heading-props) + (if (= level 1) + (add-text-properties + (match-beginning 2) (match-end 2) rule-props) + (add-text-properties + (match-beginning 3) (match-end 3) rule-props))) + ;; atx heading + (let ((fontified-start + (if (or markdown-hide-markup (not markdown-fontify-whole-heading-line)) + (match-beginning 5) + (match-beginning 0))) + (fontified-end + (if markdown-fontify-whole-heading-line + (min (point-max) (1+ (match-end 0))) + (match-end 5)))) + (add-text-properties + (match-beginning 4) (match-end 4) left-markup-props) + + ;; If closing tag is present + (if (match-end 6) + (progn + (add-text-properties fontified-start fontified-end heading-props) + (when (or markdown-hide-markup (not markdown-fontify-whole-heading-line)) + (add-text-properties (match-beginning 6) (match-end 6) right-markup-props))) + ;; If closing tag is not present + (add-text-properties fontified-start fontified-end heading-props))))) + t)) + +(defun markdown-fontify-tables (last) + (when (re-search-forward "|" last t) + (when (markdown-table-at-point-p) + (font-lock-append-text-property + (line-beginning-position) (min (1+ (line-end-position)) (point-max)) + 'face 'markdown-table-face)) + (forward-line 1) + t)) + +(defun markdown-fontify-blockquotes (last) + "Apply font-lock properties to blockquotes from point to LAST." + (when (markdown-match-blockquotes last) + (let ((display-string + (markdown--first-displayable markdown-blockquote-display-char))) + (add-text-properties + (match-beginning 1) (match-end 1) + (if markdown-hide-markup + `(face markdown-blockquote-face display ,display-string) + `(face markdown-markup-face))) + (font-lock-append-text-property + (match-beginning 0) (match-end 0) 'face 'markdown-blockquote-face) + t))) + +(defun markdown-fontify-list-items (last) + "Apply font-lock properties to list markers from point to LAST." + (when (markdown-match-list-items last) + (when (not (markdown-code-block-at-point-p (match-beginning 2))) + (let* ((indent (length (match-string-no-properties 1))) + (level (/ indent markdown-list-indent-width)) ;; level = 0, 1, 2, ... + (bullet (nth (mod level (length markdown-list-item-bullets)) + markdown-list-item-bullets))) + (add-text-properties + (match-beginning 2) (match-end 2) '(face markdown-list-face)) + (when markdown-hide-markup + (cond + ;; Unordered lists + ((string-match-p "[\\*\\+-]" (match-string 2)) + (add-text-properties + (match-beginning 2) (match-end 2) `(display ,bullet))) + ;; Definition lists + ((string-equal ":" (match-string 2)) + (let ((display-string + (char-to-string (markdown--first-displayable + markdown-definition-display-char)))) + (add-text-properties (match-beginning 2) (match-end 2) + `(display ,display-string)))))))) + t)) + +(defun markdown--fontify-hrs-view-mode (hr-char) + (if (and hr-char (display-supports-face-attributes-p '(:extend t))) + (add-text-properties + (match-beginning 0) (match-end 0) + `(face + (:inherit markdown-hr-face :underline t :extend t) + font-lock-multiline t + display "\n")) + (let ((hr-len (and hr-char (/ (1- (window-body-width)) (char-width hr-char))))) + (add-text-properties + (match-beginning 0) (match-end 0) + `(face + markdown-hr-face font-lock-multiline t + display ,(make-string hr-len hr-char)))))) + +(defun markdown-fontify-hrs (last) + "Add text properties to horizontal rules from point to LAST." + (when (markdown-match-hr last) + (let ((hr-char (markdown--first-displayable markdown-hr-display-char))) + (if (and markdown-hide-markup hr-char) + (markdown--fontify-hrs-view-mode hr-char) + (add-text-properties + (match-beginning 0) (match-end 0) + `(face markdown-hr-face font-lock-multiline t))) + t))) + +(defun markdown-fontify-sub-superscripts (last) + "Apply text properties to sub- and superscripts from point to LAST." + (when (markdown-search-until-condition + (lambda () (and (not (markdown-code-block-at-point-p)) + (not (markdown-inline-code-at-point-p)) + (not (markdown-in-comment-p)) + (not (markdown--math-block-p)))) + markdown-regex-sub-superscript last t) + (let* ((subscript-p (string= (match-string 2) "~")) + (props + (if subscript-p + (car markdown-sub-superscript-display) + (cdr markdown-sub-superscript-display))) + (mp (list 'face 'markdown-markup-face + 'invisible 'markdown-markup))) + (when markdown-hide-markup + (put-text-property (match-beginning 3) (match-end 3) + 'display props)) + (add-text-properties (match-beginning 2) (match-end 2) mp) + (add-text-properties (match-beginning 4) (match-end 4) mp) + t))) + + +;;; Syntax Table ============================================================== + +(defvar markdown-mode-syntax-table + (let ((tab (make-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?\" "." tab) + tab) + "Syntax table for `markdown-mode'.") + + +;;; Element Insertion ========================================================= + +(defun markdown-ensure-blank-line-before () + "If previous line is not already blank, insert a blank line before point." + (unless (bolp) (insert "\n")) + (unless (or (bobp) (looking-back "\n\\s-*\n" nil)) (insert "\n"))) + +(defun markdown-ensure-blank-line-after () + "If following line is not already blank, insert a blank line after point. +Return the point where it was originally." + (save-excursion + (unless (eolp) (insert "\n")) + (unless (or (eobp) (looking-at-p "\n\\s-*\n")) (insert "\n")))) + +(defun markdown-wrap-or-insert (s1 s2 &optional thing beg end) + "Insert the strings S1 and S2, wrapping around region or THING. +If a region is specified by the optional BEG and END arguments, +wrap the strings S1 and S2 around that region. +If there is an active region, wrap the strings S1 and S2 around +the region. If there is not an active region but the point is at +THING, wrap that thing (which defaults to word). Otherwise, just +insert S1 and S2 and place the point in between. Return the +bounds of the entire wrapped string, or nil if nothing was wrapped +and S1 and S2 were only inserted." + (let (a b bounds new-point) + (cond + ;; Given region + ((and beg end) + (setq a beg + b end + new-point (+ (point) (length s1)))) + ;; Active region + ((use-region-p) + (setq a (region-beginning) + b (region-end) + new-point (+ (point) (length s1)))) + ;; Thing (word) at point + ((setq bounds (markdown-bounds-of-thing-at-point (or thing 'word))) + (setq a (car bounds) + b (cdr bounds) + new-point (+ (point) (length s1)))) + ;; No active region and no word + (t + (setq a (point) + b (point)))) + (goto-char b) + (insert s2) + (goto-char a) + (insert s1) + (when new-point (goto-char new-point)) + (if (= a b) + nil + (setq b (+ b (length s1) (length s2))) + (cons a b)))) + +(defun markdown-point-after-unwrap (cur prefix suffix) + "Return desired position of point after an unwrapping operation. +CUR gives the position of the point before the operation. +Additionally, two cons cells must be provided. PREFIX gives the +bounds of the prefix string and SUFFIX gives the bounds of the +suffix string." + (cond ((< cur (cdr prefix)) (car prefix)) + ((< cur (car suffix)) (- cur (- (cdr prefix) (car prefix)))) + ((<= cur (cdr suffix)) + (- cur (+ (- (cdr prefix) (car prefix)) + (- cur (car suffix))))) + (t cur))) + +(defun markdown-unwrap-thing-at-point (regexp all text) + "Remove prefix and suffix of thing at point and reposition the point. +When the thing at point matches REGEXP, replace the subexpression +ALL with the string in subexpression TEXT. Reposition the point +in an appropriate location accounting for the removal of prefix +and suffix strings. Return new bounds of string from group TEXT. +When REGEXP is nil, assumes match data is already set." + (when (or (null regexp) + (thing-at-point-looking-at regexp)) + (let ((cur (point)) + (prefix (cons (match-beginning all) (match-beginning text))) + (suffix (cons (match-end text) (match-end all))) + (bounds (cons (match-beginning text) (match-end text)))) + ;; Replace the thing at point + (replace-match (match-string text) t t nil all) + ;; Reposition the point + (goto-char (markdown-point-after-unwrap cur prefix suffix)) + ;; Adjust bounds + (setq bounds (cons (car prefix) + (- (cdr bounds) (- (cdr prefix) (car prefix)))))))) + +(defun markdown-unwrap-things-in-region (beg end regexp all text) + "Remove prefix and suffix of all things in region from BEG to END. +When a thing in the region matches REGEXP, replace the +subexpression ALL with the string in subexpression TEXT. +Return a cons cell containing updated bounds for the region." + (save-excursion + (goto-char beg) + (let ((removed 0) len-all len-text) + (while (re-search-forward regexp (- end removed) t) + (setq len-all (length (match-string-no-properties all))) + (setq len-text (length (match-string-no-properties text))) + (setq removed (+ removed (- len-all len-text))) + (replace-match (match-string text) t t nil all)) + (cons beg (- end removed))))) + +(defun markdown-insert-hr (arg) + "Insert or replace a horizontal rule. +By default, use the first element of `markdown-hr-strings'. When +ARG is non-nil, as when given a prefix, select a different +element as follows. When prefixed with \\[universal-argument], +use the last element of `markdown-hr-strings' instead. When +prefixed with an integer from 1 to the length of +`markdown-hr-strings', use the element in that position instead." + (interactive "*P") + (when (thing-at-point-looking-at markdown-regex-hr) + (delete-region (match-beginning 0) (match-end 0))) + (markdown-ensure-blank-line-before) + (cond ((equal arg '(4)) + (insert (car (reverse markdown-hr-strings)))) + ((and (integerp arg) (> arg 0) + (<= arg (length markdown-hr-strings))) + (insert (nth (1- arg) markdown-hr-strings))) + (t + (insert (car markdown-hr-strings)))) + (markdown-ensure-blank-line-after)) + +(defun markdown--insert-common (start-delim end-delim regex start-group end-group face + &optional skip-space) + (if (use-region-p) + ;; Active region + (let* ((bounds (markdown-unwrap-things-in-region + (region-beginning) (region-end) + regex start-group end-group)) + (beg (car bounds)) + (end (cdr bounds))) + (when (and beg skip-space) + (save-excursion + (goto-char beg) + (skip-chars-forward " \t") + (setq beg (point)))) + (when (and end skip-space) + (save-excursion + (goto-char end) + (skip-chars-backward " \t") + (setq end (point)))) + (markdown-wrap-or-insert start-delim end-delim nil beg end)) + (if (markdown--face-p (point) (list face)) + (save-excursion + (while (and (markdown--face-p (point) (list face)) (not (bobp))) + (forward-char -1)) + (forward-char (- (1- (length start-delim)))) ;; for delimiter + (unless (bolp) + (forward-char -1)) + (when (looking-at regex) + (markdown-unwrap-thing-at-point nil start-group end-group))) + (if (thing-at-point-looking-at regex) + (markdown-unwrap-thing-at-point nil start-group end-group) + (markdown-wrap-or-insert start-delim end-delim 'word nil nil))))) + +(defun markdown-insert-bold () + "Insert markup to make a region or word bold. +If there is an active region, make the region bold. If the point +is at a non-bold word, make the word bold. If the point is at a +bold word or phrase, remove the bold markup. Otherwise, simply +insert bold delimiters and place the point in between them." + (interactive) + (let ((delim (if markdown-bold-underscore "__" "**"))) + (markdown--insert-common delim delim markdown-regex-bold 2 4 'markdown-bold-face t))) + +(defun markdown-insert-italic () + "Insert markup to make a region or word italic. +If there is an active region, make the region italic. If the point +is at a non-italic word, make the word italic. If the point is at an +italic word or phrase, remove the italic markup. Otherwise, simply +insert italic delimiters and place the point in between them." + (interactive) + (let ((delim (if markdown-italic-underscore "_" "*"))) + (markdown--insert-common delim delim markdown-regex-italic 1 3 'markdown-italic-face t))) + +(defun markdown-insert-strike-through () + "Insert markup to make a region or word strikethrough. +If there is an active region, make the region strikethrough. If the point +is at a non-bold word, make the word strikethrough. If the point is at a +strikethrough word or phrase, remove the strikethrough markup. Otherwise, +simply insert bold delimiters and place the point in between them." + (interactive) + (markdown--insert-common + "~~" "~~" markdown-regex-strike-through 2 4 'markdown-strike-through-face t)) + +(defun markdown-insert-code () + "Insert markup to make a region or word an inline code fragment. +If there is an active region, make the region an inline code +fragment. If the point is at a word, make the word an inline +code fragment. Otherwise, simply insert code delimiters and +place the point in between them." + (interactive) + (if (use-region-p) + ;; Active region + (let ((bounds (markdown-unwrap-things-in-region + (region-beginning) (region-end) + markdown-regex-code 1 3))) + (markdown-wrap-or-insert "`" "`" nil (car bounds) (cdr bounds))) + ;; Code markup removal, code markup for word, or empty markup insertion + (if (markdown-inline-code-at-point) + (markdown-unwrap-thing-at-point nil 0 2) + (markdown-wrap-or-insert "`" "`" 'word nil nil)))) + +(defun markdown-insert-kbd () + "Insert markup to wrap region or word in <kbd> tags. +If there is an active region, use the region. If the point is at +a word, use the word. Otherwise, simply insert <kbd> tags and +place the point in between them." + (interactive) + (if (use-region-p) + ;; Active region + (let ((bounds (markdown-unwrap-things-in-region + (region-beginning) (region-end) + markdown-regex-kbd 0 2))) + (markdown-wrap-or-insert "<kbd>" "</kbd>" nil (car bounds) (cdr bounds))) + ;; Markup removal, markup for word, or empty markup insertion + (if (thing-at-point-looking-at markdown-regex-kbd) + (markdown-unwrap-thing-at-point nil 0 2) + (markdown-wrap-or-insert "<kbd>" "</kbd>" 'word nil nil)))) + +(defun markdown-insert-inline-link (text url &optional title) + "Insert an inline link with TEXT pointing to URL. +Optionally, the user can provide a TITLE." + (let ((cur (point))) + (setq title (and title (concat " \"" title "\""))) + (insert (concat "[" text "](" url title ")")) + (cond ((not text) (goto-char (+ 1 cur))) + ((not url) (goto-char (+ 3 (length text) cur)))))) + +(defun markdown-insert-inline-image (text url &optional title) + "Insert an inline link with alt TEXT pointing to URL. +Optionally, also provide a TITLE." + (let ((cur (point))) + (setq title (and title (concat " \"" title "\""))) + (insert (concat "![" text "](" url title ")")) + (cond ((not text) (goto-char (+ 2 cur))) + ((not url) (goto-char (+ 4 (length text) cur)))))) + +(defun markdown-insert-reference-link (text label &optional url title) + "Insert a reference link and, optionally, a reference definition. +The link TEXT will be inserted followed by the optional LABEL. +If a URL is given, also insert a definition for the reference +LABEL according to `markdown-reference-location'. If a TITLE is +given, it will be added to the end of the reference definition +and will be used to populate the title attribute when converted +to XHTML. If URL is nil, insert only the link portion (for +example, when a reference label is already defined)." + (insert (concat "[" text "][" label "]")) + (when url + (markdown-insert-reference-definition + (if (string-equal label "") text label) + url title))) + +(defun markdown-insert-reference-image (text label &optional url title) + "Insert a reference image and, optionally, a reference definition. +The alt TEXT will be inserted followed by the optional LABEL. +If a URL is given, also insert a definition for the reference +LABEL according to `markdown-reference-location'. If a TITLE is +given, it will be added to the end of the reference definition +and will be used to populate the title attribute when converted +to XHTML. If URL is nil, insert only the link portion (for +example, when a reference label is already defined)." + (insert (concat "![" text "][" label "]")) + (when url + (markdown-insert-reference-definition + (if (string-equal label "") text label) + url title))) + +(defun markdown-insert-reference-definition (label &optional url title) + "Add definition for reference LABEL with URL and TITLE. +LABEL is a Markdown reference label without square brackets. +URL and TITLE are optional. When given, the TITLE will +be used to populate the title attribute when converted to XHTML." + ;; END specifies where to leave the point upon return + (let ((end (point))) + (cl-case markdown-reference-location + (end (goto-char (point-max))) + (immediately (markdown-end-of-text-block)) + (subtree (markdown-end-of-subtree)) + (header (markdown-end-of-defun))) + ;; Skip backwards over local variables. This logic is similar to the one + ;; used in ‘hack-local-variables’. + (when (and enable-local-variables (eobp)) + (search-backward "\n\f" (max (- (point) 3000) (point-min)) :move) + (when (let ((case-fold-search t)) + (search-forward "Local Variables:" nil :move)) + (beginning-of-line 0) + (when (eq (char-before) ?\n) (backward-char)))) + (unless (or (markdown-cur-line-blank-p) + (thing-at-point-looking-at markdown-regex-reference-definition)) + (insert "\n")) + (insert "\n[" label "]: ") + (if url + (insert url) + ;; When no URL is given, leave point at END following the colon + (setq end (point))) + (when (> (length title) 0) + (insert " \"" title "\"")) + (unless (looking-at-p "\n") + (insert "\n")) + (goto-char end) + (when url + (message + (markdown--substitute-command-keys + "Reference [%s] was defined, press \\[markdown-do] to jump there") + label)))) + +(defcustom markdown-link-make-text-function nil + "Function that automatically generates a link text for a URL. + +If non-nil, this function will be called by +`markdown--insert-link-or-image' and the result will be the +default link text. The function should receive exactly one +argument that corresponds to the link URL." + :group 'markdown + :type 'function + :package-version '(markdown-mode . "2.5")) + +(defcustom markdown-disable-tooltip-prompt nil + "Disable prompt for tooltip when inserting a link or image. + +If non-nil, `markdown-insert-link' and `markdown-insert-link' +will not prompt the user to insert a tooltip text for the given +link or image." + :group 'markdown + :type 'boolean + :safe 'booleanp + :package-version '(markdown-mode . "2.5")) + +(defun markdown--insert-link-or-image (image) + "Interactively insert new or update an existing link or image. +When IMAGE is non-nil, insert an image. Otherwise, insert a link. +This is an internal function called by +`markdown-insert-link' and `markdown-insert-image'." + (cl-multiple-value-bind (begin end text uri ref title) + (if (use-region-p) + ;; Use region as either link text or URL as appropriate. + (let ((region (buffer-substring-no-properties + (region-beginning) (region-end)))) + (if (string-match markdown-regex-uri region) + ;; Region contains a URL; use it as such. + (list (region-beginning) (region-end) + nil (match-string 0 region) nil nil) + ;; Region doesn't contain a URL, so use it as text. + (list (region-beginning) (region-end) + region nil nil nil))) + ;; Extract and use properties of existing link, if any. + (markdown-link-at-pos (point))) + (let* ((ref (when ref (concat "[" ref "]"))) + (defined-refs (mapcar #'car (markdown-get-defined-references))) + (defined-ref-cands (mapcar (lambda (ref) (concat "[" ref "]")) defined-refs)) + (used-uris (markdown-get-used-uris)) + (uri-or-ref (completing-read + "URL or [reference]: " + (append defined-ref-cands used-uris) + nil nil (or uri ref))) + (ref (cond ((string-match "\\`\\[\\(.*\\)\\]\\'" uri-or-ref) + (match-string 1 uri-or-ref)) + ((string-equal "" uri-or-ref) + ""))) + (uri (unless ref uri-or-ref)) + (text-prompt (if image + "Alt text: " + (if ref + "Link text: " + "Link text (blank for plain URL): "))) + (text (or text (and markdown-link-make-text-function uri + (funcall markdown-link-make-text-function uri)))) + (text (completing-read text-prompt defined-refs nil nil text)) + (text (if (= (length text) 0) nil text)) + (plainp (and uri (not text))) + (implicitp (string-equal ref "")) + (ref (if implicitp text ref)) + (definedp (and ref (markdown-reference-definition ref))) + (ref-url (unless (or uri definedp) + (completing-read "Reference URL: " used-uris))) + (title (unless (or plainp definedp markdown-disable-tooltip-prompt) + (read-string "Title (tooltip text, optional): " title))) + (title (if (= (length title) 0) nil title))) + (when (and image implicitp) + (user-error "Reference required: implicit image references are invalid")) + (when (and begin end) + (delete-region begin end)) + (cond + ((and (not image) uri text) + (markdown-insert-inline-link text uri title)) + ((and image uri text) + (markdown-insert-inline-image text uri title)) + ((and ref text) + (if image + (markdown-insert-reference-image text (unless implicitp ref) nil title) + (markdown-insert-reference-link text (unless implicitp ref) nil title)) + (unless definedp + (markdown-insert-reference-definition ref ref-url title))) + ((and (not image) uri) + (markdown-insert-uri uri)))))) + +(defun markdown-insert-link () + "Insert new or update an existing link, with interactive prompt. +If the point is at an existing link or URL, update the link text, +URL, reference label, and/or title. Otherwise, insert a new link. +The type of link inserted (inline, reference, or plain URL) +depends on which values are provided: + +* If a URL and TEXT are given, insert an inline link: [TEXT](URL). +* If [REF] and TEXT are given, insert a reference link: [TEXT][REF]. +* If only TEXT is given, insert an implicit reference link: [TEXT][]. +* If only a URL is given, insert a plain link: <URL>. + +In other words, to create an implicit reference link, leave the +URL prompt empty and to create a plain URL link, leave the link +text empty. + +If there is an active region, use the text as the default URL, if +it seems to be a URL, or link text value otherwise. + +If a given reference is not defined, this function will +additionally prompt for the URL and optional title. In this case, +the reference definition is placed at the location determined by +`markdown-reference-location'. In addition, it is possible to +have the `markdown-link-make-text-function' function, if non-nil, +define the default link text before prompting the user for it. + +If `markdown-disable-tooltip-prompt' is non-nil, the user will +not be prompted to add or modify a tooltip text. + +Through updating the link, this function can be used to convert a +link of one type (inline, reference, or plain) to another type by +selectively adding or removing information via the prompts." + (interactive) + (markdown--insert-link-or-image nil)) + +(defun markdown-insert-image () + "Insert new or update an existing image, with interactive prompt. +If the point is at an existing image, update the alt text, URL, +reference label, and/or title. Otherwise, insert a new image. +The type of image inserted (inline or reference) depends on which +values are provided: + +* If a URL and ALT-TEXT are given, insert an inline image: + . +* If [REF] and ALT-TEXT are given, insert a reference image: + ![ALT-TEXT][REF]. + +If there is an active region, use the text as the default URL, if +it seems to be a URL, or alt text value otherwise. + +If a given reference is not defined, this function will +additionally prompt for the URL and optional title. In this case, +the reference definition is placed at the location determined by +`markdown-reference-location'. + +Through updating the image, this function can be used to convert an +image of one type (inline or reference) to another type by +selectively adding or removing information via the prompts." + (interactive) + (markdown--insert-link-or-image t)) + +(defun markdown-insert-uri (&optional uri) + "Insert markup for an inline URI. +If there is an active region, use it as the URI. If the point is +at a URI, wrap it with angle brackets. If the point is at an +inline URI, remove the angle brackets. Otherwise, simply insert +angle brackets place the point between them." + (interactive) + (if (use-region-p) + ;; Active region + (let ((bounds (markdown-unwrap-things-in-region + (region-beginning) (region-end) + markdown-regex-angle-uri 0 2))) + (markdown-wrap-or-insert "<" ">" nil (car bounds) (cdr bounds))) + ;; Markup removal, URI at point, new URI, or empty markup insertion + (if (thing-at-point-looking-at markdown-regex-angle-uri) + (markdown-unwrap-thing-at-point nil 0 2) + (if uri + (insert "<" uri ">") + (markdown-wrap-or-insert "<" ">" 'url nil nil))))) + +(defun markdown-insert-wiki-link () + "Insert a wiki link of the form [[WikiLink]]. +If there is an active region, use the region as the link text. +If the point is at a word, use the word as the link text. If +there is no active region and the point is not at word, simply +insert link markup." + (interactive) + (if (use-region-p) + ;; Active region + (markdown-wrap-or-insert "[[" "]]" nil (region-beginning) (region-end)) + ;; Markup removal, wiki link at at point, or empty markup insertion + (if (thing-at-point-looking-at markdown-regex-wiki-link) + (if (or markdown-wiki-link-alias-first + (null (match-string 5))) + (markdown-unwrap-thing-at-point nil 1 3) + (markdown-unwrap-thing-at-point nil 1 5)) + (markdown-wrap-or-insert "[[" "]]")))) + +(defun markdown-remove-header () + "Remove header markup if point is at a header. +Return bounds of remaining header text if a header was removed +and nil otherwise." + (interactive "*") + (or (markdown-unwrap-thing-at-point markdown-regex-header-atx 0 2) + (markdown-unwrap-thing-at-point markdown-regex-header-setext 0 1))) + +(defun markdown-insert-header (&optional level text setext) + "Insert or replace header markup. +The level of the header is specified by LEVEL and header text is +given by TEXT. LEVEL must be an integer from 1 and 6, and the +default value is 1. +When TEXT is nil, the header text is obtained as follows. +If there is an active region, it is used as the header text. +Otherwise, the current line will be used as the header text. +If there is not an active region and the point is at a header, +remove the header markup and replace with level N header. +Otherwise, insert empty header markup and place the point in +between. +The style of the header will be atx (hash marks) unless +SETEXT is non-nil, in which case a setext-style (underlined) +header will be inserted." + (interactive "p\nsHeader text: ") + (setq level (min (max (or level 1) 1) (if setext 2 6))) + ;; Determine header text if not given + (when (null text) + (if (use-region-p) + ;; Active region + (setq text (delete-and-extract-region (region-beginning) (region-end))) + ;; No active region + (markdown-remove-header) + (setq text (delete-and-extract-region + (line-beginning-position) (line-end-position))) + (when (and setext (string-match-p "^[ \t]*$" text)) + (setq text (read-string "Header text: ")))) + (setq text (markdown-compress-whitespace-string text))) + ;; Insertion with given text + (markdown-ensure-blank-line-before) + (let (hdr) + (cond (setext + (setq hdr (make-string (string-width text) (if (= level 2) ?- ?=))) + (insert text "\n" hdr)) + (t + (setq hdr (make-string level ?#)) + (insert hdr " " text) + (when (null markdown-asymmetric-header) (insert " " hdr))))) + (markdown-ensure-blank-line-after) + ;; Leave point at end of text + (cond (setext + (backward-char (1+ (string-width text)))) + ((null markdown-asymmetric-header) + (backward-char (1+ level))))) + +(defun markdown-insert-header-dwim (&optional arg setext) + "Insert or replace header markup. +The level and type of the header are determined automatically by +the type and level of the previous header, unless a prefix +argument is given via ARG. +With a numeric prefix valued 1 to 6, insert a header of the given +level, with the type being determined automatically (note that +only level 1 or 2 setext headers are possible). + +With a \\[universal-argument] prefix (i.e., when ARG is (4)), +promote the heading by one level. +With two \\[universal-argument] prefixes (i.e., when ARG is (16)), +demote the heading by one level. +When SETEXT is non-nil, prefer setext-style headers when +possible (levels one and two). + +When there is an active region, use it for the header text. When +the point is at an existing header, change the type and level +according to the rules above. +Otherwise, if the line is not empty, create a header using the +text on the current line as the header text. +Finally, if the point is on a blank line, insert empty header +markup (atx) or prompt for text (setext). +See `markdown-insert-header' for more details about how the +header text is determined." + (interactive "*P") + (let (level) + (save-excursion + (when (or (thing-at-point-looking-at markdown-regex-header) + (re-search-backward markdown-regex-header nil t)) + ;; level of current or previous header + (setq level (markdown-outline-level)) + ;; match group 1 indicates a setext header + (setq setext (match-end 1)))) + ;; check prefix argument + (cond + ((and (equal arg '(4)) level (> level 1)) ;; C-u + (cl-decf level)) + ((and (equal arg '(16)) level (< level 6)) ;; C-u C-u + (cl-incf level)) + (arg ;; numeric prefix + (setq level (prefix-numeric-value arg)))) + ;; setext headers must be level one or two + (and level (setq setext (and setext (<= level 2)))) + ;; insert the heading + (markdown-insert-header level nil setext))) + +(defun markdown-insert-header-setext-dwim (&optional arg) + "Insert or replace header markup, with preference for setext. +See `markdown-insert-header-dwim' for details, including how ARG is handled." + (interactive "*P") + (markdown-insert-header-dwim arg t)) + +(defun markdown-insert-header-atx-1 () + "Insert a first level atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 1 nil nil)) + +(defun markdown-insert-header-atx-2 () + "Insert a level two atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 2 nil nil)) + +(defun markdown-insert-header-atx-3 () + "Insert a level three atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 3 nil nil)) + +(defun markdown-insert-header-atx-4 () + "Insert a level four atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 4 nil nil)) + +(defun markdown-insert-header-atx-5 () + "Insert a level five atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 5 nil nil)) + +(defun markdown-insert-header-atx-6 () + "Insert a sixth level atx-style (hash mark) header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 6 nil nil)) + +(defun markdown-insert-header-setext-1 () + "Insert a setext-style (underlined) first-level header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 1 nil t)) + +(defun markdown-insert-header-setext-2 () + "Insert a setext-style (underlined) second-level header. +See `markdown-insert-header'." + (interactive "*") + (markdown-insert-header 2 nil t)) + +(defun markdown-blockquote-indentation (loc) + "Return string containing necessary indentation for a blockquote at LOC. +Also see `markdown-pre-indentation'." + (save-excursion + (goto-char loc) + (let* ((list-level (length (markdown-calculate-list-levels))) + (indent "")) + (dotimes (_ list-level indent) + (setq indent (concat indent " ")))))) + +(defun markdown-insert-blockquote () + "Start a blockquote section (or blockquote the region). +If Transient Mark mode is on and a region is active, it is used as +the blockquote text." + (interactive) + (if (use-region-p) + (markdown-blockquote-region (region-beginning) (region-end)) + (markdown-ensure-blank-line-before) + (insert (markdown-blockquote-indentation (point)) "> ") + (markdown-ensure-blank-line-after))) + +(defun markdown-block-region (beg end prefix) + "Format the region using a block prefix. +Arguments BEG and END specify the beginning and end of the +region. The characters PREFIX will appear at the beginning +of each line." + (save-excursion + (let* ((end-marker (make-marker)) + (beg-marker (make-marker)) + (prefix-without-trailing-whitespace + (replace-regexp-in-string (rx (+ blank) eos) "" prefix))) + ;; Ensure blank line after and remove extra whitespace + (goto-char end) + (skip-syntax-backward "-") + (set-marker end-marker (point)) + (delete-horizontal-space) + (markdown-ensure-blank-line-after) + ;; Ensure blank line before and remove extra whitespace + (goto-char beg) + (skip-syntax-forward "-") + (delete-horizontal-space) + (markdown-ensure-blank-line-before) + (set-marker beg-marker (point)) + ;; Insert PREFIX before each line + (goto-char beg-marker) + (while (and (< (line-beginning-position) end-marker) + (not (eobp))) + ;; Don’t insert trailing whitespace. + (insert (if (eolp) prefix-without-trailing-whitespace prefix)) + (forward-line))))) + +(defun markdown-blockquote-region (beg end) + "Blockquote the region. +Arguments BEG and END specify the beginning and end of the region." + (interactive "*r") + (markdown-block-region + beg end (concat (markdown-blockquote-indentation + (max (point-min) (1- beg))) "> "))) + +(defun markdown-pre-indentation (loc) + "Return string containing necessary whitespace for a pre block at LOC. +Also see `markdown-blockquote-indentation'." + (save-excursion + (goto-char loc) + (let* ((list-level (length (markdown-calculate-list-levels))) + indent) + (dotimes (_ (1+ list-level) indent) + (setq indent (concat indent " ")))))) + +(defun markdown-insert-pre () + "Start a preformatted section (or apply to the region). +If Transient Mark mode is on and a region is active, it is marked +as preformatted text." + (interactive) + (if (use-region-p) + (markdown-pre-region (region-beginning) (region-end)) + (markdown-ensure-blank-line-before) + (insert (markdown-pre-indentation (point))) + (markdown-ensure-blank-line-after))) + +(defun markdown-pre-region (beg end) + "Format the region as preformatted text. +Arguments BEG and END specify the beginning and end of the region." + (interactive "*r") + (let ((indent (markdown-pre-indentation (max (point-min) (1- beg))))) + (markdown-block-region beg end indent))) + +(defun markdown-electric-backquote (arg) + "Insert a backquote. +The numeric prefix argument ARG says how many times to repeat the insertion. +Call `markdown-insert-gfm-code-block' interactively +if three backquotes inserted at the beginning of line." + (interactive "*P") + (self-insert-command (prefix-numeric-value arg)) + (when (and markdown-gfm-use-electric-backquote (looking-back "^```" nil)) + (replace-match "") + (call-interactively #'markdown-insert-gfm-code-block))) + +(defconst markdown-gfm-recognized-languages + ;; To reproduce/update, evaluate the let-form in + ;; scripts/get-recognized-gfm-languages.el. that produces a single long sexp, + ;; but with appropriate use of a keyboard macro, indenting and filling it + ;; properly is pretty fast. + '("1C-Enterprise" "2-Dimensional-Array" "4D" "ABAP" "ABAP-CDS" "ABNF" + "AGS-Script" "AIDL" "AL" "AMPL" "ANTLR" "API-Blueprint" "APL" "ASL" + "ASN.1" "ASP.NET" "ATS" "ActionScript" "Ada" "Adblock-Filter-List" + "Adobe-Font-Metrics" "Agda" "Alloy" "Alpine-Abuild" "Altium-Designer" + "AngelScript" "Ant-Build-System" "Antlers" "ApacheConf" "Apex" + "Apollo-Guidance-Computer" "AppleScript" "Arc" "AsciiDoc" "AspectJ" + "Assembly" "Astro" "Asymptote" "Augeas" "AutoHotkey" "AutoIt" + "Avro-IDL" "Awk" "BASIC" "Ballerina" "Batchfile" "Beef" "Befunge" + "Berry" "BibTeX" "Bicep" "Bikeshed" "Bison" "BitBake" "Blade" + "BlitzBasic" "BlitzMax" "Bluespec" "Bluespec-BH" "Boo" "Boogie" + "Brainfuck" "BrighterScript" "Brightscript" "Browserslist" "C" "C#" + "C++" "C-ObjDump" "C2hs-Haskell" "CAP-CDS" "CIL" "CLIPS" "CMake" + "COBOL" "CODEOWNERS" "COLLADA" "CSON" "CSS" "CSV" "CUE" "CWeb" + "Cabal-Config" "Cadence" "Cairo" "CameLIGO" "Cap'n-Proto" "CartoCSS" + "Ceylon" "Chapel" "Charity" "Checksums" "ChucK" "Circom" "Cirru" + "Clarion" "Clarity" "Classic-ASP" "Clean" "Click" "Clojure" + "Closure-Templates" "Cloud-Firestore-Security-Rules" "CoNLL-U" + "CodeQL" "CoffeeScript" "ColdFusion" "ColdFusion-CFC" "Common-Lisp" + "Common-Workflow-Language" "Component-Pascal" "Cool" "Coq" + "Cpp-ObjDump" "Creole" "Crystal" "Csound" "Csound-Document" + "Csound-Score" "Cuda" "Cue-Sheet" "Curry" "Cycript" "Cypher" "Cython" + "D" "D-ObjDump" "D2" "DIGITAL-Command-Language" "DM" "DNS-Zone" + "DTrace" "Dafny" "Darcs-Patch" "Dart" "DataWeave" + "Debian-Package-Control-File" "DenizenScript" "Dhall" "Diff" + "DirectX-3D-File" "Dockerfile" "Dogescript" "Dotenv" "Dylan" "E" + "E-mail" "EBNF" "ECL" "ECLiPSe" "EJS" "EQ" "Eagle" "Earthly" + "Easybuild" "Ecere-Projects" "Ecmarkup" "Edge" "EdgeQL" + "EditorConfig" "Edje-Data-Collection" "Eiffel" "Elixir" "Elm" + "Elvish" "Elvish-Transcript" "Emacs-Lisp" "EmberScript" "Erlang" + "Euphoria" "F#" "F*" "FIGlet-Font" "FLUX" "Factor" "Fancy" "Fantom" + "Faust" "Fennel" "Filebench-WML" "Filterscript" "Fluent" "Formatted" + "Forth" "Fortran" "Fortran-Free-Form" "FreeBasic" "FreeMarker" + "Frege" "Futhark" "G-code" "GAML" "GAMS" "GAP" + "GCC-Machine-Description" "GDB" "GDScript" "GEDCOM" "GLSL" "GN" "GSC" + "Game-Maker-Language" "Gemfile.lock" "Gemini" "Genero-4gl" + "Genero-per" "Genie" "Genshi" "Gentoo-Ebuild" "Gentoo-Eclass" + "Gerber-Image" "Gettext-Catalog" "Gherkin" "Git-Attributes" + "Git-Config" "Git-Revision-List" "Gleam" "Glimmer-JS" "Glimmer-TS" + "Glyph" "Glyph-Bitmap-Distribution-Format" "Gnuplot" "Go" + "Go-Checksums" "Go-Module" "Go-Workspace" "Godot-Resource" "Golo" + "Gosu" "Grace" "Gradle" "Gradle-Kotlin-DSL" "Grammatical-Framework" + "Graph-Modeling-Language" "GraphQL" "Graphviz-(DOT)" "Groovy" + "Groovy-Server-Pages" "HAProxy" "HCL" "HLSL" "HOCON" "HTML" + "HTML+ECR" "HTML+EEX" "HTML+ERB" "HTML+PHP" "HTML+Razor" "HTTP" + "HXML" "Hack" "Haml" "Handlebars" "Harbour" "Haskell" "Haxe" "HiveQL" + "HolyC" "Hosts-File" "Hy" "HyPhy" "IDL" "IGOR-Pro" "INI" "IRC-log" + "Idris" "Ignore-List" "ImageJ-Macro" "Imba" "Inform-7" "Ink" + "Inno-Setup" "Io" "Ioke" "Isabelle" "Isabelle-ROOT" "J" + "JAR-Manifest" "JCL" "JFlex" "JSON" "JSON-with-Comments" "JSON5" + "JSONLD" "JSONiq" "Janet" "Jasmin" "Java" "Java-Properties" + "Java-Server-Pages" "JavaScript" "JavaScript+ERB" "Jest-Snapshot" + "JetBrains-MPS" "Jinja" "Jison" "Jison-Lex" "Jolie" "Jsonnet" "Julia" + "Jupyter-Notebook" "Just" "KRL" "Kaitai-Struct" "KakouneScript" + "KerboScript" "KiCad-Layout" "KiCad-Legacy-Layout" "KiCad-Schematic" + "Kickstart" "Kit" "Kotlin" "Kusto" "LFE" "LLVM" "LOLCODE" "LSL" + "LTspice-Symbol" "LabVIEW" "Lark" "Lasso" "Latte" "Lean" "Lean-4" + "Less" "Lex" "LigoLANG" "LilyPond" "Limbo" "Linker-Script" + "Linux-Kernel-Module" "Liquid" "Literate-Agda" + "Literate-CoffeeScript" "Literate-Haskell" "LiveScript" "Logos" + "Logtalk" "LookML" "LoomScript" "Lua" "M" "M4" "M4Sugar" "MATLAB" + "MAXScript" "MDX" "MLIR" "MQL4" "MQL5" "MTML" "MUF" "Macaulay2" + "Makefile" "Mako" "Markdown" "Marko" "Mask" "Mathematica" "Maven-POM" + "Max" "Mercury" "Mermaid" "Meson" "Metal" + "Microsoft-Developer-Studio-Project" + "Microsoft-Visual-Studio-Solution" "MiniD" "MiniYAML" "Mint" "Mirah" + "Modelica" "Modula-2" "Modula-3" "Module-Management-System" "Mojo" + "Monkey" "Monkey-C" "Moocode" "MoonScript" "Motoko" + "Motorola-68K-Assembly" "Move" "Muse" "Mustache" "Myghty" "NASL" + "NCL" "NEON" "NL" "NPM-Config" "NSIS" "NWScript" "Nasal" "Nearley" + "Nemerle" "NetLinx" "NetLinx+ERB" "NetLogo" "NewLisp" "Nextflow" + "Nginx" "Nim" "Ninja" "Nit" "Nix" "Nu" "NumPy" "Nunjucks" "Nushell" + "OASv2-json" "OASv2-yaml" "OASv3-json" "OASv3-yaml" "OCaml" "Oberon" + "ObjDump" "Object-Data-Instance-Notation" "ObjectScript" + "Objective-C" "Objective-C++" "Objective-J" "Odin" "Omgrofl" "Opa" + "Opal" "Open-Policy-Agent" "OpenAPI-Specification-v2" + "OpenAPI-Specification-v3" "OpenCL" "OpenEdge-ABL" "OpenQASM" + "OpenRC-runscript" "OpenSCAD" "OpenStep-Property-List" + "OpenType-Feature-File" "Option-List" "Org" "Ox" "Oxygene" "Oz" "P4" + "PDDL" "PEG.js" "PHP" "PLSQL" "PLpgSQL" "POV-Ray-SDL" "Pact" "Pan" + "Papyrus" "Parrot" "Parrot-Assembly" "Parrot-Internal-Representation" + "Pascal" "Pawn" "Pep8" "Perl" "Pic" "Pickle" "PicoLisp" "PigLatin" + "Pike" "Pip-Requirements" "PlantUML" "Pod" "Pod-6" "PogoScript" + "Polar" "Pony" "Portugol" "PostCSS" "PostScript" "PowerBuilder" + "PowerShell" "Praat" "Prisma" "Processing" "Procfile" "Proguard" + "Prolog" "Promela" "Propeller-Spin" "Protocol-Buffer" + "Protocol-Buffer-Text-Format" "Public-Key" "Pug" "Puppet" "Pure-Data" + "PureBasic" "PureScript" "Pyret" "Python" "Python-console" + "Python-traceback" "Q#" "QML" "QMake" "Qt-Script" "Quake" "R" "RAML" + "RBS" "RDoc" "REALbasic" "REXX" "RMarkdown" "RPC" "RPGLE" "RPM-Spec" + "RUNOFF" "Racket" "Ragel" "Raku" "Rascal" "Raw-token-data" "ReScript" + "Readline-Config" "Reason" "ReasonLIGO" "Rebol" "Record-Jar" "Red" + "Redcode" "Redirect-Rules" "Regular-Expression" "Ren'Py" + "RenderScript" "Rez" "Rich-Text-Format" "Ring" "Riot" + "RobotFramework" "Roc" "Roff" "Roff-Manpage" "Rouge" + "RouterOS-Script" "Ruby" "Rust" "SAS" "SCSS" "SELinux-Policy" "SMT" + "SPARQL" "SQF" "SQL" "SQLPL" "SRecode-Template" "SSH-Config" "STAR" + "STL" "STON" "SVG" "SWIG" "Sage" "SaltStack" "Sass" "Scala" "Scaml" + "Scenic" "Scheme" "Scilab" "Self" "ShaderLab" "Shell" + "ShellCheck-Config" "ShellSession" "Shen" "Sieve" + "Simple-File-Verification" "Singularity" "Slash" "Slice" "Slim" + "Slint" "SmPL" "Smali" "Smalltalk" "Smarty" "Smithy" "Snakemake" + "Solidity" "Soong" "SourcePawn" "Spline-Font-Database" "Squirrel" + "Stan" "Standard-ML" "Starlark" "Stata" "StringTemplate" "Stylus" + "SubRip-Text" "SugarSS" "SuperCollider" "Svelte" "Sway" "Sweave" + "Swift" "SystemVerilog" "TI-Program" "TL-Verilog" "TLA" "TOML" "TSQL" + "TSV" "TSX" "TXL" "Talon" "Tcl" "Tcsh" "TeX" "Tea" "Terra" + "Terraform-Template" "Texinfo" "Text" "TextGrid" + "TextMate-Properties" "Textile" "Thrift" "Toit" "Turing" "Turtle" + "Twig" "Type-Language" "TypeScript" "Typst" "Unified-Parallel-C" + "Unity3D-Asset" "Unix-Assembly" "Uno" "UnrealScript" "UrWeb" "V" + "VBA" "VBScript" "VCL" "VHDL" "Vala" "Valve-Data-Format" + "Velocity-Template-Language" "Verilog" "Vim-Help-File" "Vim-Script" + "Vim-Snippet" "Visual-Basic-.NET" "Visual-Basic-6.0" "Volt" "Vue" + "Vyper" "WDL" "WGSL" "Wavefront-Material" "Wavefront-Object" + "Web-Ontology-Language" "WebAssembly" "WebAssembly-Interface-Type" + "WebIDL" "WebVTT" "Wget-Config" "Whiley" "Wikitext" + "Win32-Message-File" "Windows-Registry-Entries" "Witcher-Script" + "Wollok" "World-of-Warcraft-Addon-Data" "Wren" "X-BitMap" + "X-Font-Directory-Index" "X-PixMap" "X10" "XC" "XCompose" "XML" + "XML-Property-List" "XPages" "XProc" "XQuery" "XS" "XSLT" "Xojo" + "Xonsh" "Xtend" "YAML" "YANG" "YARA" "YASnippet" "Yacc" "Yul" "ZAP" + "ZIL" "Zeek" "ZenScript" "Zephir" "Zig" "Zimpl" "cURL-Config" + "desktop" "dircolors" "eC" "edn" "fish" "hoon" "jq" "kvlang" + "mIRC-Script" "mcfunction" "mupad" "nanorc" "nesC" "ooc" "q" + "reStructuredText" "robots.txt" "sed" "wisp" "xBase") + "Language specifiers recognized by GitHub's syntax highlighting features.") + +(defvar-local markdown-gfm-used-languages nil + "Language names used in GFM code blocks.") + +(defun markdown-trim-whitespace (str) + (replace-regexp-in-string + "\\(?:[[:space:]\r\n]+\\'\\|\\`[[:space:]\r\n]+\\)" "" str)) + +(defun markdown-clean-language-string (str) + (replace-regexp-in-string + "{\\.?\\|}" "" (markdown-trim-whitespace str))) + +(defun markdown-validate-language-string (widget) + (let ((str (widget-value widget))) + (unless (string= str (markdown-clean-language-string str)) + (widget-put widget :error (format "Invalid language spec: '%s'" str)) + widget))) + +(defun markdown-gfm-get-corpus () + "Create corpus of recognized GFM code block languages for the given buffer." + (let ((given-corpus (append markdown-gfm-additional-languages + markdown-gfm-recognized-languages))) + (append + markdown-gfm-used-languages + (if markdown-gfm-downcase-languages (cl-mapcar #'downcase given-corpus) + given-corpus)))) + +(defun markdown-gfm-add-used-language (lang) + "Clean LANG and add to list of used languages." + (setq markdown-gfm-used-languages + (cons lang (remove lang markdown-gfm-used-languages)))) + +(defcustom markdown-spaces-after-code-fence 1 + "Number of space characters to insert after a code fence. +\\<gfm-mode-map>\\[markdown-insert-gfm-code-block] inserts this many spaces between an +opening code fence and an info string." + :group 'markdown + :type 'integer + :safe #'natnump + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-code-block-braces nil + "When non-nil, automatically insert braces for GFM code blocks." + :group 'markdown + :type 'boolean) + +(defun markdown-insert-gfm-code-block (&optional lang edit) + "Insert GFM code block for language LANG. +If LANG is nil, the language will be queried from user. If a +region is active, wrap this region with the markup instead. If +the region boundaries are not on empty lines, these are added +automatically in order to have the correct markup. When EDIT is +non-nil (e.g., when \\[universal-argument] is given), edit the +code block in an indirect buffer after insertion." + (interactive + (list (let ((completion-ignore-case nil)) + (condition-case nil + (markdown-clean-language-string + (completing-read + "Programming language: " + (markdown-gfm-get-corpus) + nil 'confirm (car markdown-gfm-used-languages) + 'markdown-gfm-language-history)) + (quit ""))) + current-prefix-arg)) + (unless (string= lang "") (markdown-gfm-add-used-language lang)) + (when (and (> (length lang) 0) + (not markdown-code-block-braces)) + (setq lang (concat (make-string markdown-spaces-after-code-fence ?\s) + lang))) + (let ((gfm-open-brace (if markdown-code-block-braces "{" "")) + (gfm-close-brace (if markdown-code-block-braces "}" ""))) + (if (use-region-p) + (let* ((b (region-beginning)) (e (region-end)) end + (indent (progn (goto-char b) (current-indentation)))) + (goto-char e) + ;; if we're on a blank line, don't newline, otherwise the ``` + ;; should go on its own line + (unless (looking-back "\n" nil) + (newline)) + (indent-to indent) + (insert "```") + (markdown-ensure-blank-line-after) + (setq end (point)) + (goto-char b) + ;; if we're on a blank line, insert the quotes here, otherwise + ;; add a new line first + (unless (looking-at-p "\n") + (newline) + (forward-line -1)) + (markdown-ensure-blank-line-before) + (indent-to indent) + (insert "```" gfm-open-brace lang gfm-close-brace) + (markdown-syntax-propertize-fenced-block-constructs (line-beginning-position) end)) + (let ((indent (current-indentation)) + start-bol) + (delete-horizontal-space :backward-only) + (markdown-ensure-blank-line-before) + (indent-to indent) + (setq start-bol (line-beginning-position)) + (insert "```" gfm-open-brace lang gfm-close-brace "\n") + (indent-to indent) + (unless edit (insert ?\n)) + (indent-to indent) + (insert "```") + (markdown-ensure-blank-line-after) + (markdown-syntax-propertize-fenced-block-constructs start-bol (point))) + (end-of-line 0) + (when edit (markdown-edit-code-block))))) + +(defun markdown-code-block-lang (&optional pos-prop) + "Return the language name for a GFM or tilde fenced code block. +The beginning of the block may be described by POS-PROP, +a cons of (pos . prop) giving the position and property +at the beginning of the block." + (or pos-prop + (setq pos-prop + (markdown-max-of-seq + #'car + (cl-remove-if + #'null + (cl-mapcar + #'markdown-find-previous-prop + (markdown-get-fenced-block-begin-properties)))))) + (when pos-prop + (goto-char (car pos-prop)) + (set-match-data (get-text-property (point) (cdr pos-prop))) + ;; Note: Hard-coded group number assumes tilde + ;; and GFM fenced code regexp groups agree. + (let ((begin (match-beginning 3)) + (end (match-end 3))) + (when (and begin end) + ;; Fix language strings beginning with periods, like ".ruby". + (when (eq (char-after begin) ?.) + (setq begin (1+ begin))) + (buffer-substring-no-properties begin end))))) + +(defun markdown-gfm-parse-buffer-for-languages (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (goto-char (point-min)) + (cl-loop + with prop = 'markdown-gfm-block-begin + for pos-prop = (markdown-find-next-prop prop) + while pos-prop + for lang = (markdown-code-block-lang pos-prop) + do (progn (when lang (markdown-gfm-add-used-language lang)) + (goto-char (next-single-property-change (point) prop))))))) + +(defun markdown-insert-foldable-block () + "Insert details disclosure element to make content foldable. +If a region is active, wrap this region with the disclosure +element. More details here https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details." + (interactive) + (let ((details-open-tag "<details>") + (details-close-tag "</details>") + (summary-open-tag "<summary>") + (summary-close-tag " </summary>")) + (if (use-region-p) + (let* ((b (region-beginning)) + (e (region-end)) + (indent (progn (goto-char b) (current-indentation)))) + (goto-char e) + ;; if we're on a blank line, don't newline, otherwise the tags + ;; should go on its own line + (unless (looking-back "\n" nil) + (newline)) + (indent-to indent) + (insert details-close-tag) + (markdown-ensure-blank-line-after) + (goto-char b) + ;; if we're on a blank line, insert the quotes here, otherwise + ;; add a new line first + (unless (looking-at-p "\n") + (newline) + (forward-line -1)) + (markdown-ensure-blank-line-before) + (indent-to indent) + (insert details-open-tag "\n") + (insert summary-open-tag summary-close-tag) + (search-backward summary-close-tag)) + (let ((indent (current-indentation))) + (delete-horizontal-space :backward-only) + (markdown-ensure-blank-line-before) + (indent-to indent) + (insert details-open-tag "\n") + (insert summary-open-tag summary-close-tag "\n") + (insert details-close-tag) + (indent-to indent) + (markdown-ensure-blank-line-after) + (search-backward summary-close-tag))))) + + +;;; Footnotes ================================================================= + +(defun markdown-footnote-counter-inc () + "Increment `markdown-footnote-counter' and return the new value." + (when (= markdown-footnote-counter 0) ; hasn't been updated in this buffer yet. + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (concat "^\\[\\^\\(" markdown-footnote-chars "*?\\)\\]:") + (point-max) t) + (let ((fn (string-to-number (match-string 1)))) + (when (> fn markdown-footnote-counter) + (setq markdown-footnote-counter fn)))))) + (cl-incf markdown-footnote-counter)) + +(defun markdown-insert-footnote () + "Insert footnote with a new number and move point to footnote definition." + (interactive) + (let ((fn (markdown-footnote-counter-inc))) + (insert (format "[^%d]" fn)) + (push-mark (point) t) + (markdown-footnote-text-find-new-location) + (markdown-ensure-blank-line-before) + (unless (markdown-cur-line-blank-p) + (insert "\n")) + (insert (format "[^%d]: " fn)) + (markdown-ensure-blank-line-after))) + +(defun markdown-footnote-text-find-new-location () + "Position the point at the proper location for a new footnote text." + (cond + ((eq markdown-footnote-location 'end) (goto-char (point-max))) + ((eq markdown-footnote-location 'immediately) (markdown-end-of-text-block)) + ((eq markdown-footnote-location 'subtree) (markdown-end-of-subtree)) + ((eq markdown-footnote-location 'header) (markdown-end-of-defun)))) + +(defun markdown-footnote-kill () + "Kill the footnote at point. +The footnote text is killed (and added to the kill ring), the +footnote marker is deleted. Point has to be either at the +footnote marker or in the footnote text." + (interactive) + (let ((marker-pos nil) + (skip-deleting-marker nil) + (starting-footnote-text-positions + (markdown-footnote-text-positions))) + (when starting-footnote-text-positions + ;; We're starting in footnote text, so mark our return position and jump + ;; to the marker if possible. + (let ((marker-pos (markdown-footnote-find-marker + (cl-first starting-footnote-text-positions)))) + (if marker-pos + (goto-char (1- marker-pos)) + ;; If there isn't a marker, we still want to kill the text. + (setq skip-deleting-marker t)))) + ;; Either we didn't start in the text, or we started in the text and jumped + ;; to the marker. We want to assume we're at the marker now and error if + ;; we're not. + (unless skip-deleting-marker + (let ((marker (markdown-footnote-delete-marker))) + (unless marker + (error "Not at a footnote")) + ;; Even if we knew the text position before, it changed when we deleted + ;; the label. + (setq marker-pos (cl-second marker)) + (let ((new-text-pos (markdown-footnote-find-text (cl-first marker)))) + (unless new-text-pos + (error "No text for footnote `%s'" (cl-first marker))) + (goto-char new-text-pos)))) + (let ((pos (markdown-footnote-kill-text))) + (goto-char (if starting-footnote-text-positions + pos + marker-pos))))) + +(defun markdown-footnote-delete-marker () + "Delete a footnote marker at point. +Returns a list (ID START) containing the footnote ID and the +start position of the marker before deletion. If no footnote +marker was deleted, this function returns NIL." + (let ((marker (markdown-footnote-marker-positions))) + (when marker + (delete-region (cl-second marker) (cl-third marker)) + (butlast marker)))) + +(defun markdown-footnote-kill-text () + "Kill footnote text at point. +Returns the start position of the footnote text before deletion, +or NIL if point was not inside a footnote text. + +The killed text is placed in the kill ring (without the footnote +number)." + (let ((fn (markdown-footnote-text-positions))) + (when fn + (let ((text (delete-and-extract-region (cl-second fn) (cl-third fn)))) + (string-match (concat "\\[\\" (cl-first fn) "\\]:[[:space:]]*\\(\\(.*\n?\\)*\\)") text) + (kill-new (match-string 1 text)) + (when (and (markdown-cur-line-blank-p) + (markdown-prev-line-blank-p) + (not (bobp))) + (delete-region (1- (point)) (point))) + (cl-second fn))))) + +(defun markdown-footnote-goto-text () + "Jump to the text of the footnote at point." + (interactive) + (let ((fn (car (markdown-footnote-marker-positions)))) + (unless fn + (user-error "Not at a footnote marker")) + (let ((new-pos (markdown-footnote-find-text fn))) + (unless new-pos + (error "No definition found for footnote `%s'" fn)) + (goto-char new-pos)))) + +(defun markdown-footnote-return () + "Return from a footnote to its footnote number in the main text." + (interactive) + (let ((fn (save-excursion + (car (markdown-footnote-text-positions))))) + (unless fn + (user-error "Not in a footnote")) + (let ((new-pos (markdown-footnote-find-marker fn))) + (unless new-pos + (error "Footnote marker `%s' not found" fn)) + (goto-char new-pos)))) + +(defun markdown-footnote-find-marker (id) + "Find the location of the footnote marker with ID. +The actual buffer position returned is the position directly +following the marker's closing bracket. If no marker is found, +NIL is returned." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "\\[" id "\\]\\([^:]\\|\\'\\)") nil t) + (skip-chars-backward "^]") + (point)))) + +(defun markdown-footnote-find-text (id) + "Find the location of the text of footnote ID. +The actual buffer position returned is the position of the first +character of the text, after the footnote's identifier. If no +footnote text is found, NIL is returned." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^ \\{0,3\\}\\[" id "\\]:") nil t) + (skip-chars-forward " \t") + (point)))) + +(defun markdown-footnote-marker-positions () + "Return the position and ID of the footnote marker point is on. +The return value is a list (ID START END). If point is not on a +footnote, NIL is returned." + ;; first make sure we're at a footnote marker + (if (or (looking-back (concat "\\[\\^" markdown-footnote-chars "*\\]?") (line-beginning-position)) + (looking-at-p (concat "\\[?\\^" markdown-footnote-chars "*?\\]"))) + (save-excursion + ;; move point between [ and ^: + (if (looking-at-p "\\[") + (forward-char 1) + (skip-chars-backward "^[")) + (looking-at (concat "\\(\\^" markdown-footnote-chars "*?\\)\\]")) + (list (match-string 1) (1- (match-beginning 1)) (1+ (match-end 1)))))) + +(defun markdown-footnote-text-positions () + "Return the start and end positions of the footnote text point is in. +The exact return value is a list of three elements: (ID START END). +The start position is the position of the opening bracket +of the footnote id. The end position is directly after the +newline that ends the footnote. If point is not in a footnote, +NIL is returned instead." + (save-excursion + (let (result) + (move-beginning-of-line 1) + ;; Try to find the label. If we haven't found the label and we're at a blank + ;; or indented line, back up if possible. + (while (and + (not (and (looking-at markdown-regex-footnote-definition) + (setq result (list (match-string 1) (point))))) + (and (not (bobp)) + (or (markdown-cur-line-blank-p) + (>= (current-indentation) 4)))) + (forward-line -1)) + (when result + ;; Advance if there is a next line that is either blank or indented. + ;; (Need to check if we're on the last line, because + ;; markdown-next-line-blank-p returns true for last line in buffer.) + (while (and (/= (line-end-position) (point-max)) + (or (markdown-next-line-blank-p) + (>= (markdown-next-line-indent) 4))) + (forward-line)) + ;; Move back while the current line is blank. + (while (markdown-cur-line-blank-p) + (forward-line -1)) + ;; Advance to capture this line and a single trailing newline (if there + ;; is one). + (forward-line) + (append result (list (point))))))) + +(defun markdown-get-defined-footnotes () + "Return a list of all defined footnotes. +Result is an alist of pairs (MARKER . LINE), where MARKER is the +footnote marker, a string, and LINE is the line number containing +the footnote definition. + +For example, suppose the following footnotes are defined at positions +448 and 475: + +\[^1]: First footnote here. +\[^marker]: Second footnote. + +Then the returned list is: ((\"^1\" . 478) (\"^marker\" . 475))" + (save-excursion + (goto-char (point-min)) + (let (footnotes) + (while (markdown-search-until-condition + (lambda () (and (not (markdown-code-block-at-point-p)) + (not (markdown-inline-code-at-point-p)) + (not (markdown-in-comment-p)))) + markdown-regex-footnote-definition nil t) + (let ((marker (match-string-no-properties 1)) + (pos (match-beginning 0))) + (unless (zerop (length marker)) + (cl-pushnew (cons marker pos) footnotes :test #'equal)))) + (reverse footnotes)))) + + +;;; Element Removal =========================================================== + +(defun markdown-kill-thing-at-point () + "Kill thing at point and add important text, without markup, to kill ring. +Possible things to kill include (roughly in order of precedence): +inline code, headers, horizontal rules, links (add link text to +kill ring), images (add alt text to kill ring), angle uri, email +addresses, bold, italics, reference definition (add URI to kill +ring), footnote markers and text (kill both marker and text, add +text to kill ring), and list items." + (interactive "*") + (let (val) + (cond + ;; Inline code + ((markdown-inline-code-at-point) + (kill-new (match-string 2)) + (delete-region (match-beginning 0) (match-end 0))) + ;; ATX header + ((thing-at-point-looking-at markdown-regex-header-atx) + (kill-new (match-string 2)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Setext header + ((thing-at-point-looking-at markdown-regex-header-setext) + (kill-new (match-string 1)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Horizontal rule + ((thing-at-point-looking-at markdown-regex-hr) + (kill-new (match-string 0)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Inline link or image (add link or alt text to kill ring) + ((thing-at-point-looking-at markdown-regex-link-inline) + (kill-new (match-string 3)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Reference link or image (add link or alt text to kill ring) + ((thing-at-point-looking-at markdown-regex-link-reference) + (kill-new (match-string 3)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Angle URI (add URL to kill ring) + ((thing-at-point-looking-at markdown-regex-angle-uri) + (kill-new (match-string 2)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Email address in angle brackets (add email address to kill ring) + ((thing-at-point-looking-at markdown-regex-email) + (kill-new (match-string 1)) + (delete-region (match-beginning 0) (match-end 0))) + ;; Wiki link (add alias text to kill ring) + ((and markdown-enable-wiki-links + (thing-at-point-looking-at markdown-regex-wiki-link)) + (kill-new (markdown-wiki-link-alias)) + (delete-region (match-beginning 1) (match-end 1))) + ;; Bold + ((thing-at-point-looking-at markdown-regex-bold) + (kill-new (match-string 4)) + (delete-region (match-beginning 2) (match-end 2))) + ;; Italics + ((thing-at-point-looking-at markdown-regex-italic) + (kill-new (match-string 3)) + (delete-region (match-beginning 1) (match-end 1))) + ;; Strikethrough + ((thing-at-point-looking-at markdown-regex-strike-through) + (kill-new (match-string 4)) + (delete-region (match-beginning 2) (match-end 2))) + ;; Footnote marker (add footnote text to kill ring) + ((thing-at-point-looking-at markdown-regex-footnote) + (markdown-footnote-kill)) + ;; Footnote text (add footnote text to kill ring) + ((setq val (markdown-footnote-text-positions)) + (markdown-footnote-kill)) + ;; Reference definition (add URL to kill ring) + ((thing-at-point-looking-at markdown-regex-reference-definition) + (kill-new (match-string 5)) + (delete-region (match-beginning 0) (match-end 0))) + ;; List item + ((setq val (markdown-cur-list-item-bounds)) + (kill-new (delete-and-extract-region (cl-first val) (cl-second val)))) + (t + (user-error "Nothing found at point to kill"))))) + +(defun markdown-kill-outline () + "Kill visible heading and add it to `kill-ring'." + (interactive) + (save-excursion + (markdown-outline-previous) + (kill-region (point) (progn (markdown-outline-next) (point))))) + +(defun markdown-kill-block () + "Kill visible code block, list item, or blockquote and add it to `kill-ring'." + (interactive) + (save-excursion + (markdown-backward-block) + (kill-region (point) (progn (markdown-forward-block) (point))))) + + +;;; Indentation =============================================================== + +(defun markdown-indent-find-next-position (cur-pos positions) + "Return the position after the index of CUR-POS in POSITIONS. +Positions are calculated by `markdown-calc-indents'." + (while (and positions + (not (equal cur-pos (car positions)))) + (setq positions (cdr positions))) + (or (cadr positions) 0)) + +(defun markdown-outdent-find-next-position (cur-pos positions) + "Return the maximal element that precedes CUR-POS from POSITIONS. +Positions are calculated by `markdown-calc-indents'." + (let ((result 0)) + (dolist (i positions) + (when (< i cur-pos) + (setq result (max result i)))) + result)) + +(defun markdown-indent-line () + "Indent the current line using some heuristics. +If the _previous_ command was either `markdown-enter-key' or +`markdown-cycle', then we should cycle to the next +reasonable indentation position. Otherwise, we could have been +called directly by `markdown-enter-key', by an initial call of +`markdown-cycle', or indirectly by `auto-fill-mode'. In +these cases, indent to the default position. +Positions are calculated by `markdown-calc-indents'." + (interactive) + (let ((positions (markdown-calc-indents)) + (point-pos (current-column)) + (_ (back-to-indentation)) + (cur-pos (current-column))) + (if (not (equal this-command 'markdown-cycle)) + (indent-line-to (car positions)) + (setq positions (sort (delete-dups positions) '<)) + (let* ((next-pos (markdown-indent-find-next-position cur-pos positions)) + (new-point-pos (max (+ point-pos (- next-pos cur-pos)) 0))) + (indent-line-to next-pos) + (move-to-column new-point-pos))))) + +(defun markdown-calc-indents () + "Return a list of indentation columns to cycle through. +The first element in the returned list should be considered the +default indentation level. This function does not worry about +duplicate positions, which are handled up by calling functions." + (let (pos prev-line-pos positions) + + ;; Indentation of previous line + (setq prev-line-pos (markdown-prev-line-indent)) + (setq positions (cons prev-line-pos positions)) + + ;; Indentation of previous non-list-marker text + (when (setq pos (save-excursion + (forward-line -1) + (when (looking-at markdown-regex-list) + (- (match-end 3) (match-beginning 0))))) + (setq positions (cons pos positions))) + + ;; Indentation required for a pre block in current context + (setq pos (length (markdown-pre-indentation (point)))) + (setq positions (cons pos positions)) + + ;; Indentation of the previous line + tab-width + (if prev-line-pos + (setq positions (cons (+ prev-line-pos tab-width) positions)) + (setq positions (cons tab-width positions))) + + ;; Indentation of the previous line - tab-width + (if (and prev-line-pos (> prev-line-pos tab-width)) + (setq positions (cons (- prev-line-pos tab-width) positions))) + + ;; Indentation of all preceding list markers (when in a list) + (when (setq pos (markdown-calculate-list-levels)) + (setq positions (append pos positions))) + + ;; First column + (setq positions (cons 0 positions)) + + ;; Return reversed list + (reverse positions))) + +(defun markdown-enter-key () ;FIXME: Partly obsoleted by electric-indent + "Handle RET depending on the context. +If the point is at a table, move to the next row. Otherwise, +indent according to value of `markdown-indent-on-enter'. +When it is nil, simply call `newline'. Otherwise, indent the next line +following RET using `markdown-indent-line'. Furthermore, when it +is set to \\='indent-and-new-item and the point is in a list item, +start a new item with the same indentation. If the point is in an +empty list item, remove it (so that pressing RET twice when in a +list simply adds a blank line)." + (interactive) + (cond + ;; Table + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-next-row)) + ;; Indent non-table text + (markdown-indent-on-enter + (let (bounds) + (if (and (memq markdown-indent-on-enter '(indent-and-new-item)) + (setq bounds (markdown-cur-list-item-bounds))) + (let ((beg (cl-first bounds)) + (end (cl-second bounds)) + (nonlist-indent (cl-fourth bounds)) + (checkbox (cl-sixth bounds))) + ;; Point is in a list item + (if (= (- end beg) (+ nonlist-indent (length checkbox))) + ;; Delete blank list + (progn + (delete-region beg end) + (newline) + (markdown-indent-line)) + (call-interactively #'markdown-insert-list-item))) + ;; Point is not in a list + (newline) + (markdown-indent-line)))) + ;; Insert a raw newline + (t (newline)))) + +(defun markdown-outdent-or-delete (arg) + "Handle BACKSPACE by cycling through indentation points. +When BACKSPACE is pressed, if there is only whitespace +before the current point, then outdent the line one level. +Otherwise, do normal delete by repeating +`backward-delete-char-untabify' ARG times." + (interactive "*p") + (if (use-region-p) + (backward-delete-char-untabify arg) + (let ((cur-pos (current-column)) + (start-of-indention (save-excursion + (back-to-indentation) + (current-column))) + (positions (markdown-calc-indents))) + (if (and (> cur-pos 0) (= cur-pos start-of-indention)) + (indent-line-to (markdown-outdent-find-next-position cur-pos positions)) + (backward-delete-char-untabify arg))))) + +(defun markdown-find-leftmost-column (beg end) + "Find the leftmost column in the region from BEG to END." + (let ((mincol 1000)) + (save-excursion + (goto-char beg) + (while (< (point) end) + (back-to-indentation) + (unless (looking-at-p "[ \t]*$") + (setq mincol (min mincol (current-column)))) + (forward-line 1) + )) + mincol)) + +(defun markdown-indent-region (beg end arg) + "Indent the region from BEG to END using some heuristics. +When ARG is non-nil, outdent the region instead. +See `markdown-indent-line' and `markdown-indent-line'." + (interactive "*r\nP") + (let* ((positions (sort (delete-dups (markdown-calc-indents)) '<)) + (leftmostcol (markdown-find-leftmost-column beg end)) + (next-pos (if arg + (markdown-outdent-find-next-position leftmostcol positions) + (markdown-indent-find-next-position leftmostcol positions)))) + (indent-rigidly beg end (- next-pos leftmostcol)) + (setq deactivate-mark nil))) + +(defun markdown-outdent-region (beg end) + "Call `markdown-indent-region' on region from BEG to END with prefix." + (interactive "*r") + (markdown-indent-region beg end t)) + +(defun markdown--indent-region (start end) + (let ((deactivate-mark nil)) + (save-excursion + (goto-char end) + (setq end (point-marker)) + (goto-char start) + (when (bolp) + (forward-line 1)) + (while (< (point) end) + (unless (or (markdown-code-block-at-point-p) (and (bolp) (eolp))) + (indent-according-to-mode)) + (forward-line 1)) + (move-marker end nil)))) + + +;;; Markup Completion ========================================================= + +(defconst markdown-complete-alist + '((markdown-regex-header-atx . markdown-complete-atx) + (markdown-regex-header-setext . markdown-complete-setext) + (markdown-regex-hr . markdown-complete-hr)) + "Association list of form (regexp . function) for markup completion.") + +(defun markdown-incomplete-atx-p () + "Return t if ATX header markup is incomplete and nil otherwise. +Assumes match data is available for `markdown-regex-header-atx'. +Checks that the number of trailing hash marks equals the number of leading +hash marks, that there is only a single space before and after the text, +and that there is no extraneous whitespace in the text." + (or + ;; Number of starting and ending hash marks differs + (not (= (length (match-string 1)) (length (match-string 3)))) + ;; When the header text is not empty... + (and (> (length (match-string 2)) 0) + ;; ...if there are extra leading, trailing, or interior spaces + (or (not (= (match-beginning 2) (1+ (match-end 1)))) + (not (= (match-beginning 3) (1+ (match-end 2)))) + (string-match-p "[ \t\n]\\{2\\}" (match-string 2)))) + ;; When the header text is empty... + (and (= (length (match-string 2)) 0) + ;; ...if there are too many or too few spaces + (not (= (match-beginning 3) (+ (match-end 1) 2)))))) + +(defun markdown-complete-atx () + "Complete and normalize ATX headers. +Add or remove hash marks to the end of the header to match the +beginning. Ensure that there is only a single space between hash +marks and header text. Removes extraneous whitespace from header text. +Assumes match data is available for `markdown-regex-header-atx'. +Return nil if markup was complete and non-nil if markup was completed." + (when (markdown-incomplete-atx-p) + (let* ((new-marker (make-marker)) + (new-marker (set-marker new-marker (match-end 2)))) + ;; Hash marks and spacing at end + (goto-char (match-end 2)) + (delete-region (match-end 2) (match-end 3)) + (insert " " (match-string 1)) + ;; Remove extraneous whitespace from title + (replace-match (markdown-compress-whitespace-string (match-string 2)) + t t nil 2) + ;; Spacing at beginning + (goto-char (match-end 1)) + (delete-region (match-end 1) (match-beginning 2)) + (insert " ") + ;; Leave point at end of text + (goto-char new-marker)))) + +(defun markdown-incomplete-setext-p () + "Return t if setext header markup is incomplete and nil otherwise. +Assumes match data is available for `markdown-regex-header-setext'. +Checks that length of underline matches text and that there is no +extraneous whitespace in the text." + (or (not (= (length (match-string 1)) (length (match-string 2)))) + (string-match-p "[ \t\n]\\{2\\}" (match-string 1)))) + +(defun markdown-complete-setext () + "Complete and normalize setext headers. +Add or remove underline characters to match length of header +text. Removes extraneous whitespace from header text. Assumes +match data is available for `markdown-regex-header-setext'. +Return nil if markup was complete and non-nil if markup was completed." + (when (markdown-incomplete-setext-p) + (let* ((text (markdown-compress-whitespace-string (match-string 1))) + (char (char-after (match-beginning 2))) + (level (if (char-equal char ?-) 2 1))) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) (match-end 0)) + (markdown-insert-header level text t) + t))) + +(defun markdown-incomplete-hr-p () + "Return non-nil if hr is not in `markdown-hr-strings' and nil otherwise. +Assumes match data is available for `markdown-regex-hr'." + (not (member (match-string 0) markdown-hr-strings))) + +(defun markdown-complete-hr () + "Complete horizontal rules. +If horizontal rule string is a member of `markdown-hr-strings', +do nothing. Otherwise, replace with the car of +`markdown-hr-strings'. +Assumes match data is available for `markdown-regex-hr'. +Return nil if markup was complete and non-nil if markup was completed." + (when (markdown-incomplete-hr-p) + (replace-match (car markdown-hr-strings)) + t)) + +(defun markdown-complete () + "Complete markup of object near point or in region when active. +Handle all objects in `markdown-complete-alist', in order. +See `markdown-complete-at-point' and `markdown-complete-region'." + (interactive "*") + (if (use-region-p) + (markdown-complete-region (region-beginning) (region-end)) + (markdown-complete-at-point))) + +(defun markdown-complete-at-point () + "Complete markup of object near point. +Handle all elements of `markdown-complete-alist' in order." + (interactive "*") + (let ((list markdown-complete-alist) found changed) + (while list + (let ((regexp (eval (caar list) t)) ;FIXME: Why `eval'? + (function (cdar list))) + (setq list (cdr list)) + (when (thing-at-point-looking-at regexp) + (setq found t) + (setq changed (funcall function)) + (setq list nil)))) + (if found + (or changed (user-error "Markup at point is complete")) + (user-error "Nothing to complete at point")))) + +(defun markdown-complete-region (beg end) + "Complete markup of objects in region from BEG to END. +Handle all objects in `markdown-complete-alist', in order. Each +match is checked to ensure that a previous regexp does not also +match." + (interactive "*r") + (let ((end-marker (set-marker (make-marker) end)) + previous) + (dolist (element markdown-complete-alist) + (let ((regexp (eval (car element) t)) ;FIXME: Why `eval'? + (function (cdr element))) + (goto-char beg) + (while (re-search-forward regexp end-marker 'limit) + (when (match-string 0) + ;; Make sure this is not a match for any of the preceding regexps. + ;; This prevents mistaking an HR for a Setext subheading. + (let (match) + (save-match-data + (dolist (prev-regexp previous) + (or match (setq match (looking-back prev-regexp nil))))) + (unless match + (save-excursion (funcall function)))))) + (cl-pushnew regexp previous :test #'equal))) + previous)) + +(defun markdown-complete-buffer () + "Complete markup for all objects in the current buffer." + (interactive "*") + (markdown-complete-region (point-min) (point-max))) + + +;;; Markup Cycling ============================================================ + +(defun markdown-cycle-atx (arg &optional remove) + "Cycle ATX header markup. +Promote header (decrease level) when ARG is 1 and demote +header (increase level) if arg is -1. When REMOVE is non-nil, +remove the header when the level reaches zero and stop cycling +when it reaches six. Otherwise, perform a proper cycling through +levels one through six. Assumes match data is available for +`markdown-regex-header-atx'." + (let* ((old-level (length (match-string 1))) + (new-level (+ old-level arg)) + (text (match-string 2))) + (when (not remove) + (setq new-level (% new-level 6)) + (setq new-level (cond ((= new-level 0) 6) + ((< new-level 0) (+ new-level 6)) + (t new-level)))) + (cond + ((= new-level 0) + (markdown-unwrap-thing-at-point nil 0 2)) + ((<= new-level 6) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) (match-end 0)) + (markdown-insert-header new-level text nil))))) + +(defun markdown-cycle-setext (arg &optional remove) + "Cycle setext header markup. +Promote header (increase level) when ARG is 1 and demote +header (decrease level or remove) if arg is -1. When demoting a +level-two setext header, replace with a level-three atx header. +When REMOVE is non-nil, remove the header when the level reaches +zero. Otherwise, cycle back to a level six atx header. Assumes +match data is available for `markdown-regex-header-setext'." + (let* ((char (char-after (match-beginning 2))) + (old-level (if (char-equal char ?=) 1 2)) + (new-level (+ old-level arg))) + (when (and (not remove) (= new-level 0)) + (setq new-level 6)) + (cond + ((= new-level 0) + (markdown-unwrap-thing-at-point nil 0 1)) + ((<= new-level 2) + (markdown-insert-header new-level nil t)) + ((<= new-level 6) + (markdown-insert-header new-level nil nil))))) + +(defun markdown-cycle-hr (arg &optional remove) + "Cycle string used for horizontal rule from `markdown-hr-strings'. +When ARG is 1, cycle forward (demote), and when ARG is -1, cycle +backwards (promote). When REMOVE is non-nil, remove the hr instead +of cycling when the end of the list is reached. +Assumes match data is available for `markdown-regex-hr'." + (let* ((strings (if (= arg -1) + (reverse markdown-hr-strings) + markdown-hr-strings)) + (tail (member (match-string 0) strings)) + (new (or (cadr tail) + (if remove + (if (= arg 1) + "" + (car tail)) + (car strings))))) + (replace-match new))) + +(defun markdown-cycle-bold () + "Cycle bold markup between underscores and asterisks. +Assumes match data is available for `markdown-regex-bold'." + (save-excursion + (let* ((old-delim (match-string 3)) + (new-delim (if (string-equal old-delim "**") "__" "**"))) + (replace-match new-delim t t nil 3) + (replace-match new-delim t t nil 5)))) + +(defun markdown-cycle-italic () + "Cycle italic markup between underscores and asterisks. +Assumes match data is available for `markdown-regex-italic'." + (save-excursion + (let* ((old-delim (match-string 2)) + (new-delim (if (string-equal old-delim "*") "_" "*"))) + (replace-match new-delim t t nil 2) + (replace-match new-delim t t nil 4)))) + + +;;; Keymap ==================================================================== + +(defun markdown--style-map-prompt () + "Return a formatted prompt for Markdown markup insertion." + (when markdown-enable-prefix-prompts + (concat + "Markdown: " + (propertize "bold" 'face 'markdown-bold-face) ", " + (propertize "italic" 'face 'markdown-italic-face) ", " + (propertize "code" 'face 'markdown-inline-code-face) ", " + (propertize "C = GFM code" 'face 'markdown-code-face) ", " + (propertize "pre" 'face 'markdown-pre-face) ", " + (propertize "footnote" 'face 'markdown-footnote-text-face) ", " + (propertize "F = foldable" 'face 'markdown-bold-face) ", " + (propertize "q = blockquote" 'face 'markdown-blockquote-face) ", " + (propertize "h & 1-6 = heading" 'face 'markdown-header-face) ", " + (propertize "- = hr" 'face 'markdown-hr-face) ", " + "C-h = more"))) + +(defun markdown--command-map-prompt () + "Return prompt for Markdown buffer-wide commands." + (when markdown-enable-prefix-prompts + (concat + "Command: " + (propertize "m" 'face 'markdown-bold-face) "arkdown, " + (propertize "p" 'face 'markdown-bold-face) "review, " + (propertize "o" 'face 'markdown-bold-face) "pen, " + (propertize "e" 'face 'markdown-bold-face) "xport, " + "export & pre" (propertize "v" 'face 'markdown-bold-face) "iew, " + (propertize "c" 'face 'markdown-bold-face) "heck refs, " + (propertize "u" 'face 'markdown-bold-face) "nused refs, " + "C-h = more"))) + +(defvar markdown-mode-style-map + (let ((map (make-keymap (markdown--style-map-prompt)))) + (define-key map (kbd "1") 'markdown-insert-header-atx-1) + (define-key map (kbd "2") 'markdown-insert-header-atx-2) + (define-key map (kbd "3") 'markdown-insert-header-atx-3) + (define-key map (kbd "4") 'markdown-insert-header-atx-4) + (define-key map (kbd "5") 'markdown-insert-header-atx-5) + (define-key map (kbd "6") 'markdown-insert-header-atx-6) + (define-key map (kbd "!") 'markdown-insert-header-setext-1) + (define-key map (kbd "@") 'markdown-insert-header-setext-2) + (define-key map (kbd "b") 'markdown-insert-bold) + (define-key map (kbd "c") 'markdown-insert-code) + (define-key map (kbd "C") 'markdown-insert-gfm-code-block) + (define-key map (kbd "f") 'markdown-insert-footnote) + (define-key map (kbd "F") 'markdown-insert-foldable-block) + (define-key map (kbd "h") 'markdown-insert-header-dwim) + (define-key map (kbd "H") 'markdown-insert-header-setext-dwim) + (define-key map (kbd "i") 'markdown-insert-italic) + (define-key map (kbd "k") 'markdown-insert-kbd) + (define-key map (kbd "l") 'markdown-insert-link) + (define-key map (kbd "p") 'markdown-insert-pre) + (define-key map (kbd "P") 'markdown-pre-region) + (define-key map (kbd "q") 'markdown-insert-blockquote) + (define-key map (kbd "s") 'markdown-insert-strike-through) + (define-key map (kbd "t") 'markdown-insert-table) + (define-key map (kbd "Q") 'markdown-blockquote-region) + (define-key map (kbd "w") 'markdown-insert-wiki-link) + (define-key map (kbd "-") 'markdown-insert-hr) + (define-key map (kbd "[") 'markdown-insert-gfm-checkbox) + ;; Deprecated keys that may be removed in a future version + (define-key map (kbd "e") 'markdown-insert-italic) + map) + "Keymap for Markdown text styling commands.") + +(defvar markdown-mode-command-map + (let ((map (make-keymap (markdown--command-map-prompt)))) + (define-key map (kbd "m") 'markdown-other-window) + (define-key map (kbd "p") 'markdown-preview) + (define-key map (kbd "e") 'markdown-export) + (define-key map (kbd "v") 'markdown-export-and-preview) + (define-key map (kbd "o") 'markdown-open) + (define-key map (kbd "l") 'markdown-live-preview-mode) + (define-key map (kbd "w") 'markdown-kill-ring-save) + (define-key map (kbd "c") 'markdown-check-refs) + (define-key map (kbd "u") 'markdown-unused-refs) + (define-key map (kbd "n") 'markdown-cleanup-list-numbers) + (define-key map (kbd "]") 'markdown-complete-buffer) + (define-key map (kbd "^") 'markdown-table-sort-lines) + (define-key map (kbd "|") 'markdown-table-convert-region) + (define-key map (kbd "t") 'markdown-table-transpose) + map) + "Keymap for Markdown buffer-wide commands.") + +(defvar markdown-mode-map + (let ((map (make-keymap))) + ;; Markup insertion & removal + (define-key map (kbd "C-c C-s") markdown-mode-style-map) + (define-key map (kbd "C-c C-l") 'markdown-insert-link) + (define-key map (kbd "C-c C-k") 'markdown-kill-thing-at-point) + ;; Promotion, demotion, and cycling + (define-key map (kbd "C-c C--") 'markdown-promote) + (define-key map (kbd "C-c C-=") 'markdown-demote) + (define-key map (kbd "C-c C-]") 'markdown-complete) + ;; Following and doing things + (define-key map (kbd "C-c C-o") 'markdown-follow-thing-at-point) + (define-key map (kbd "C-c C-d") 'markdown-do) + (define-key map (kbd "C-c '") 'markdown-edit-code-block) + ;; Indentation + (define-key map (kbd "RET") 'markdown-enter-key) + (define-key map (kbd "DEL") 'markdown-outdent-or-delete) + (define-key map (kbd "C-c >") 'markdown-indent-region) + (define-key map (kbd "C-c <") 'markdown-outdent-region) + ;; Visibility cycling + (define-key map (kbd "TAB") 'markdown-cycle) + ;; S-iso-lefttab and S-tab should both be mapped to `backtab' by + ;; (local-)function-key-map. + ;;(define-key map (kbd "<S-iso-lefttab>") 'markdown-shifttab) + ;;(define-key map (kbd "<S-tab>") 'markdown-shifttab) + (define-key map (kbd "<backtab>") 'markdown-shifttab) + ;; Heading and list navigation + (define-key map (kbd "C-c C-n") 'markdown-outline-next) + (define-key map (kbd "C-c C-p") 'markdown-outline-previous) + (define-key map (kbd "C-c C-f") 'markdown-outline-next-same-level) + (define-key map (kbd "C-c C-b") 'markdown-outline-previous-same-level) + (define-key map (kbd "C-c C-u") 'markdown-outline-up) + ;; Buffer-wide commands + (define-key map (kbd "C-c C-c") markdown-mode-command-map) + ;; Subtree, list, and table editing + (define-key map (kbd "C-c <up>") 'markdown-move-up) + (define-key map (kbd "C-c <down>") 'markdown-move-down) + (define-key map (kbd "C-c <left>") 'markdown-promote) + (define-key map (kbd "C-c <right>") 'markdown-demote) + (define-key map (kbd "C-c S-<up>") 'markdown-table-delete-row) + (define-key map (kbd "C-c S-<down>") 'markdown-table-insert-row) + (define-key map (kbd "C-c S-<left>") 'markdown-table-delete-column) + (define-key map (kbd "C-c S-<right>") 'markdown-table-insert-column) + (define-key map (kbd "C-c C-M-h") 'markdown-mark-subtree) + (define-key map (kbd "C-x n s") 'markdown-narrow-to-subtree) + (define-key map (kbd "M-RET") 'markdown-insert-list-item) + (define-key map (kbd "C-c C-j") 'markdown-insert-list-item) + ;; Lines + (define-key map [remap move-beginning-of-line] 'markdown-beginning-of-line) + (define-key map [remap move-end-of-line] 'markdown-end-of-line) + ;; Paragraphs (Markdown context aware) + (define-key map [remap backward-paragraph] 'markdown-backward-paragraph) + (define-key map [remap forward-paragraph] 'markdown-forward-paragraph) + (define-key map [remap mark-paragraph] 'markdown-mark-paragraph) + ;; Blocks (one or more paragraphs) + (define-key map (kbd "C-M-{") 'markdown-backward-block) + (define-key map (kbd "C-M-}") 'markdown-forward-block) + (define-key map (kbd "C-c M-h") 'markdown-mark-block) + (define-key map (kbd "C-x n b") 'markdown-narrow-to-block) + ;; Pages (top-level sections) + (define-key map [remap backward-page] 'markdown-backward-page) + (define-key map [remap forward-page] 'markdown-forward-page) + (define-key map [remap mark-page] 'markdown-mark-page) + (define-key map [remap narrow-to-page] 'markdown-narrow-to-page) + ;; Link Movement + (define-key map (kbd "M-n") 'markdown-next-link) + (define-key map (kbd "M-p") 'markdown-previous-link) + ;; Toggling functionality + (define-key map (kbd "C-c C-x C-e") 'markdown-toggle-math) + (define-key map (kbd "C-c C-x C-f") 'markdown-toggle-fontify-code-blocks-natively) + (define-key map (kbd "C-c C-x C-i") 'markdown-toggle-inline-images) + (define-key map (kbd "C-c C-x C-l") 'markdown-toggle-url-hiding) + (define-key map (kbd "C-c C-x C-m") 'markdown-toggle-markup-hiding) + ;; Alternative keys (in case of problems with the arrow keys) + (define-key map (kbd "C-c C-x u") 'markdown-move-up) + (define-key map (kbd "C-c C-x d") 'markdown-move-down) + (define-key map (kbd "C-c C-x l") 'markdown-promote) + (define-key map (kbd "C-c C-x r") 'markdown-demote) + ;; Deprecated keys that may be removed in a future version + (define-key map (kbd "C-c C-a L") 'markdown-insert-link) ;; C-c C-l + (define-key map (kbd "C-c C-a l") 'markdown-insert-link) ;; C-c C-l + (define-key map (kbd "C-c C-a r") 'markdown-insert-link) ;; C-c C-l + (define-key map (kbd "C-c C-a u") 'markdown-insert-uri) ;; C-c C-l + (define-key map (kbd "C-c C-a f") 'markdown-insert-footnote) + (define-key map (kbd "C-c C-a w") 'markdown-insert-wiki-link) + (define-key map (kbd "C-c C-t 1") 'markdown-insert-header-atx-1) + (define-key map (kbd "C-c C-t 2") 'markdown-insert-header-atx-2) + (define-key map (kbd "C-c C-t 3") 'markdown-insert-header-atx-3) + (define-key map (kbd "C-c C-t 4") 'markdown-insert-header-atx-4) + (define-key map (kbd "C-c C-t 5") 'markdown-insert-header-atx-5) + (define-key map (kbd "C-c C-t 6") 'markdown-insert-header-atx-6) + (define-key map (kbd "C-c C-t !") 'markdown-insert-header-setext-1) + (define-key map (kbd "C-c C-t @") 'markdown-insert-header-setext-2) + (define-key map (kbd "C-c C-t h") 'markdown-insert-header-dwim) + (define-key map (kbd "C-c C-t H") 'markdown-insert-header-setext-dwim) + (define-key map (kbd "C-c C-t s") 'markdown-insert-header-setext-2) + (define-key map (kbd "C-c C-t t") 'markdown-insert-header-setext-1) + (define-key map (kbd "C-c C-i") 'markdown-insert-image) + (define-key map (kbd "C-c C-x m") 'markdown-insert-list-item) ;; C-c C-j + (define-key map (kbd "C-c C-x C-x") 'markdown-toggle-gfm-checkbox) ;; C-c C-d + (define-key map (kbd "C-c -") 'markdown-insert-hr) + map) + "Keymap for Markdown major mode.") + +(defvar markdown-mode-mouse-map + (when markdown-mouse-follow-link + (let ((map (make-sparse-keymap))) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] #'markdown-follow-thing-at-point) + map)) + "Keymap for following links with mouse.") + +(defvar gfm-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map markdown-mode-map) + (define-key map (kbd "C-c C-s d") 'markdown-insert-strike-through) + (define-key map "`" 'markdown-electric-backquote) + map) + "Keymap for `gfm-mode'. +See also `markdown-mode-map'.") + + +;;; Menu ====================================================================== + +(easy-menu-define markdown-mode-menu markdown-mode-map + "Menu for Markdown mode." + '("Markdown" + "---" + ("Movement" + ["Jump" markdown-do] + ["Follow Link" markdown-follow-thing-at-point] + ["Next Link" markdown-next-link] + ["Previous Link" markdown-previous-link] + "---" + ["Next Heading or List Item" markdown-outline-next] + ["Previous Heading or List Item" markdown-outline-previous] + ["Next at Same Level" markdown-outline-next-same-level] + ["Previous at Same Level" markdown-outline-previous-same-level] + ["Up to Parent" markdown-outline-up] + "---" + ["Forward Paragraph" markdown-forward-paragraph] + ["Backward Paragraph" markdown-backward-paragraph] + ["Forward Block" markdown-forward-block] + ["Backward Block" markdown-backward-block]) + ("Show & Hide" + ["Cycle Heading Visibility" markdown-cycle + :enable (markdown-on-heading-p)] + ["Cycle Heading Visibility (Global)" markdown-shifttab] + "---" + ["Narrow to Region" narrow-to-region] + ["Narrow to Block" markdown-narrow-to-block] + ["Narrow to Section" narrow-to-defun] + ["Narrow to Subtree" markdown-narrow-to-subtree] + ["Widen" widen (buffer-narrowed-p)] + "---" + ["Toggle Markup Hiding" markdown-toggle-markup-hiding + :keys "C-c C-x C-m" + :style radio + :selected markdown-hide-markup]) + "---" + ("Headings & Structure" + ["Automatic Heading" markdown-insert-header-dwim + :keys "C-c C-s h"] + ["Automatic Heading (Setext)" markdown-insert-header-setext-dwim + :keys "C-c C-s H"] + ("Specific Heading (atx)" + ["First Level atx" markdown-insert-header-atx-1 + :keys "C-c C-s 1"] + ["Second Level atx" markdown-insert-header-atx-2 + :keys "C-c C-s 2"] + ["Third Level atx" markdown-insert-header-atx-3 + :keys "C-c C-s 3"] + ["Fourth Level atx" markdown-insert-header-atx-4 + :keys "C-c C-s 4"] + ["Fifth Level atx" markdown-insert-header-atx-5 + :keys "C-c C-s 5"] + ["Sixth Level atx" markdown-insert-header-atx-6 + :keys "C-c C-s 6"]) + ("Specific Heading (Setext)" + ["First Level Setext" markdown-insert-header-setext-1 + :keys "C-c C-s !"] + ["Second Level Setext" markdown-insert-header-setext-2 + :keys "C-c C-s @"]) + ["Horizontal Rule" markdown-insert-hr + :keys "C-c C-s -"] + "---" + ["Move Subtree Up" markdown-move-up + :keys "C-c <up>"] + ["Move Subtree Down" markdown-move-down + :keys "C-c <down>"] + ["Promote Subtree" markdown-promote + :keys "C-c <left>"] + ["Demote Subtree" markdown-demote + :keys "C-c <right>"]) + ("Region & Mark" + ["Indent Region" markdown-indent-region] + ["Outdent Region" markdown-outdent-region] + "--" + ["Mark Paragraph" mark-paragraph] + ["Mark Block" markdown-mark-block] + ["Mark Section" mark-defun] + ["Mark Subtree" markdown-mark-subtree]) + ("Tables" + ["Move Row Up" markdown-move-up + :enable (markdown-table-at-point-p) + :keys "C-c <up>"] + ["Move Row Down" markdown-move-down + :enable (markdown-table-at-point-p) + :keys "C-c <down>"] + ["Move Column Left" markdown-promote + :enable (markdown-table-at-point-p) + :keys "C-c <left>"] + ["Move Column Right" markdown-demote + :enable (markdown-table-at-point-p) + :keys "C-c <right>"] + ["Delete Row" markdown-table-delete-row + :enable (markdown-table-at-point-p)] + ["Insert Row" markdown-table-insert-row + :enable (markdown-table-at-point-p)] + ["Delete Column" markdown-table-delete-column + :enable (markdown-table-at-point-p)] + ["Insert Column" markdown-table-insert-column + :enable (markdown-table-at-point-p)] + ["Insert Table" markdown-insert-table] + "--" + ["Convert Region to Table" markdown-table-convert-region] + ["Sort Table Lines" markdown-table-sort-lines + :enable (markdown-table-at-point-p)] + ["Transpose Table" markdown-table-transpose + :enable (markdown-table-at-point-p)]) + ("Lists" + ["Insert List Item" markdown-insert-list-item] + ["Move Subtree Up" markdown-move-up + :keys "C-c <up>"] + ["Move Subtree Down" markdown-move-down + :keys "C-c <down>"] + ["Indent Subtree" markdown-demote + :keys "C-c <right>"] + ["Outdent Subtree" markdown-promote + :keys "C-c <left>"] + ["Renumber List" markdown-cleanup-list-numbers] + ["Insert Task List Item" markdown-insert-gfm-checkbox + :keys "C-c C-x ["] + ["Toggle Task List Item" markdown-toggle-gfm-checkbox + :enable (markdown-gfm-task-list-item-at-point) + :keys "C-c C-d"]) + ("Links & Images" + ["Insert Link" markdown-insert-link] + ["Insert Image" markdown-insert-image] + ["Insert Footnote" markdown-insert-footnote + :keys "C-c C-s f"] + ["Insert Wiki Link" markdown-insert-wiki-link + :keys "C-c C-s w"] + "---" + ["Check References" markdown-check-refs] + ["Find Unused References" markdown-unused-refs] + ["Toggle URL Hiding" markdown-toggle-url-hiding + :style radio + :selected markdown-hide-urls] + ["Toggle Inline Images" markdown-toggle-inline-images + :keys "C-c C-x C-i" + :style radio + :selected markdown-inline-image-overlays] + ["Toggle Wiki Links" markdown-toggle-wiki-links + :style radio + :selected markdown-enable-wiki-links]) + ("Styles" + ["Bold" markdown-insert-bold] + ["Italic" markdown-insert-italic] + ["Code" markdown-insert-code] + ["Strikethrough" markdown-insert-strike-through] + ["Keyboard" markdown-insert-kbd] + "---" + ["Blockquote" markdown-insert-blockquote] + ["Preformatted" markdown-insert-pre] + ["GFM Code Block" markdown-insert-gfm-code-block] + ["Edit Code Block" markdown-edit-code-block + :enable (markdown-code-block-at-point-p)] + ["Foldable Block" markdown-insert-foldable-block] + "---" + ["Blockquote Region" markdown-blockquote-region] + ["Preformatted Region" markdown-pre-region] + "---" + ["Fontify Code Blocks Natively" + markdown-toggle-fontify-code-blocks-natively + :style radio + :selected markdown-fontify-code-blocks-natively] + ["LaTeX Math Support" markdown-toggle-math + :style radio + :selected markdown-enable-math]) + "---" + ("Preview & Export" + ["Compile" markdown-other-window] + ["Preview" markdown-preview] + ["Export" markdown-export] + ["Export & View" markdown-export-and-preview] + ["Open" markdown-open] + ["Live Export" markdown-live-preview-mode + :style radio + :selected markdown-live-preview-mode] + ["Kill ring save" markdown-kill-ring-save]) + ("Markup Completion and Cycling" + ["Complete Markup" markdown-complete] + ["Promote Element" markdown-promote + :keys "C-c C--"] + ["Demote Element" markdown-demote + :keys "C-c C-="]) + "---" + ["Kill Element" markdown-kill-thing-at-point] + "---" + ("Documentation" + ["Version" markdown-show-version] + ["Homepage" markdown-mode-info] + ["Describe Mode" (describe-function 'markdown-mode)] + ["Guide" (browse-url "https://leanpub.com/markdown-mode")]))) + + +;;; imenu ===================================================================== + +(defun markdown-imenu-create-nested-index () + "Create and return a nested imenu index alist for the current buffer. +See `imenu-create-index-function' and `imenu--index-alist' for details." + (let* ((root (list nil)) + (min-level 9999) + hashes headers) + (save-excursion + ;; Headings + (goto-char (point-min)) + (while (re-search-forward markdown-regex-header (point-max) t) + (unless (or (markdown-code-block-at-point-p) + (and (match-beginning 3) + (get-text-property (match-beginning 3) 'markdown-yaml-metadata-end))) + (cond + ((match-string-no-properties 2) ;; level 1 setext + (setq min-level 1) + (push (list :heading (match-string-no-properties 1) + :point (match-beginning 1) + :level 1) headers)) + ((match-string-no-properties 3) ;; level 2 setext + (setq min-level (min min-level 2)) + (push (list :heading (match-string-no-properties 1) + :point (match-beginning 1) + :level (- 2 (1- min-level))) headers)) + ((setq hashes (markdown-trim-whitespace + (match-string-no-properties 4))) + (setq min-level (min min-level (length hashes))) + (push (list :heading (match-string-no-properties 5) + :point (match-beginning 4) + :level (- (length hashes) (1- min-level))) headers))))) + (cl-loop with cur-level = 0 + with cur-alist = nil + with empty-heading = "-" + with self-heading = "." + for header in (reverse headers) + for level = (plist-get header :level) + do + (let ((alist (list (cons (plist-get header :heading) (plist-get header :point))))) + (cond + ((= cur-level level) ; new sibling + (setcdr cur-alist alist) + (setq cur-alist alist)) + ((< cur-level level) ; first child + (dotimes (_ (- level cur-level 1)) + (setq alist (list (cons empty-heading alist)))) + (if cur-alist + (let* ((parent (car cur-alist)) + (self-pos (cdr parent))) + (setcdr parent (cons (cons self-heading self-pos) alist))) + (setcdr root alist)) ; primogenitor + (setq cur-alist alist) + (setq cur-level level)) + (t ; new sibling of an ancestor + (let ((sibling-alist (last (cdr root)))) + (dotimes (_ (1- level)) + (setq sibling-alist (last (cdar sibling-alist)))) + (setcdr sibling-alist alist) + (setq cur-alist alist)) + (setq cur-level level))))) + (setq root (copy-tree root)) + ;; Footnotes + (let ((fn (markdown-get-defined-footnotes))) + (if (or (zerop (length fn)) + (null markdown-add-footnotes-to-imenu)) + (cdr root) + (nconc (cdr root) (list (cons "Footnotes" fn)))))))) + +(defun markdown-imenu-create-flat-index () + "Create and return a flat imenu index alist for the current buffer. +See `imenu-create-index-function' and `imenu--index-alist' for details." + (let* ((empty-heading "-") index heading pos) + (save-excursion + ;; Headings + (goto-char (point-min)) + (while (re-search-forward markdown-regex-header (point-max) t) + (when (and (not (markdown-code-block-at-point-p (line-beginning-position))) + (not (markdown-text-property-at-point 'markdown-yaml-metadata-begin))) + (cond + ((setq heading (match-string-no-properties 1)) + (setq pos (match-beginning 1))) + ((setq heading (match-string-no-properties 5)) + (setq pos (match-beginning 4)))) + (or (> (length heading) 0) + (setq heading empty-heading)) + (setq index (append index (list (cons heading pos)))))) + ;; Footnotes + (when markdown-add-footnotes-to-imenu + (nconc index (markdown-get-defined-footnotes))) + index))) + + +;;; References ================================================================ + +(defun markdown-reference-goto-definition () + "Jump to the definition of the reference at point or create it." + (interactive) + (when (thing-at-point-looking-at markdown-regex-link-reference) + (let* ((text (match-string-no-properties 3)) + (reference (match-string-no-properties 6)) + (target (downcase (if (string= reference "") text reference))) + (loc (cadr (save-match-data (markdown-reference-definition target))))) + (if loc + (goto-char loc) + (goto-char (match-beginning 0)) + (markdown-insert-reference-definition target))))) + +(defun markdown-reference-find-links (reference) + "Return a list of all links for REFERENCE. +REFERENCE should not include the surrounding square brackets. +Elements of the list have the form (text start line), where +text is the link text, start is the location at the beginning of +the link, and line is the line number on which the link appears." + (let* ((ref-quote (regexp-quote reference)) + (regexp (format "!?\\(?:\\[\\(%s\\)\\][ ]?\\[\\]\\|\\[\\([^]]+?\\)\\][ ]?\\[%s\\]\\)" + ref-quote ref-quote)) + links) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (let* ((text (or (match-string-no-properties 1) + (match-string-no-properties 2))) + (start (match-beginning 0)) + (line (markdown-line-number-at-pos))) + (cl-pushnew (list text start line) links :test #'equal)))) + links)) + +(defmacro markdown-for-all-refs (f) + `(let ((result)) + (save-excursion + (goto-char (point-min)) + (while + (re-search-forward markdown-regex-link-reference nil t) + (let* ((text (match-string-no-properties 3)) + (reference (match-string-no-properties 6)) + (target (downcase (if (string= reference "") text reference)))) + (,f text target result)))) + (reverse result))) + +(defmacro markdown-collect-always (_ target result) + `(cl-pushnew ,target ,result :test #'equal)) + +(defmacro markdown-collect-undefined (text target result) + `(unless (markdown-reference-definition target) + (let ((entry (assoc ,target ,result))) + (if (not entry) + (cl-pushnew + (cons ,target (list (cons ,text (markdown-line-number-at-pos)))) + ,result :test #'equal) + (setcdr entry + (append (cdr entry) (list (cons ,text (markdown-line-number-at-pos))))))))) + +(defun markdown-get-all-refs () + "Return a list of all Markdown references." + (markdown-for-all-refs markdown-collect-always)) + +(defun markdown-get-undefined-refs () + "Return a list of undefined Markdown references. +Result is an alist of pairs (reference . occurrences), where +occurrences is itself another alist of pairs (label . line-number). +For example, an alist corresponding to [Nice editor][Emacs] at line 12, +\[GNU Emacs][Emacs] at line 45 and [manual][elisp] at line 127 is +\((\"emacs\" (\"Nice editor\" . 12) (\"GNU Emacs\" . 45)) (\"elisp\" (\"manual\" . 127)))." + (markdown-for-all-refs markdown-collect-undefined)) + +(defun markdown-get-unused-refs () + (cl-sort + (cl-set-difference + (markdown-get-defined-references) (markdown-get-all-refs) + :test (lambda (e1 e2) (equal (car e1) e2))) + #'< :key #'cdr)) + +(defmacro defun-markdown-buffer (name docstring) + "Define a function to name and return a buffer. + +By convention, NAME must be a name of a string constant with +%buffer% placeholder used to name the buffer, and will also be +used as a name of the function defined. + +DOCSTRING will be used as the first part of the docstring." + `(defun ,name (&optional buffer-name) + ,(concat docstring "\n\nBUFFER-NAME is the name of the main buffer being visited.") + (or buffer-name (setq buffer-name (buffer-name))) + (let ((refbuf (get-buffer-create (replace-regexp-in-string + "%buffer%" buffer-name + ,name)))) + (with-current-buffer refbuf + (when view-mode + (View-exit-and-edit)) + (use-local-map button-buffer-map) + (erase-buffer)) + refbuf))) + +(defconst markdown-reference-check-buffer + "*Undefined references for %buffer%*" + "Pattern for name of buffer for listing undefined references. +The string %buffer% will be replaced by the corresponding +`markdown-mode' buffer name.") + +(defun-markdown-buffer + markdown-reference-check-buffer + "Name and return buffer for reference checking.") + +(defconst markdown-unused-references-buffer + "*Unused references for %buffer%*" + "Pattern for name of buffer for listing unused references. +The string %buffer% will be replaced by the corresponding +`markdown-mode' buffer name.") + +(defun-markdown-buffer + markdown-unused-references-buffer + "Name and return buffer for unused reference checking.") + +(defconst markdown-reference-links-buffer + "*Reference links for %buffer%*" + "Pattern for name of buffer for listing references. +The string %buffer% will be replaced by the corresponding buffer name.") + +(defun-markdown-buffer + markdown-reference-links-buffer + "Name, setup, and return a buffer for listing links.") + +;; Add an empty Markdown reference definition to buffer +;; specified in the 'target-buffer property. The reference name is +;; the button's label. +(define-button-type 'markdown-undefined-reference-button + 'help-echo "mouse-1, RET: create definition for undefined reference" + 'follow-link t + 'face 'bold + 'action (lambda (b) + (let ((buffer (button-get b 'target-buffer)) + (line (button-get b 'target-line)) + (label (button-label b))) + (switch-to-buffer-other-window buffer) + (goto-char (point-min)) + (forward-line line) + (markdown-insert-reference-definition label) + (markdown-check-refs t)))) + +;; Jump to line in buffer specified by 'target-buffer property. +;; Line number is button's 'target-line property. +(define-button-type 'markdown-goto-line-button + 'help-echo "mouse-1, RET: go to line" + 'follow-link t + 'face 'italic + 'action (lambda (b) + (switch-to-buffer-other-window (button-get b 'target-buffer)) + ;; use call-interactively to silence compiler + (let ((current-prefix-arg (button-get b 'target-line))) + (call-interactively 'goto-line)))) + +;; Kill a line in buffer specified by 'target-buffer property. +;; Line number is button's 'target-line property. +(define-button-type 'markdown-kill-line-button + 'help-echo "mouse-1, RET: kill line" + 'follow-link t + 'face 'italic + 'action (lambda (b) + (switch-to-buffer-other-window (button-get b 'target-buffer)) + ;; use call-interactively to silence compiler + (let ((current-prefix-arg (button-get b 'target-line))) + (call-interactively 'goto-line)) + (kill-line 1) + (markdown-unused-refs t))) + +;; Jumps to a particular link at location given by 'target-char +;; property in buffer given by 'target-buffer property. +(define-button-type 'markdown-location-button + 'help-echo "mouse-1, RET: jump to location of link" + 'follow-link t + 'face 'bold + 'action (lambda (b) + (let ((target (button-get b 'target-buffer)) + (loc (button-get b 'target-char))) + (kill-buffer-and-window) + (switch-to-buffer target) + (goto-char loc)))) + +(defun markdown-insert-undefined-reference-button (reference oldbuf) + "Insert a button for creating REFERENCE in buffer OLDBUF. +REFERENCE should be a list of the form (reference . occurrences), +as returned by `markdown-get-undefined-refs'." + (let ((label (car reference))) + ;; Create a reference button + (insert-button label + :type 'markdown-undefined-reference-button + 'target-buffer oldbuf + 'target-line (cdr (car (cdr reference)))) + (insert " (") + (dolist (occurrence (cdr reference)) + (let ((line (cdr occurrence))) + ;; Create a line number button + (insert-button (number-to-string line) + :type 'markdown-goto-line-button + 'target-buffer oldbuf + 'target-line line) + (insert " "))) + (delete-char -1) + (insert ")") + (newline))) + +(defun markdown-insert-unused-reference-button (reference oldbuf) + "Insert a button for creating REFERENCE in buffer OLDBUF. +REFERENCE must be a pair of (ref . line-number)." + (let ((label (car reference)) + (line (cdr reference))) + ;; Create a reference button + (insert-button label + :type 'markdown-goto-line-button + 'face 'bold + 'target-buffer oldbuf + 'target-line line) + (insert (format " (%d) [" line)) + (insert-button "X" + :type 'markdown-kill-line-button + 'face 'bold + 'target-buffer oldbuf + 'target-line line) + (insert "]") + (newline))) + +(defun markdown-insert-link-button (link oldbuf) + "Insert a button for jumping to LINK in buffer OLDBUF. +LINK should be a list of the form (text char line) containing +the link text, location, and line number." + (let ((label (cl-first link)) + (char (cl-second link)) + (line (cl-third link))) + ;; Create a reference button + (insert-button label + :type 'markdown-location-button + 'target-buffer oldbuf + 'target-char char) + (insert (format " (line %d)\n" line)))) + +(defun markdown-reference-goto-link (&optional reference) + "Jump to the location of the first use of REFERENCE." + (interactive) + (unless reference + (if (thing-at-point-looking-at markdown-regex-reference-definition) + (setq reference (match-string-no-properties 2)) + (user-error "No reference definition at point"))) + (let ((links (markdown-reference-find-links reference))) + (cond ((= (length links) 1) + (goto-char (cadr (car links)))) + ((> (length links) 1) + (let ((oldbuf (current-buffer)) + (linkbuf (markdown-reference-links-buffer))) + (with-current-buffer linkbuf + (insert "Links using reference " reference ":\n\n") + (dolist (link (reverse links)) + (markdown-insert-link-button link oldbuf))) + (view-buffer-other-window linkbuf) + (goto-char (point-min)) + (forward-line 2))) + (t + (error "No links for reference %s" reference))))) + +(defmacro defun-markdown-ref-checker + (name docstring checker-function buffer-function none-message buffer-header insert-reference) + "Define a function NAME acting on result of CHECKER-FUNCTION. + +DOCSTRING is used as a docstring for the defined function. + +BUFFER-FUNCTION should name and return an auxiliary buffer to put +results in. + +NONE-MESSAGE is used when CHECKER-FUNCTION returns no results. + +BUFFER-HEADER is put into the auxiliary buffer first, followed by +calling INSERT-REFERENCE for each element in the list returned by +CHECKER-FUNCTION." + `(defun ,name (&optional silent) + ,(concat + docstring + "\n\nIf SILENT is non-nil, do not message anything when no +such references found.") + (interactive "P") + (unless (derived-mode-p 'markdown-mode) + (user-error "Not available in current mode")) + (let ((oldbuf (current-buffer)) + (refs (,checker-function)) + (refbuf (,buffer-function))) + (if (null refs) + (progn + (when (not silent) + (message ,none-message)) + (kill-buffer refbuf)) + (with-current-buffer refbuf + (insert ,buffer-header) + (dolist (ref refs) + (,insert-reference ref oldbuf)) + (view-buffer-other-window refbuf) + (goto-char (point-min)) + (forward-line 2)))))) + +(defun-markdown-ref-checker + markdown-check-refs + "Show all undefined Markdown references in current `markdown-mode' buffer. + +Links which have empty reference definitions are considered to be +defined." + markdown-get-undefined-refs + markdown-reference-check-buffer + "No undefined references found" + "The following references are undefined:\n\n" + markdown-insert-undefined-reference-button) + + +(defun-markdown-ref-checker + markdown-unused-refs + "Show all unused Markdown references in current `markdown-mode' buffer." + markdown-get-unused-refs + markdown-unused-references-buffer + "No unused references found" + "The following references are unused:\n\n" + markdown-insert-unused-reference-button) + + + +;;; Lists ===================================================================== + +(defun markdown-insert-list-item (&optional arg) + "Insert a new list item. +If the point is inside unordered list, insert a bullet mark. If +the point is inside ordered list, insert the next number followed +by a period. Use the previous list item to determine the amount +of whitespace to place before and after list markers. + +With a \\[universal-argument] prefix (i.e., when ARG is (4)), +decrease the indentation by one level. + +With two \\[universal-argument] prefixes (i.e., when ARG is (16)), +increase the indentation by one level." + (interactive "p") + (let (bounds cur-indent marker indent new-indent new-loc) + (save-match-data + ;; Look for a list item on current or previous non-blank line + (save-excursion + (while (and (not (setq bounds (markdown-cur-list-item-bounds))) + (not (bobp)) + (markdown-cur-line-blank-p)) + (forward-line -1))) + (when bounds + (cond ((save-excursion + (skip-chars-backward " \t") + (looking-at-p markdown-regex-list)) + (beginning-of-line) + (insert "\n") + (forward-line -1)) + ((not (markdown-cur-line-blank-p)) + (newline))) + (setq new-loc (point))) + ;; Look ahead for a list item on next non-blank line + (unless bounds + (save-excursion + (while (and (null bounds) + (not (eobp)) + (markdown-cur-line-blank-p)) + (forward-line) + (setq bounds (markdown-cur-list-item-bounds)))) + (when bounds + (setq new-loc (point)) + (unless (markdown-cur-line-blank-p) + (newline)))) + (if (not bounds) + ;; When not in a list, start a new unordered one + (progn + (unless (markdown-cur-line-blank-p) + (insert "\n")) + (insert markdown-unordered-list-item-prefix)) + ;; Compute indentation and marker for new list item + (setq cur-indent (nth 2 bounds)) + (setq marker (nth 4 bounds)) + ;; If current item is a GFM checkbox, insert new unchecked checkbox. + (when (nth 5 bounds) + (setq marker + (concat marker + (replace-regexp-in-string "[Xx]" " " (nth 5 bounds))))) + (cond + ;; Dedent: decrement indentation, find previous marker. + ((= arg 4) + (setq indent (max (- cur-indent markdown-list-indent-width) 0)) + (let ((prev-bounds + (save-excursion + (goto-char (nth 0 bounds)) + (when (markdown-up-list) + (markdown-cur-list-item-bounds))))) + (when prev-bounds + (setq marker (nth 4 prev-bounds))))) + ;; Indent: increment indentation by 4, use same marker. + ((= arg 16) (setq indent (+ cur-indent markdown-list-indent-width))) + ;; Same level: keep current indentation and marker. + (t (setq indent cur-indent))) + (setq new-indent (make-string indent 32)) + (goto-char new-loc) + (cond + ;; Ordered list + ((string-match-p "[0-9]" marker) + (if (= arg 16) ;; starting a new column indented one more level + (insert (concat new-indent "1. ")) + ;; Don't use previous match-data + (set-match-data nil) + ;; travel up to the last item and pick the correct number. If + ;; the argument was nil, "new-indent = cur-indent" is the same, + ;; so we don't need special treatment. Neat. + (save-excursion + (while (and (not (looking-at (concat new-indent "\\([0-9]+\\)\\(\\.[ \t]*\\)"))) + (>= (forward-line -1) 0)))) + (let* ((old-prefix (match-string 1)) + (old-spacing (match-string 2)) + (new-prefix (if (and old-prefix markdown-ordered-list-enumeration) + (int-to-string (1+ (string-to-number old-prefix))) + "1")) + (space-adjust (- (length old-prefix) (length new-prefix))) + (new-spacing (if (and (match-string 2) + (not (string-match-p "\t" old-spacing)) + (< space-adjust 0) + (> space-adjust (- 1 (length (match-string 2))))) + (substring (match-string 2) 0 space-adjust) + (or old-spacing ". ")))) + (insert (concat new-indent new-prefix new-spacing))))) + ;; Unordered list, GFM task list, or ordered list with hash mark + ((string-match-p "[\\*\\+-]\\|#\\." marker) + (insert new-indent marker)))) + ;; Propertize the newly inserted list item now + (markdown-syntax-propertize-list-items (line-beginning-position) (line-end-position))))) + +(defun markdown-move-list-item-up () + "Move the current list item up in the list when possible. +In nested lists, move child items with the parent item." + (interactive) + (let (cur prev old) + (when (setq cur (markdown-cur-list-item-bounds)) + (setq old (point)) + (goto-char (nth 0 cur)) + (if (markdown-prev-list-item (nth 3 cur)) + (progn + (setq prev (markdown-cur-list-item-bounds)) + (condition-case nil + (progn + (transpose-regions (nth 0 prev) (nth 1 prev) + (nth 0 cur) (nth 1 cur) t) + (goto-char (+ (nth 0 prev) (- old (nth 0 cur))))) + ;; Catch error in case regions overlap. + (error (goto-char old)))) + (goto-char old))))) + +(defun markdown-move-list-item-down () + "Move the current list item down in the list when possible. +In nested lists, move child items with the parent item." + (interactive) + (let (cur next old) + (when (setq cur (markdown-cur-list-item-bounds)) + (setq old (point)) + (if (markdown-next-list-item (nth 3 cur)) + (progn + (setq next (markdown-cur-list-item-bounds)) + (condition-case nil + (progn + (transpose-regions (nth 0 cur) (nth 1 cur) + (nth 0 next) (nth 1 next) nil) + (goto-char (+ old (- (nth 1 next) (nth 1 cur))))) + ;; Catch error in case regions overlap. + (error (goto-char old)))) + (goto-char old))))) + +(defun markdown-demote-list-item (&optional bounds) + "Indent (or demote) the current list item. +Optionally, BOUNDS of the current list item may be provided if available. +In nested lists, demote child items as well." + (interactive) + (when (or bounds (setq bounds (markdown-cur-list-item-bounds))) + (save-excursion + (let* ((item-start (set-marker (make-marker) (nth 0 bounds))) + (item-end (set-marker (make-marker) (nth 1 bounds))) + (list-start (progn (markdown-beginning-of-list) + (set-marker (make-marker) (point)))) + (list-end (progn (markdown-end-of-list) + (set-marker (make-marker) (point))))) + (goto-char item-start) + (while (< (point) item-end) + (unless (markdown-cur-line-blank-p) + (insert (make-string markdown-list-indent-width ? ))) + (forward-line)) + (markdown-syntax-propertize-list-items list-start list-end))))) + +(defun markdown-promote-list-item (&optional bounds) + "Unindent (or promote) the current list item. +Optionally, BOUNDS of the current list item may be provided if available. +In nested lists, demote child items as well." + (interactive) + (when (or bounds (setq bounds (markdown-cur-list-item-bounds))) + (save-excursion + (save-match-data + (let ((item-start (set-marker (make-marker) (nth 0 bounds))) + (item-end (set-marker (make-marker) (nth 1 bounds))) + (list-start (progn (markdown-beginning-of-list) + (set-marker (make-marker) (point)))) + (list-end (progn (markdown-end-of-list) + (set-marker (make-marker) (point)))) + num regexp) + (goto-char item-start) + (when (looking-at (format "^[ ]\\{1,%d\\}" + markdown-list-indent-width)) + (setq num (- (match-end 0) (match-beginning 0))) + (setq regexp (format "^[ ]\\{1,%d\\}" num)) + (while (and (< (point) item-end) + (re-search-forward regexp item-end t)) + (replace-match "" nil nil) + (forward-line)) + (markdown-syntax-propertize-list-items list-start list-end))))))) + +(defun markdown-cleanup-list-numbers-level (&optional pfx prev-item) + "Update the numbering for level PFX (as a string of spaces) and PREV-ITEM. +PREV-ITEM is width of previous-indentation and list number + +Assume that the previously found match was for a numbered item in +a list." + (let ((cpfx pfx) + (cur-item nil) + (idx 0) + (continue t) + (step t) + (sep nil)) + (while (and continue (not (eobp))) + (setq step t) + (cond + ((looking-at "^\\(\\([\s-]*\\)[0-9]+\\)\\. ") + (setq cpfx (match-string-no-properties 2)) + (setq cur-item (match-string-no-properties 1)) ;; indentation and list marker + (cond + ((or (= (length cpfx) (length pfx)) + (= (length cur-item) (length prev-item))) + (save-excursion + (replace-match + (if (not markdown-ordered-list-enumeration) + (concat pfx "1. ") + (cl-incf idx) + (concat pfx (number-to-string idx) ". ")))) + (setq sep nil)) + ;; indented a level + ((< (length pfx) (length cpfx)) + (setq sep (markdown-cleanup-list-numbers-level cpfx cur-item)) + (setq step nil)) + ;; exit the loop + (t + (setq step nil) + (setq continue nil)))) + + ((looking-at "^\\([\s-]*\\)[^ \t\n\r].*$") + (setq cpfx (match-string-no-properties 1)) + (cond + ;; reset if separated before + ((string= cpfx pfx) (when sep (setq idx 0))) + ((string< cpfx pfx) + (setq step nil) + (setq continue nil)))) + (t (setq sep t))) + + (when step + (beginning-of-line) + (setq continue (= (forward-line) 0)))) + sep)) + +(defun markdown-cleanup-list-numbers () + "Update the numbering of ordered lists." + (interactive) + (save-excursion + (goto-char (point-min)) + (markdown-cleanup-list-numbers-level ""))) + + +;;; Movement ================================================================== + +;; This function was originally derived from `org-beginning-of-line' from org.el. +(defun markdown-beginning-of-line (&optional n) + "Go to the beginning of the current visible line. + +If this is a headline, and `markdown-special-ctrl-a/e' is not nil +or symbol `reversed', on the first attempt move to where the +headline text hashes, and only move to beginning of line when the +cursor is already before the hashes of the text of the headline. + +If `markdown-special-ctrl-a/e' is symbol `reversed' then go to +the hashes of the text on the second attempt. + +With argument N not nil or 1, move forward N - 1 lines first." + (interactive "^p") + (let ((origin (point)) + (special (pcase markdown-special-ctrl-a/e + (`(,C-a . ,_) C-a) (_ markdown-special-ctrl-a/e))) + deactivate-mark) + ;; First move to a visible line. + (if visual-line-mode + (beginning-of-visual-line n) + (move-beginning-of-line n) + ;; `move-beginning-of-line' may leave point after invisible + ;; characters if line starts with such of these (e.g., with + ;; a link at column 0). Really move to the beginning of the + ;; current visible line. + (forward-line 0)) + (cond + ;; No special behavior. Point is already at the beginning of + ;; a line, logical or visual. + ((not special)) + ;; `beginning-of-visual-line' left point before logical beginning + ;; of line: point is at the beginning of a visual line. Bail + ;; out. + ((and visual-line-mode (not (bolp)))) + ((looking-at markdown-regex-header-atx) + ;; At a header, special position is before the title. + (let ((refpos (match-beginning 2)) + (bol (point))) + (if (eq special 'reversed) + (when (and (= origin bol) (eq last-command this-command)) + (goto-char refpos)) + (when (or (> origin refpos) (<= origin bol)) + (goto-char refpos))) + ;; Prevent automatic cursor movement caused by the command loop. + ;; Enable disable-point-adjustment to avoid unintended cursor repositioning. + (when (and markdown-hide-markup + (equal (get-char-property (point) 'display) "")) + (setq disable-point-adjustment t)))) + ((looking-at markdown-regex-list) + ;; At a list item, special position is after the list marker or checkbox. + (let ((refpos (or (match-end 4) (match-end 3)))) + (if (eq special 'reversed) + (when (and (= (point) origin) (eq last-command this-command)) + (goto-char refpos)) + (when (or (> origin refpos) (<= origin (line-beginning-position))) + (goto-char refpos))))) + ;; No special case, already at beginning of line. + (t nil)))) + +;; This function was originally derived from `org-end-of-line' from org.el. +(defun markdown-end-of-line (&optional n) + "Go to the end of the line, but before ellipsis, if any. + +If this is a headline, and `markdown-special-ctrl-a/e' is not nil +or symbol `reversed', ignore closing tags on the first attempt, +and only move to after the closing tags when the cursor is +already beyond the end of the headline. + +If `markdown-special-ctrl-a/e' is symbol `reversed' then ignore +closing tags on the second attempt. + +With argument N not nil or 1, move forward N - 1 lines first." + (interactive "^p") + (let ((origin (point)) + (special (pcase markdown-special-ctrl-a/e + (`(,_ . ,C-e) C-e) (_ markdown-special-ctrl-a/e))) + deactivate-mark) + ;; First move to a visible line. + (if visual-line-mode + (beginning-of-visual-line n) + (move-beginning-of-line n)) + (cond + ;; At a headline, with closing tags. + ((save-excursion + (forward-line 0) + (and (looking-at markdown-regex-header-atx) (match-end 3))) + (let ((refpos (match-end 2)) + (visual-end (and visual-line-mode + (save-excursion + (end-of-visual-line) + (point))))) + ;; If `end-of-visual-line' brings us before end of line or even closing + ;; tags, i.e., the headline spans over multiple visual lines, move + ;; there. + (cond ((and visual-end + (< visual-end refpos) + (<= origin visual-end)) + (goto-char visual-end)) + ((not special) (end-of-line)) + ((eq special 'reversed) + (if (and (= origin (line-end-position)) + (eq this-command last-command)) + (goto-char refpos) + (end-of-line))) + (t + (if (or (< origin refpos) (>= origin (line-end-position))) + (goto-char refpos) + (end-of-line)))) + ;; Prevent automatic cursor movement caused by the command loop. + ;; Enable disable-point-adjustment to avoid unintended cursor repositioning. + (when (and markdown-hide-markup + (equal (get-char-property (point) 'display) "")) + (setq disable-point-adjustment t)))) + (visual-line-mode + (let ((bol (line-beginning-position))) + (end-of-visual-line) + ;; If `end-of-visual-line' gets us past the ellipsis at the + ;; end of a line, backtrack and use `end-of-line' instead. + (when (/= bol (line-beginning-position)) + (goto-char bol) + (end-of-line)))) + (t (end-of-line))))) + +(defun markdown-beginning-of-defun (&optional arg) + "`beginning-of-defun-function' for Markdown. +This is used to find the beginning of the defun and should behave +like ‘beginning-of-defun’, returning non-nil if it found the +beginning of a defun. It moves the point backward, right before a +heading which defines a defun. When ARG is non-nil, repeat that +many times. When ARG is negative, move forward to the ARG-th +following section." + (or arg (setq arg 1)) + (when (< arg 0) (end-of-line)) + ;; Adjust position for setext headings. + (when (and (thing-at-point-looking-at markdown-regex-header-setext) + (not (= (point) (match-beginning 0))) + (not (markdown-code-block-at-point-p))) + (goto-char (match-end 0))) + (let (found) + ;; Move backward with positive argument. + (while (and (not (bobp)) (> arg 0)) + (setq found nil) + (while (and (not found) + (not (bobp)) + (re-search-backward markdown-regex-header nil 'move)) + (markdown-code-block-at-pos (match-beginning 0)) + (setq found (match-beginning 0))) + (setq arg (1- arg))) + ;; Move forward with negative argument. + (while (and (not (eobp)) (< arg 0)) + (setq found nil) + (while (and (not found) + (not (eobp)) + (re-search-forward markdown-regex-header nil 'move)) + (markdown-code-block-at-pos (match-beginning 0)) + (setq found (match-beginning 0))) + (setq arg (1+ arg))) + (when found + (beginning-of-line) + t))) + +(defun markdown-end-of-defun () + "`end-of-defun-function’ for Markdown. +This is used to find the end of the defun at point. +It is called with no argument, right after calling ‘beginning-of-defun-raw’, +so it can assume that point is at the beginning of the defun body. +It should move point to the first position after the defun." + (or (eobp) (forward-char 1)) + (let (found) + (while (and (not found) + (not (eobp)) + (re-search-forward markdown-regex-header nil 'move)) + (when (not (markdown-code-block-at-pos (match-beginning 0))) + (setq found (match-beginning 0)))) + (when found + (goto-char found) + (skip-syntax-backward "-")))) + +(defun markdown-beginning-of-text-block () + "Move backward to previous beginning of a plain text block. +This function simply looks for blank lines without considering +the surrounding context in light of Markdown syntax. For that, see +`markdown-backward-block'." + (interactive) + (let ((start (point))) + (if (re-search-backward markdown-regex-block-separator nil t) + (goto-char (match-end 0)) + (goto-char (point-min))) + (when (and (= start (point)) (not (bobp))) + (forward-line -1) + (if (re-search-backward markdown-regex-block-separator nil t) + (goto-char (match-end 0)) + (goto-char (point-min)))))) + +(defun markdown-end-of-text-block () + "Move forward to next beginning of a plain text block. +This function simply looks for blank lines without considering +the surrounding context in light of Markdown syntax. For that, see +`markdown-forward-block'." + (interactive) + (beginning-of-line) + (skip-chars-forward " \t\n") + (when (= (point) (point-min)) + (forward-char)) + (if (re-search-forward markdown-regex-block-separator nil t) + (goto-char (match-end 0)) + (goto-char (point-max))) + (skip-chars-backward " \t\n") + (forward-line)) + +(defun markdown-backward-paragraph (&optional arg) + "Move the point to the start of the current paragraph. +With argument ARG, do it ARG times; a negative argument ARG = -N +means move forward N blocks." + (interactive "^p") + (or arg (setq arg 1)) + (if (< arg 0) + (markdown-forward-paragraph (- arg)) + (dotimes (_ arg) + ;; Skip over whitespace in between paragraphs when moving backward. + (skip-chars-backward " \t\n") + (beginning-of-line) + ;; Skip over code block endings. + (when (markdown-range-properties-exist + (line-beginning-position) (line-end-position) + '(markdown-gfm-block-end + markdown-tilde-fence-end)) + (forward-line -1)) + ;; Skip over blank lines inside blockquotes. + (while (and (not (eobp)) + (looking-at markdown-regex-blockquote) + (= (length (match-string 3)) 0)) + (forward-line -1)) + ;; Proceed forward based on the type of block of paragraph. + (let (bounds skip) + (cond + ;; Blockquotes + ((looking-at markdown-regex-blockquote) + (while (and (not (bobp)) + (looking-at markdown-regex-blockquote) + (> (length (match-string 3)) 0)) ;; not blank + (forward-line -1)) + (forward-line)) + ;; List items + ((setq bounds (markdown-cur-list-item-bounds)) + (goto-char (nth 0 bounds))) + ;; Other + (t + (while (and (not (bobp)) + (not skip) + (not (markdown-cur-line-blank-p)) + (not (looking-at markdown-regex-blockquote)) + (not (markdown-range-properties-exist + (line-beginning-position) (line-end-position) + '(markdown-gfm-block-end + markdown-tilde-fence-end)))) + (setq skip (markdown-range-properties-exist + (line-beginning-position) (line-end-position) + '(markdown-gfm-block-begin + markdown-tilde-fence-begin))) + (forward-line -1)) + (unless (bobp) + (forward-line 1)))))))) + +(defun markdown-forward-paragraph (&optional arg) + "Move forward to the next end of a paragraph. +With argument ARG, do it ARG times; a negative argument ARG = -N +means move backward N blocks." + (interactive "^p") + (or arg (setq arg 1)) + (if (< arg 0) + (markdown-backward-paragraph (- arg)) + (dotimes (_ arg) + ;; Skip whitespace in between paragraphs. + (when (markdown-cur-line-blank-p) + (skip-syntax-forward "-") + (beginning-of-line)) + ;; Proceed forward based on the type of block. + (let (bounds skip) + (cond + ;; Blockquotes + ((looking-at markdown-regex-blockquote) + ;; Skip over blank lines inside blockquotes. + (while (and (not (eobp)) + (looking-at markdown-regex-blockquote) + (= (length (match-string 3)) 0)) + (forward-line)) + ;; Move to end of quoted text block + (while (and (not (eobp)) + (looking-at markdown-regex-blockquote) + (> (length (match-string 3)) 0)) ;; not blank + (forward-line))) + ;; List items + ((and (markdown-cur-list-item-bounds) + (setq bounds (markdown-next-list-item-bounds))) + (goto-char (nth 0 bounds))) + ;; Other + (t + (forward-line) + (while (and (not (eobp)) + (not skip) + (not (markdown-cur-line-blank-p)) + (not (looking-at markdown-regex-blockquote)) + (not (markdown-range-properties-exist + (line-beginning-position) (line-end-position) + '(markdown-gfm-block-begin + markdown-tilde-fence-begin)))) + (setq skip (markdown-range-properties-exist + (line-beginning-position) (line-end-position) + '(markdown-gfm-block-end + markdown-tilde-fence-end))) + (forward-line)))))))) + +(defun markdown-backward-block (&optional arg) + "Move the point to the start of the current Markdown block. +Moves across complete code blocks, list items, and blockquotes, +but otherwise stops at blank lines, headers, and horizontal +rules. With argument ARG, do it ARG times; a negative argument +ARG = -N means move forward N blocks." + (interactive "^p") + (or arg (setq arg 1)) + (if (< arg 0) + (markdown-forward-block (- arg)) + (dotimes (_ arg) + ;; Skip over whitespace in between blocks when moving backward, + ;; unless at a block boundary with no whitespace. + (skip-syntax-backward "-") + (beginning-of-line) + ;; Proceed forward based on the type of block. + (cond + ;; Code blocks + ((and (markdown-code-block-at-pos (point)) ;; this line + (markdown-code-block-at-pos (line-beginning-position 0))) ;; previous line + (forward-line -1) + (while (and (markdown-code-block-at-point-p) (not (bobp))) + (forward-line -1)) + (forward-line)) + ;; Headings + ((markdown-heading-at-point) + (goto-char (match-beginning 0))) + ;; Horizontal rules + ((looking-at markdown-regex-hr)) + ;; Blockquotes + ((looking-at markdown-regex-blockquote) + (forward-line -1) + (while (and (looking-at markdown-regex-blockquote) + (not (bobp))) + (forward-line -1)) + (forward-line)) + ;; List items + ((markdown-cur-list-item-bounds) + (markdown-beginning-of-list)) + ;; Other + (t + ;; Move forward in case it is a one line regular paragraph. + (unless (markdown-next-line-blank-p) + (forward-line)) + (unless (markdown-prev-line-blank-p) + (markdown-backward-paragraph))))))) + +(defun markdown-forward-block (&optional arg) + "Move forward to the next end of a Markdown block. +Moves across complete code blocks, list items, and blockquotes, +but otherwise stops at blank lines, headers, and horizontal +rules. With argument ARG, do it ARG times; a negative argument +ARG = -N means move backward N blocks." + (interactive "^p") + (or arg (setq arg 1)) + (if (< arg 0) + (markdown-backward-block (- arg)) + (dotimes (_ arg) + ;; Skip over whitespace in between blocks when moving forward. + (if (markdown-cur-line-blank-p) + (skip-syntax-forward "-") + (beginning-of-line)) + ;; Proceed forward based on the type of block. + (cond + ;; Code blocks + ((markdown-code-block-at-point-p) + (forward-line) + (while (and (markdown-code-block-at-point-p) (not (eobp))) + (forward-line))) + ;; Headings + ((looking-at markdown-regex-header) + (goto-char (or (match-end 4) (match-end 2) (match-end 3))) + (forward-line)) + ;; Horizontal rules + ((looking-at markdown-regex-hr) + (forward-line)) + ;; Blockquotes + ((looking-at markdown-regex-blockquote) + (forward-line) + (while (and (looking-at markdown-regex-blockquote) (not (eobp))) + (forward-line))) + ;; List items + ((markdown-cur-list-item-bounds) + (markdown-end-of-list) + (forward-line)) + ;; Other + (t (markdown-forward-paragraph)))) + (skip-syntax-backward "-") + (unless (eobp) + (forward-char 1)))) + +(defun markdown-backward-page (&optional count) + "Move backward to boundary of the current toplevel section. +With COUNT, repeat, or go forward if negative." + (interactive "p") + (or count (setq count 1)) + (if (< count 0) + (markdown-forward-page (- count)) + (skip-syntax-backward "-") + (or (markdown-back-to-heading-over-code-block t t) + (goto-char (point-min))) + (when (looking-at markdown-regex-header) + (let ((level (markdown-outline-level))) + (when (> level 1) (markdown-up-heading level)) + (when (> count 1) + (condition-case nil + (markdown-backward-same-level (1- count)) + (error (goto-char (point-min))))))))) + +(defun markdown-forward-page (&optional count) + "Move forward to boundary of the current toplevel section. +With COUNT, repeat, or go backward if negative." + (interactive "p") + (or count (setq count 1)) + (if (< count 0) + (markdown-backward-page (- count)) + (if (markdown-back-to-heading-over-code-block t t) + (let ((level (markdown-outline-level))) + (when (> level 1) (markdown-up-heading level)) + (condition-case nil + (markdown-forward-same-level count) + (error (goto-char (point-max))))) + (markdown-next-visible-heading 1)))) + +(defun markdown-next-link () + "Jump to next inline, reference, or wiki link. +If successful, return point. Otherwise, return nil. +See `markdown-wiki-link-p' and `markdown-previous-wiki-link'." + (interactive) + (let ((opoint (point))) + (when (or (markdown-link-p) (markdown-wiki-link-p)) + ;; At a link already, move past it. + (goto-char (+ (match-end 0) 1))) + ;; Search for the next wiki link and move to the beginning. + (while (and (re-search-forward (markdown-make-regex-link-generic) nil t) + (markdown-code-block-at-point-p) + (< (point) (point-max)))) + (if (and (not (eq (point) opoint)) + (or (markdown-link-p) (markdown-wiki-link-p))) + ;; Group 1 will move past non-escape character in wiki link regexp. + ;; Go to beginning of group zero for all other link types. + (goto-char (or (match-beginning 1) (match-beginning 0))) + (goto-char opoint) + nil))) + +(defun markdown-previous-link () + "Jump to previous wiki link. +If successful, return point. Otherwise, return nil. +See `markdown-wiki-link-p' and `markdown-next-wiki-link'." + (interactive) + (let ((opoint (point))) + (while (and (re-search-backward (markdown-make-regex-link-generic) nil t) + (markdown-code-block-at-point-p) + (> (point) (point-min)))) + (if (and (not (eq (point) opoint)) + (or (markdown-link-p) (markdown-wiki-link-p))) + (goto-char (or (match-beginning 1) (match-beginning 0))) + (goto-char opoint) + nil))) + + +;;; Outline =================================================================== + +(defun markdown-move-heading-common (move-fn &optional arg adjust) + "Wrapper for `outline-mode' functions to skip false positives. +MOVE-FN is a function and ARG is its argument. For example, +headings inside preformatted code blocks may match +`outline-regexp' but should not be considered as headings. +When ADJUST is non-nil, adjust the point for interactive calls +to avoid leaving the point at invisible markup. This adjustment +generally should only be done for interactive calls, since other +functions may expect the point to be at the beginning of the +regular expression." + (let ((prev -1) (start (point))) + (if arg (funcall move-fn arg) (funcall move-fn)) + (while (and (/= prev (point)) (markdown-code-block-at-point-p)) + (setq prev (point)) + (if arg (funcall move-fn arg) (funcall move-fn))) + ;; Adjust point for setext headings and invisible text. + (save-match-data + (when (and adjust (thing-at-point-looking-at markdown-regex-header)) + (if markdown-hide-markup + ;; Move to beginning of heading text if markup is hidden. + (goto-char (or (match-beginning 1) (match-beginning 5))) + ;; Move to beginning of markup otherwise. + (goto-char (or (match-beginning 1) (match-beginning 4)))))) + (if (= (point) start) nil (point)))) + +(defun markdown-next-visible-heading (arg) + "Move to the next visible heading line of any level. +With argument, repeats or can move backward if negative. ARG is +passed to `outline-next-visible-heading'." + (interactive "p") + (markdown-move-heading-common #'outline-next-visible-heading arg 'adjust)) + +(defun markdown-previous-visible-heading (arg) + "Move to the previous visible heading line of any level. +With argument, repeats or can move backward if negative. ARG is +passed to `outline-previous-visible-heading'." + (interactive "p") + (markdown-move-heading-common #'outline-previous-visible-heading arg 'adjust)) + +(defun markdown-next-heading () + "Move to the next heading line of any level." + (markdown-move-heading-common #'outline-next-heading)) + +(defun markdown-previous-heading () + "Move to the previous heading line of any level." + (markdown-move-heading-common #'outline-previous-heading)) + +(defun markdown-back-to-heading-over-code-block (&optional invisible-ok no-error) + "Move back to the beginning of the previous heading. +Returns t if the point is at a heading, the location if a heading +was found, and nil otherwise. +Only visible heading lines are considered, unless INVISIBLE-OK is +non-nil. Throw an error if there is no previous heading unless +NO-ERROR is non-nil. +Leaves match data intact for `markdown-regex-header'." + (beginning-of-line) + (or (and (markdown-heading-at-point) + (not (markdown-code-block-at-point-p))) + (let (found) + (save-excursion + (while (and (not found) + (re-search-backward markdown-regex-header nil t)) + (when (and (or invisible-ok (not (outline-invisible-p))) + (not (markdown-code-block-at-point-p))) + (setq found (point)))) + (if (not found) + (unless no-error (user-error "Before first heading")) + (setq found (point)))) + (when found (goto-char found))))) + +(defun markdown-forward-same-level (arg) + "Move forward to the ARG'th heading at same level as this one. +Stop at the first and last headings of a superior heading." + (interactive "p") + (markdown-back-to-heading-over-code-block) + (markdown-move-heading-common #'outline-forward-same-level arg 'adjust)) + +(defun markdown-backward-same-level (arg) + "Move backward to the ARG'th heading at same level as this one. +Stop at the first and last headings of a superior heading." + (interactive "p") + (markdown-back-to-heading-over-code-block) + (while (> arg 0) + (let ((point-to-move-to + (save-excursion + (markdown-move-heading-common #'outline-get-last-sibling nil 'adjust)))) + (if point-to-move-to + (progn + (goto-char point-to-move-to) + (setq arg (1- arg))) + (user-error "No previous same-level heading"))))) + +(defun markdown-up-heading (arg &optional interactive) + "Move to the visible heading line of which the present line is a subheading. +With argument, move up ARG levels. When called interactively (or +INTERACTIVE is non-nil), also push the mark." + (interactive "p\np") + (and interactive (not (eq last-command 'markdown-up-heading)) + (push-mark)) + (markdown-move-heading-common #'outline-up-heading arg 'adjust)) + +(defun markdown-back-to-heading (&optional invisible-ok) + "Move to previous heading line, or beg of this line if it's a heading. +Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." + (interactive) + (markdown-move-heading-common #'outline-back-to-heading invisible-ok)) + +(defalias 'markdown-end-of-heading 'outline-end-of-heading) + +(defun markdown-on-heading-p () + "Return non-nil if point is on a heading line." + (get-text-property (line-beginning-position) 'markdown-heading)) + +(defun markdown-end-of-subtree (&optional invisible-OK) + "Move to the end of the current subtree. +Only visible heading lines are considered, unless INVISIBLE-OK is +non-nil. +Derived from `org-end-of-subtree'." + (markdown-back-to-heading invisible-OK) + (let ((first t) + (level (markdown-outline-level))) + (while (and (not (eobp)) + (or first (> (markdown-outline-level) level))) + (setq first nil) + (markdown-next-heading)) + (if (memq (preceding-char) '(?\n ?\^M)) + (progn + ;; Go to end of line before heading + (forward-char -1) + (if (memq (preceding-char) '(?\n ?\^M)) + ;; leave blank line before heading + (forward-char -1))))) + (point)) + +(defun markdown-outline-fix-visibility () + "Hide any false positive headings that should not be shown. +For example, headings inside preformatted code blocks may match +`outline-regexp' but should not be shown as headings when cycling. +Also, the ending --- line in metadata blocks appears to be a +setext header, but should not be folded." + (save-excursion + (goto-char (point-min)) + ;; Unhide any false positives in metadata blocks + (when (markdown-text-property-at-point 'markdown-yaml-metadata-begin) + (let ((body (progn (forward-line) + (markdown-text-property-at-point + 'markdown-yaml-metadata-section)))) + (when body + (let ((end (progn (goto-char (cl-second body)) + (markdown-text-property-at-point + 'markdown-yaml-metadata-end)))) + (outline-flag-region (point-min) (1+ (cl-second end)) nil))))) + ;; Hide any false positives in code blocks + (unless (outline-on-heading-p) + (outline-next-visible-heading 1)) + (while (< (point) (point-max)) + (when (markdown-code-block-at-point-p) + (outline-flag-region (1- (line-beginning-position)) (line-end-position) t)) + (outline-next-visible-heading 1)))) + +(defvar markdown-cycle-global-status 1) +(defvar markdown-cycle-subtree-status nil) + +(defun markdown-next-preface () + (let (finish) + (while (and (not finish) (re-search-forward (concat "\n\\(?:" outline-regexp "\\)") + nil 'move)) + (unless (markdown-code-block-at-point-p) + (goto-char (match-beginning 0)) + (setq finish t)))) + (when (and (bolp) (or outline-blank-line (eobp)) (not (bobp))) + (forward-char -1))) + +(defun markdown-show-entry () + (save-excursion + (outline-back-to-heading t) + (outline-flag-region (1- (point)) + (progn + (markdown-next-preface) + (if (= 1 (- (point-max) (point))) + (point-max) + (point))) + nil))) + +;; This function was originally derived from `org-cycle' from org.el. +(defun markdown-cycle (&optional arg) + "Visibility cycling for Markdown mode. +This function is called with a `\\[universal-argument]' or if ARG is t, perform +global visibility cycling. If the point is at an atx-style header, cycle +visibility of the corresponding subtree. Otherwise, indent the current line + or insert a tab, as appropriate, by calling `indent-for-tab-command'." + (interactive "P") + (cond + + ;; Global cycling + (arg + (cond + ;; Move from overview to contents + ((and (eq last-command this-command) + (eq markdown-cycle-global-status 2)) + (outline-hide-sublevels 1) + (message "CONTENTS") + (setq markdown-cycle-global-status 3) + (markdown-outline-fix-visibility)) + ;; Move from contents to all + ((and (eq last-command this-command) + (eq markdown-cycle-global-status 3)) + (outline-show-all) + (message "SHOW ALL") + (setq markdown-cycle-global-status 1)) + ;; Defaults to overview + (t + (outline-hide-body) + (message "OVERVIEW") + (setq markdown-cycle-global-status 2) + (markdown-outline-fix-visibility)))) + + ;; At a heading: rotate between three different views + ((save-excursion (beginning-of-line 1) (markdown-on-heading-p)) + (markdown-back-to-heading) + (let ((goal-column 0) eoh eol eos) + ;; Determine boundaries + (save-excursion + (markdown-back-to-heading) + (save-excursion + (beginning-of-line 2) + (while (and (not (eobp)) ;; this is like `next-line' + (get-char-property (1- (point)) 'invisible)) + (beginning-of-line 2)) (setq eol (point))) + (markdown-end-of-heading) (setq eoh (point)) + (markdown-end-of-subtree t) + (skip-chars-forward " \t\n") + (beginning-of-line 1) ; in case this is an item + (setq eos (1- (point)))) + ;; Find out what to do next and set `this-command' + (cond + ;; Nothing is hidden behind this heading + ((= eos eoh) + (message "EMPTY ENTRY") + (setq markdown-cycle-subtree-status nil)) + ;; Entire subtree is hidden in one line: open it + ((>= eol eos) + (markdown-show-entry) + (outline-show-children) + (message "CHILDREN") + (setq markdown-cycle-subtree-status 'children)) + ;; We just showed the children, now show everything. + ((and (eq last-command this-command) + (eq markdown-cycle-subtree-status 'children)) + (outline-show-subtree) + (message "SUBTREE") + (setq markdown-cycle-subtree-status 'subtree)) + ;; Default action: hide the subtree. + (t + (outline-hide-subtree) + (message "FOLDED") + (setq markdown-cycle-subtree-status 'folded))))) + + ;; In a table, move forward by one cell + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-forward-cell)) + + ;; Otherwise, indent as appropriate + (t + (indent-for-tab-command)))) + +(defun markdown-shifttab () + "Handle S-TAB keybinding based on context. +When in a table, move backward one cell. +Otherwise, cycle global heading visibility by calling +`markdown-cycle' with argument t." + (interactive) + (cond ((markdown-table-at-point-p) + (call-interactively #'markdown-table-backward-cell)) + (t (markdown-cycle t)))) + +(defun markdown-outline-level () + "Return the depth to which a statement is nested in the outline." + (cond + ((and (match-beginning 0) + (markdown-code-block-at-pos (match-beginning 0))) + 7) ;; Only 6 header levels are defined. + ((match-end 2) 1) + ((match-end 3) 2) + ((match-end 4) + (length (markdown-trim-whitespace (match-string-no-properties 4)))))) + +(defun markdown-promote-subtree (&optional arg) + "Promote the current subtree of ATX headings. +Note that Markdown does not support heading levels higher than +six and therefore level-six headings will not be promoted +further. If ARG is non-nil promote the heading, otherwise +demote." + (interactive "*P") + (save-excursion + (when (and (or (thing-at-point-looking-at markdown-regex-header-atx) + (re-search-backward markdown-regex-header-atx nil t)) + (not (markdown-code-block-at-point-p))) + (let ((level (length (match-string 1))) + (promote-or-demote (if arg 1 -1)) + (remove 't)) + (markdown-cycle-atx promote-or-demote remove) + (catch 'end-of-subtree + (while (and (markdown-next-heading) + (looking-at markdown-regex-header-atx)) + ;; Exit if this not a higher level heading; promote otherwise. + (if (and (looking-at markdown-regex-header-atx) + (<= (length (match-string-no-properties 1)) level)) + (throw 'end-of-subtree nil) + (markdown-cycle-atx promote-or-demote remove)))))))) + +(defun markdown-demote-subtree () + "Demote the current subtree of ATX headings." + (interactive) + (markdown-promote-subtree t)) + +(defun markdown-move-subtree-up () + "Move the current subtree of ATX headings up." + (interactive) + (outline-move-subtree-up 1)) + +(defun markdown-move-subtree-down () + "Move the current subtree of ATX headings down." + (interactive) + (outline-move-subtree-down 1)) + +(defun markdown-outline-next () + "Move to next list item, when in a list, or next visible heading." + (interactive) + (let ((bounds (markdown-next-list-item-bounds))) + (if bounds + (goto-char (nth 0 bounds)) + (markdown-next-visible-heading 1)))) + +(defun markdown-outline-previous () + "Move to previous list item, when in a list, or previous visible heading." + (interactive) + (let ((bounds (markdown-prev-list-item-bounds))) + (if bounds + (goto-char (nth 0 bounds)) + (markdown-previous-visible-heading 1)))) + +(defun markdown-outline-next-same-level () + "Move to next list item or heading of same level." + (interactive) + (let ((bounds (markdown-cur-list-item-bounds))) + (if bounds + (markdown-next-list-item (nth 3 bounds)) + (markdown-forward-same-level 1)))) + +(defun markdown-outline-previous-same-level () + "Move to previous list item or heading of same level." + (interactive) + (let ((bounds (markdown-cur-list-item-bounds))) + (if bounds + (markdown-prev-list-item (nth 3 bounds)) + (markdown-backward-same-level 1)))) + +(defun markdown-outline-up () + "Move to previous list item, when in a list, or previous heading." + (interactive) + (unless (markdown-up-list) + (markdown-up-heading 1))) + + +;;; Marking and Narrowing ===================================================== + +(defun markdown-mark-paragraph () + "Put mark at end of this block, point at beginning. +The block marked is the one that contains point or follows point. + +Interactively, if this command is repeated or (in Transient Mark +mode) if the mark is active, it marks the next block after the +ones already marked." + (interactive) + (if (or (and (eq last-command this-command) (mark t)) + (and transient-mark-mode mark-active)) + (set-mark + (save-excursion + (goto-char (mark)) + (markdown-forward-paragraph) + (point))) + (let ((beginning-of-defun-function #'markdown-backward-paragraph) + (end-of-defun-function #'markdown-forward-paragraph)) + (mark-defun)))) + +(defun markdown-mark-block () + "Put mark at end of this block, point at beginning. +The block marked is the one that contains point or follows point. + +Interactively, if this command is repeated or (in Transient Mark +mode) if the mark is active, it marks the next block after the +ones already marked." + (interactive) + (if (or (and (eq last-command this-command) (mark t)) + (and transient-mark-mode mark-active)) + (set-mark + (save-excursion + (goto-char (mark)) + (markdown-forward-block) + (point))) + (let ((beginning-of-defun-function #'markdown-backward-block) + (end-of-defun-function #'markdown-forward-block)) + (mark-defun)))) + +(defun markdown-narrow-to-block () + "Make text outside current block invisible. +The current block is the one that contains point or follows point." + (interactive) + (let ((beginning-of-defun-function #'markdown-backward-block) + (end-of-defun-function #'markdown-forward-block)) + (narrow-to-defun))) + +(defun markdown-mark-text-block () + "Put mark at end of this plain text block, point at beginning. +The block marked is the one that contains point or follows point. + +Interactively, if this command is repeated or (in Transient Mark +mode) if the mark is active, it marks the next block after the +ones already marked." + (interactive) + (if (or (and (eq last-command this-command) (mark t)) + (and transient-mark-mode mark-active)) + (set-mark + (save-excursion + (goto-char (mark)) + (markdown-end-of-text-block) + (point))) + (let ((beginning-of-defun-function #'markdown-beginning-of-text-block) + (end-of-defun-function #'markdown-end-of-text-block)) + (mark-defun)))) + +(defun markdown-mark-page () + "Put mark at end of this top level section, point at beginning. +The top level section marked is the one that contains point or +follows point. + +Interactively, if this command is repeated or (in Transient Mark +mode) if the mark is active, it marks the next page after the +ones already marked." + (interactive) + (if (or (and (eq last-command this-command) (mark t)) + (and transient-mark-mode mark-active)) + (set-mark + (save-excursion + (goto-char (mark)) + (markdown-forward-page) + (point))) + (let ((beginning-of-defun-function #'markdown-backward-page) + (end-of-defun-function #'markdown-forward-page)) + (mark-defun)))) + +(defun markdown-narrow-to-page () + "Make text outside current top level section invisible. +The current section is the one that contains point or follows point." + (interactive) + (let ((beginning-of-defun-function #'markdown-backward-page) + (end-of-defun-function #'markdown-forward-page)) + (narrow-to-defun))) + +(defun markdown-mark-subtree () + "Mark the current subtree. +This puts point at the start of the current subtree, and mark at the end." + (interactive) + (let ((beg)) + (if (markdown-heading-at-point) + (beginning-of-line) + (markdown-previous-visible-heading 1)) + (setq beg (point)) + (markdown-end-of-subtree) + (push-mark (point) nil t) + (goto-char beg))) + +(defun markdown-narrow-to-subtree () + "Narrow buffer to the current subtree." + (interactive) + (save-excursion + (save-match-data + (narrow-to-region + (progn (markdown-back-to-heading-over-code-block t) (point)) + (progn (markdown-end-of-subtree) + (if (and (markdown-heading-at-point) (not (eobp))) + (backward-char 1)) + (point)))))) + + +;;; Generic Structure Editing, Completion, and Cycling Commands =============== + +(defun markdown-move-up () + "Move thing at point up. +When in a list item, call `markdown-move-list-item-up'. +When in a table, call `markdown-table-move-row-up'. +Otherwise, move the current heading subtree up with +`markdown-move-subtree-up'." + (interactive) + (cond + ((markdown-list-item-at-point-p) + (call-interactively #'markdown-move-list-item-up)) + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-move-row-up)) + (t + (call-interactively #'markdown-move-subtree-up)))) + +(defun markdown-move-down () + "Move thing at point down. +When in a list item, call `markdown-move-list-item-down'. +Otherwise, move the current heading subtree up with +`markdown-move-subtree-down'." + (interactive) + (cond + ((markdown-list-item-at-point-p) + (call-interactively #'markdown-move-list-item-down)) + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-move-row-down)) + (t + (call-interactively #'markdown-move-subtree-down)))) + +(defun markdown-promote () + "Promote or move element at point to the left. +Depending on the context, this function will promote a heading or +list item at the point, move a table column to the left, or cycle +markup." + (interactive) + (let (bounds) + (cond + ;; Promote atx heading subtree + ((thing-at-point-looking-at markdown-regex-header-atx) + (markdown-promote-subtree)) + ;; Promote setext heading + ((thing-at-point-looking-at markdown-regex-header-setext) + (markdown-cycle-setext -1)) + ;; Promote horizontal rule + ((thing-at-point-looking-at markdown-regex-hr) + (markdown-cycle-hr -1)) + ;; Promote list item + ((setq bounds (markdown-cur-list-item-bounds)) + (markdown-promote-list-item bounds)) + ;; Move table column to the left + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-move-column-left)) + ;; Promote bold + ((thing-at-point-looking-at markdown-regex-bold) + (markdown-cycle-bold)) + ;; Promote italic + ((thing-at-point-looking-at markdown-regex-italic) + (markdown-cycle-italic)) + (t + (user-error "Nothing to promote at point"))))) + +(defun markdown-demote () + "Demote or move element at point to the right. +Depending on the context, this function will demote a heading or +list item at the point, move a table column to the right, or cycle +or remove markup." + (interactive) + (let (bounds) + (cond + ;; Demote atx heading subtree + ((thing-at-point-looking-at markdown-regex-header-atx) + (markdown-demote-subtree)) + ;; Demote setext heading + ((thing-at-point-looking-at markdown-regex-header-setext) + (markdown-cycle-setext 1)) + ;; Demote horizontal rule + ((thing-at-point-looking-at markdown-regex-hr) + (markdown-cycle-hr 1)) + ;; Demote list item + ((setq bounds (markdown-cur-list-item-bounds)) + (markdown-demote-list-item bounds)) + ;; Move table column to the right + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-move-column-right)) + ;; Demote bold + ((thing-at-point-looking-at markdown-regex-bold) + (markdown-cycle-bold)) + ;; Demote italic + ((thing-at-point-looking-at markdown-regex-italic) + (markdown-cycle-italic)) + (t + (user-error "Nothing to demote at point"))))) + + +;;; Commands ================================================================== + +(defun markdown (&optional output-buffer-name) + "Run `markdown-command' on buffer, sending output to OUTPUT-BUFFER-NAME. +The output buffer name defaults to `markdown-output-buffer-name'. +Return the name of the output buffer used." + (interactive) + (save-window-excursion + (let* ((commands (cond ((stringp markdown-command) (split-string markdown-command)) + ((listp markdown-command) markdown-command))) + (command (car-safe commands)) + (command-args (cdr-safe commands)) + begin-region end-region) + (if (use-region-p) + (setq begin-region (region-beginning) + end-region (region-end)) + (setq begin-region (point-min) + end-region (point-max))) + + (unless output-buffer-name + (setq output-buffer-name markdown-output-buffer-name)) + (when (and (stringp command) (not (executable-find command))) + (user-error "Markdown command %s is not found" command)) + (let ((exit-code + (cond + ;; Handle case when `markdown-command' does not read from stdin + ((and (stringp command) markdown-command-needs-filename) + (if (not buffer-file-name) + (user-error "Must be visiting a file") + ;; Don’t use ‘shell-command’ because it’s not guaranteed to + ;; return the exit code of the process. + (let ((command (if (listp markdown-command) + (string-join markdown-command " ") + markdown-command))) + (shell-command-on-region + ;; Pass an empty region so that stdin is empty. + (point) (point) + (concat command " " + (shell-quote-argument buffer-file-name)) + output-buffer-name)))) + ;; Pass region to `markdown-command' via stdin + (t + (let ((buf (get-buffer-create output-buffer-name))) + (with-current-buffer buf + (setq buffer-read-only nil) + (erase-buffer)) + (if (stringp command) + (if (not (null command-args)) + (apply #'call-process-region begin-region end-region command nil buf nil command-args) + (call-process-region begin-region end-region command nil buf)) + (if markdown-command-needs-filename + (if (not buffer-file-name) + (user-error "Must be visiting a file") + (funcall markdown-command begin-region end-region buf buffer-file-name)) + (funcall markdown-command begin-region end-region buf)) + ;; If the ‘markdown-command’ function didn’t signal an + ;; error, assume it succeeded by binding ‘exit-code’ to 0. + 0)))))) + ;; The exit code can be a signal description string, so don’t use ‘=’ + ;; or ‘zerop’. + (unless (eq exit-code 0) + (user-error "%s failed with exit code %s" + markdown-command exit-code)))) + output-buffer-name)) + +(defun markdown-standalone (&optional output-buffer-name) + "Special function to provide standalone HTML output. +Insert the output in the buffer named OUTPUT-BUFFER-NAME." + (interactive) + (setq output-buffer-name (markdown output-buffer-name)) + (let ((css-path markdown-css-paths)) + (with-current-buffer output-buffer-name + (set-buffer output-buffer-name) + (setq-local markdown-css-paths css-path) + (unless (markdown-output-standalone-p) + (markdown-add-xhtml-header-and-footer output-buffer-name)) + (goto-char (point-min)) + (html-mode))) + output-buffer-name) + +(defun markdown-other-window (&optional output-buffer-name) + "Run `markdown-command' on current buffer and display in other window. +When OUTPUT-BUFFER-NAME is given, insert the output in the buffer with +that name." + (interactive) + (markdown-display-buffer-other-window + (markdown-standalone output-buffer-name))) + +(defun markdown-output-standalone-p () + "Determine whether `markdown-command' output is standalone XHTML. +Standalone XHTML output is identified by an occurrence of +`markdown-xhtml-standalone-regexp' in the first five lines of output." + (save-excursion + (goto-char (point-min)) + (save-match-data + (re-search-forward + markdown-xhtml-standalone-regexp + (save-excursion (goto-char (point-min)) (forward-line 4) (point)) + t)))) + +(defun markdown-stylesheet-link-string (stylesheet-path) + (concat "<link rel=\"stylesheet\" type=\"text/css\" media=\"all\" href=\"" + (or (and (string-prefix-p "~" stylesheet-path) + (expand-file-name stylesheet-path)) + stylesheet-path) + "\" />")) + +(defun markdown-escape-title (title) + "Escape a minimum set of characters in TITLE so they don't clash with html." + (replace-regexp-in-string ">" ">" + (replace-regexp-in-string "<" "<" + (replace-regexp-in-string "&" "&" title)))) + +(defun markdown-add-xhtml-header-and-footer (title) + "Wrap XHTML header and footer with given TITLE around current buffer." + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n" + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" + "\t\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n\n" + "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n\n" + "<head>\n<title>") + (insert (markdown-escape-title title)) + (insert "</title>\n") + (unless (= (length markdown-content-type) 0) + (insert + (format + "<meta http-equiv=\"Content-Type\" content=\"%s;charset=%s\"/>\n" + markdown-content-type + (or (and markdown-coding-system + (coding-system-get markdown-coding-system + 'mime-charset)) + (coding-system-get buffer-file-coding-system + 'mime-charset) + "utf-8")))) + (if (> (length markdown-css-paths) 0) + (insert (mapconcat #'markdown-stylesheet-link-string + markdown-css-paths "\n"))) + (when (> (length markdown-xhtml-header-content) 0) + (insert markdown-xhtml-header-content)) + (insert "\n</head>\n\n" + "<body>\n\n") + (when (> (length markdown-xhtml-body-preamble) 0) + (insert markdown-xhtml-body-preamble "\n")) + (goto-char (point-max)) + (when (> (length markdown-xhtml-body-epilogue) 0) + (insert "\n" markdown-xhtml-body-epilogue)) + (insert "\n" + "</body>\n" + "</html>\n")) + +(defun markdown-preview (&optional output-buffer-name) + "Run `markdown-command' on the current buffer and view output in browser. +When OUTPUT-BUFFER-NAME is given, insert the output in the buffer with +that name." + (interactive) + (browse-url-of-buffer + (markdown-standalone (or output-buffer-name markdown-output-buffer-name)))) + +(defun markdown-export-file-name (&optional extension) + "Attempt to generate a filename for Markdown output. +The file extension will be EXTENSION if given, or .html by default. +If the current buffer is visiting a file, we construct a new +output filename based on that filename. Otherwise, return nil." + (when (buffer-file-name) + (unless extension + (setq extension ".html")) + (let ((candidate + (concat + (cond + ((buffer-file-name) + (file-name-sans-extension (buffer-file-name))) + (t (buffer-name))) + extension))) + (cond + ((equal candidate (buffer-file-name)) + (concat candidate extension)) + (t + candidate))))) + +(defun markdown-export (&optional output-file) + "Run Markdown on the current buffer, save to file, and return the filename. +If OUTPUT-FILE is given, use that as the filename. Otherwise, use the filename +generated by `markdown-export-file-name', which will be constructed using the +current filename, but with the extension removed and replaced with .html." + (interactive) + (unless output-file + (setq output-file (markdown-export-file-name ".html"))) + (when output-file + (let* ((init-buf (current-buffer)) + (init-point (point)) + (init-buf-string (buffer-string)) + (output-buffer (find-file-noselect output-file)) + (output-buffer-name (buffer-name output-buffer))) + (run-hooks 'markdown-before-export-hook) + (markdown-standalone output-buffer-name) + (with-current-buffer output-buffer + (run-hooks 'markdown-after-export-hook) + (save-buffer) + (when markdown-export-kill-buffer (kill-buffer))) + ;; if modified, restore initial buffer + (when (buffer-modified-p init-buf) + (erase-buffer) + (insert init-buf-string) + (save-buffer) + (goto-char init-point)) + output-file))) + +(defun markdown-export-and-preview () + "Export to XHTML using `markdown-export' and browse the resulting file." + (interactive) + (browse-url-of-file (markdown-export))) + +(defvar-local markdown-live-preview-buffer nil + "Buffer used to preview markdown output in `markdown-live-preview-export'.") + +(defvar-local markdown-live-preview-source-buffer nil + "Source buffer from which current buffer was generated. +This is the inverse of `markdown-live-preview-buffer'.") + +(defvar markdown-live-preview-currently-exporting nil) + +(defun markdown-live-preview-get-filename () + "Standardize the filename exported by `markdown-live-preview-export'." + (markdown-export-file-name ".html")) + +(defun markdown-live-preview-window-eww (file) + "Preview FILE with eww. +To be used with `markdown-live-preview-window-function'." + (when (and (bound-and-true-p eww-auto-rename-buffer) + markdown-live-preview-buffer) + (kill-buffer markdown-live-preview-buffer)) + (eww-open-file file) + ;; #737 if `eww-auto-rename-buffer' is non-nil, the buffer name is not "*eww*" + ;; Try to find the buffer whose name ends with "eww*" + (if (bound-and-true-p eww-auto-rename-buffer) + (cl-loop for buf in (buffer-list) + when (string-match-p "eww\\*\\'" (buffer-name buf)) + return buf) + (get-buffer "*eww*"))) + +(defun markdown-visual-lines-between-points (beg end) + (save-excursion + (goto-char beg) + (cl-loop with count = 0 + while (progn (end-of-visual-line) + (and (< (point) end) (line-move-visual 1 t))) + do (cl-incf count) + finally return count))) + +(defun markdown-live-preview-window-serialize (buf) + "Get window point and scroll data for all windows displaying BUF." + (when (buffer-live-p buf) + (with-current-buffer buf + (mapcar + (lambda (win) + (with-selected-window win + (let* ((start (window-start)) + (pt (window-point)) + (pt-or-sym (cond ((= pt (point-min)) 'min) + ((= pt (point-max)) 'max) + (t pt))) + (diff (markdown-visual-lines-between-points + start pt))) + (list win pt-or-sym diff)))) + (get-buffer-window-list buf))))) + +(defun markdown-get-point-back-lines (pt num-lines) + (save-excursion + (goto-char pt) + (line-move-visual (- num-lines) t) + ;; in testing, can occasionally overshoot the number of lines to traverse + (let ((actual-num-lines (markdown-visual-lines-between-points (point) pt))) + (when (> actual-num-lines num-lines) + (line-move-visual (- actual-num-lines num-lines) t))) + (point))) + +(defun markdown-live-preview-window-deserialize (window-posns) + "Apply window point and scroll data from WINDOW-POSNS. +WINDOW-POSNS is provided by `markdown-live-preview-window-serialize'." + (cl-destructuring-bind (win pt-or-sym diff) window-posns + (when (window-live-p win) + (with-current-buffer markdown-live-preview-buffer + (set-window-buffer win (current-buffer)) + (cl-destructuring-bind (actual-pt actual-diff) + (cl-case pt-or-sym + (min (list (point-min) 0)) + (max (list (point-max) diff)) + (t (list pt-or-sym diff))) + (set-window-start + win (markdown-get-point-back-lines actual-pt actual-diff)) + (set-window-point win actual-pt)))))) + +(defun markdown-live-preview-export () + "Export to XHTML using `markdown-export'. +Browse the resulting file within Emacs using +`markdown-live-preview-window-function' Return the buffer +displaying the rendered output." + (interactive) + (let ((filename (markdown-live-preview-get-filename))) + (when filename + (let* ((markdown-live-preview-currently-exporting t) + (cur-buf (current-buffer)) + (export-file (markdown-export filename)) + ;; get positions in all windows currently displaying output buffer + (window-data + (markdown-live-preview-window-serialize + markdown-live-preview-buffer))) + (save-window-excursion + (let ((output-buffer + (funcall markdown-live-preview-window-function export-file))) + (with-current-buffer output-buffer + (setq markdown-live-preview-source-buffer cur-buf) + (add-hook 'kill-buffer-hook + #'markdown-live-preview-remove-on-kill t t)) + (with-current-buffer cur-buf + (setq markdown-live-preview-buffer output-buffer)))) + (with-current-buffer cur-buf + ;; reset all windows displaying output buffer to where they were, + ;; now with the new output + (mapc #'markdown-live-preview-window-deserialize window-data) + ;; delete html editing buffer + (let ((buf (get-file-buffer export-file))) (when buf (kill-buffer buf))) + (when (and export-file (file-exists-p export-file) + (eq markdown-live-preview-delete-export + 'delete-on-export)) + (delete-file export-file)) + markdown-live-preview-buffer))))) + +(defun markdown-live-preview-remove () + (when (buffer-live-p markdown-live-preview-buffer) + (kill-buffer markdown-live-preview-buffer)) + (setq markdown-live-preview-buffer nil) + ;; if set to 'delete-on-export, the output has already been deleted + (when (eq markdown-live-preview-delete-export 'delete-on-destroy) + (let ((outfile-name (markdown-live-preview-get-filename))) + (when (and outfile-name (file-exists-p outfile-name)) + (delete-file outfile-name))))) + +(defun markdown-get-other-window () + "Find another window to display preview or output content." + (cond + ((memq markdown-split-window-direction '(vertical below)) + (or (window-in-direction 'below) (split-window-vertically))) + ((memq markdown-split-window-direction '(horizontal right)) + (or (window-in-direction 'right) (split-window-horizontally))) + (t (split-window-sensibly (get-buffer-window))))) + +(defun markdown-display-buffer-other-window (buf) + "Display preview or output buffer BUF in another window." + (if (and display-buffer-alist (eq markdown-split-window-direction 'any)) + (display-buffer buf) + (let ((cur-buf (current-buffer)) + (window (markdown-get-other-window))) + (set-window-buffer window buf) + (set-buffer cur-buf)))) + +(defun markdown-live-preview-if-markdown () + (when (and (derived-mode-p 'markdown-mode) + markdown-live-preview-mode) + (unless markdown-live-preview-currently-exporting + (if (buffer-live-p markdown-live-preview-buffer) + (markdown-live-preview-export) + (markdown-display-buffer-other-window + (markdown-live-preview-export)))))) + +(defun markdown-live-preview-remove-on-kill () + (cond ((and (derived-mode-p 'markdown-mode) + markdown-live-preview-mode) + (markdown-live-preview-remove)) + (markdown-live-preview-source-buffer + (with-current-buffer markdown-live-preview-source-buffer + (setq markdown-live-preview-buffer nil)) + (setq markdown-live-preview-source-buffer nil)))) + +(defun markdown-live-preview-switch-to-output () + "Turn on `markdown-live-preview-mode' and switch to output buffer. +The output buffer is opened in another window." + (interactive) + (if markdown-live-preview-mode + (markdown-display-buffer-other-window (markdown-live-preview-export))) + (markdown-live-preview-mode)) + +(defun markdown-live-preview-re-export () + "Re-export the current live previewed content. +If the current buffer is a buffer displaying the exported version of a +`markdown-live-preview-mode' buffer, call `markdown-live-preview-export' and +update this buffer's contents." + (interactive) + (when markdown-live-preview-source-buffer + (with-current-buffer markdown-live-preview-source-buffer + (markdown-live-preview-export)))) + +(defun markdown-open () + "Open file for the current buffer with `markdown-open-command'." + (interactive) + (unless markdown-open-command + (user-error "Variable `markdown-open-command' must be set")) + (if (stringp markdown-open-command) + (if (not buffer-file-name) + (user-error "Must be visiting a file") + (save-buffer) + (let ((exit-code (call-process markdown-open-command nil nil nil + buffer-file-name))) + ;; The exit code can be a signal description string, so don’t use ‘=’ + ;; or ‘zerop’. + (unless (eq exit-code 0) + (user-error "%s failed with exit code %s" + markdown-open-command exit-code)))) + (funcall markdown-open-command)) + nil) + +(defun markdown-kill-ring-save () + "Run Markdown on file and store output in the kill ring." + (interactive) + (save-window-excursion + (markdown) + (with-current-buffer markdown-output-buffer-name + (kill-ring-save (point-min) (point-max))))) + + +;;; Links ===================================================================== + +(defun markdown-backward-to-link-start () + "Backward link start position if current position is in link title." + ;; Issue #305 + (when (eq (get-text-property (point) 'face) 'markdown-link-face) + (skip-chars-backward "^[") + (forward-char -1))) + +(defun markdown-link-p () + "Return non-nil when `point' is at a non-wiki link. +See `markdown-wiki-link-p' for more information." + (save-excursion + (let ((case-fold-search nil)) + (when (and (not (markdown-wiki-link-p)) (not (markdown-code-block-at-point-p))) + (markdown-backward-to-link-start) + (or (thing-at-point-looking-at markdown-regex-link-inline) + (thing-at-point-looking-at markdown-regex-link-reference) + (thing-at-point-looking-at markdown-regex-uri) + (thing-at-point-looking-at markdown-regex-angle-uri)))))) + +(defun markdown-link-at-pos (pos) + "Return properties of link or image at position POS. +Value is a list of elements describing the link: + 0. beginning position + 1. end position + 2. link text + 3. URL + 4. reference label + 5. title text + 6. bang (nil or \"!\")" + (save-excursion + (goto-char pos) + (markdown-backward-to-link-start) + (let (begin end text url reference title bang) + (cond + ;; Inline image or link at point. + ((thing-at-point-looking-at markdown-regex-link-inline) + (setq bang (match-string-no-properties 1) + begin (match-beginning 0) + text (match-string-no-properties 3) + url (match-string-no-properties 6)) + ;; consider nested parentheses + ;; if link target contains parentheses, (match-end 0) isn't correct end position of the link + (let* ((close-pos (scan-sexps (match-beginning 5) 1)) + (destination-part (string-trim (buffer-substring-no-properties (1+ (match-beginning 5)) (1- close-pos))))) + (setq end close-pos) + ;; A link can contain spaces if it is wrapped with angle brackets + (cond ((string-match "\\`<\\(.+\\)>\\'" destination-part) + (setq url (match-string-no-properties 1 destination-part))) + ((string-match "\\([^ ]+\\)\\s-+\\(.+\\)" destination-part) + (setq url (match-string-no-properties 1 destination-part) + title (substring (match-string-no-properties 2 destination-part) 1 -1))) + (t (setq url destination-part))) + (setq url (url-unhex-string url)))) + ;; Reference link at point. + ((thing-at-point-looking-at markdown-regex-link-reference) + (setq bang (match-string-no-properties 1) + begin (match-beginning 0) + end (match-end 0) + text (match-string-no-properties 3)) + (when (char-equal (char-after (match-beginning 5)) ?\[) + (setq reference (match-string-no-properties 6)))) + ;; Angle bracket URI at point. + ((thing-at-point-looking-at markdown-regex-angle-uri) + (setq begin (match-beginning 0) + end (match-end 0) + url (match-string-no-properties 2))) + ;; Plain URI at point. + ((thing-at-point-looking-at markdown-regex-uri) + (setq begin (match-beginning 0) + end (match-end 0) + url (match-string-no-properties 1)))) + (list begin end text url reference title bang)))) + +(defun markdown-link-url () + "Return the URL part of the regular (non-wiki) link at point. +Works with both inline and reference style links, and with images. +If point is not at a link or the link reference is not defined +returns nil." + (let* ((values (markdown-link-at-pos (point))) + (text (nth 2 values)) + (url (nth 3 values)) + (ref (nth 4 values))) + (or url (and ref (car (markdown-reference-definition + (downcase (if (string= ref "") text ref)))))))) + +(defun markdown--browse-url (url) + (let* ((struct (url-generic-parse-url url)) + (full (url-fullness struct)) + (file url)) + ;; Parse URL, determine fullness, strip query string + (setq file (car (url-path-and-query struct))) + ;; Open full URLs in browser, files in Emacs + (if full + (browse-url url) + (when (and file (> (length file) 0)) + (let ((link-file (funcall markdown-translate-filename-function file))) + (if (and markdown-open-image-command (string-match-p (image-file-name-regexp) link-file)) + (if (functionp markdown-open-image-command) + (funcall markdown-open-image-command link-file) + (process-file markdown-open-image-command nil nil nil link-file)) + (find-file link-file))))))) + +(defun markdown-follow-link-at-point (&optional event) + "Open the non-wiki link at point or EVENT. +If the link is a complete URL, open in browser with `browse-url'. +Otherwise, open with `find-file' after stripping anchor and/or query string. +Translate filenames using `markdown-filename-translate-function'." + (interactive (list last-command-event)) + (if event (posn-set-point (event-start event))) + (if (markdown-link-p) + (or (run-hook-with-args-until-success 'markdown-follow-link-functions (markdown-link-url)) + (markdown--browse-url (markdown-link-url))) + (user-error "Point is not at a Markdown link or URL"))) + +(defun markdown-fontify-inline-links (last) + "Add text properties to next inline link from point to LAST." + (when (markdown-match-generic-links last nil) + (let* ((link-start (match-beginning 3)) + (link-end (match-end 3)) + (url-start (match-beginning 6)) + (url-end (match-end 6)) + (url (match-string-no-properties 6)) + (title-start (match-beginning 7)) + (title-end (match-end 7)) + (title (match-string-no-properties 7)) + ;; Markup part + (mp (list 'invisible 'markdown-markup + 'rear-nonsticky t + 'font-lock-multiline t)) + ;; Link part (without face) + (lp (list 'keymap markdown-mode-mouse-map + 'mouse-face 'markdown-highlight-face + 'font-lock-multiline t + 'help-echo (if title (concat title "\n" url) url))) + ;; URL part + (up (list 'keymap markdown-mode-mouse-map + 'invisible 'markdown-markup + 'mouse-face 'markdown-highlight-face + 'font-lock-multiline t)) + ;; URL composition character + (url-char (markdown--first-displayable markdown-url-compose-char)) + ;; Title part + (tp (list 'invisible 'markdown-markup + 'font-lock-multiline t))) + (dolist (g '(1 2 4 5 8)) + (when (match-end g) + (add-text-properties (match-beginning g) (match-end g) mp) + (add-face-text-property (match-beginning g) (match-end g) 'markdown-markup-face))) + ;; Preserve existing faces applied to link part (e.g., inline code) + (when link-start + (add-text-properties link-start link-end lp) + (add-face-text-property link-start link-end 'markdown-link-face)) + (when url-start + (add-text-properties url-start url-end up) + (add-face-text-property url-start url-end 'markdown-url-face)) + (when title-start + (add-text-properties url-end title-end tp) + (add-face-text-property url-end title-end 'markdown-link-title-face)) + (when (and markdown-hide-urls url-start) + (compose-region url-start (or title-end url-end) url-char)) + t))) + +(defun markdown-fontify-reference-links (last) + "Add text properties to next reference link from point to LAST." + (when (markdown-match-generic-links last t) + (let* ((link-start (match-beginning 3)) + (link-end (match-end 3)) + (ref-start (match-beginning 6)) + (ref-end (match-end 6)) + ;; Markup part + (mp (list 'invisible 'markdown-markup + 'rear-nonsticky t + 'font-lock-multiline t)) + ;; Link part + (lp (list 'keymap markdown-mode-mouse-map + 'mouse-face 'markdown-highlight-face + 'font-lock-multiline t + 'help-echo (lambda (_ __ pos) + (save-match-data + (save-excursion + (goto-char pos) + (or (markdown-link-url) + "Undefined reference")))))) + ;; URL composition character + (url-char (markdown--first-displayable markdown-url-compose-char)) + ;; Reference part + (rp (list 'invisible 'markdown-markup + 'font-lock-multiline t))) + (dolist (g '(1 2 4 5 8)) + (when (match-end g) + (add-text-properties (match-beginning g) (match-end g) mp) + (add-face-text-property (match-beginning g) (match-end g) 'markdown-markup-face))) + (when link-start + (add-text-properties link-start link-end lp) + (add-face-text-property link-start link-end 'markdown-link-face)) + (when ref-start + (add-text-properties ref-start ref-end rp) + (add-face-text-property ref-start ref-end 'markdown-reference-face) + (when (and markdown-hide-urls (> (- ref-end ref-start) 2)) + (compose-region ref-start ref-end url-char))) + t))) + +(defun markdown-fontify-angle-uris (last) + "Add text properties to angle URIs from point to LAST." + (when (markdown-match-angle-uris last) + (let* ((url-start (match-beginning 2)) + (url-end (match-end 2)) + ;; Markup part + (mp (list 'face 'markdown-markup-face + 'invisible 'markdown-markup + 'rear-nonsticky t + 'font-lock-multiline t)) + ;; URI part + (up (list 'keymap markdown-mode-mouse-map + 'face 'markdown-plain-url-face + 'mouse-face 'markdown-highlight-face + 'font-lock-multiline t))) + (dolist (g '(1 3)) + (add-text-properties (match-beginning g) (match-end g) mp)) + (add-text-properties url-start url-end up) + t))) + +(defun markdown-fontify-plain-uris (last) + "Add text properties to plain URLs from point to LAST." + (when (markdown-match-plain-uris last) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (props (list 'keymap markdown-mode-mouse-map + 'face 'markdown-plain-url-face + 'mouse-face 'markdown-highlight-face + 'rear-nonsticky t + 'font-lock-multiline t))) + (add-text-properties start end props) + t))) + +(defun markdown-toggle-url-hiding (&optional arg) + "Toggle the display or hiding of URLs. +With a prefix argument ARG, enable URL hiding if ARG is positive, +and disable it otherwise." + (interactive (list (or current-prefix-arg 'toggle))) + (setq markdown-hide-urls + (if (eq arg 'toggle) + (not markdown-hide-urls) + (> (prefix-numeric-value arg) 0))) + (when (called-interactively-p 'interactive) + (message "markdown-mode URL hiding %s" (if markdown-hide-urls "enabled" "disabled"))) + (markdown-reload-extensions)) + + +;;; Wiki Links ================================================================ + +(defun markdown-wiki-link-p () + "Return non-nil if wiki links are enabled and `point' is at a true wiki link. +A true wiki link name matches `markdown-regex-wiki-link' but does +not match the current file name after conversion. This modifies +the data returned by `match-data'. Note that the potential wiki +link name must be available via `match-string'." + (when markdown-enable-wiki-links + (let ((case-fold-search nil)) + (and (thing-at-point-looking-at markdown-regex-wiki-link) + (not (markdown-code-block-at-point-p)) + (or (not buffer-file-name) + (not (string-equal (buffer-file-name) + (markdown-convert-wiki-link-to-filename + (markdown-wiki-link-link))))))))) + +(defun markdown-wiki-link-link () + "Return the link part of the wiki link using current match data. +The location of the link component depends on the value of +`markdown-wiki-link-alias-first'." + (if markdown-wiki-link-alias-first + (or (match-string-no-properties 5) (match-string-no-properties 3)) + (match-string-no-properties 3))) + +(defun markdown-wiki-link-alias () + "Return the alias or text part of the wiki link using current match data. +The location of the alias component depends on the value of +`markdown-wiki-link-alias-first'." + (if markdown-wiki-link-alias-first + (match-string-no-properties 3) + (or (match-string-no-properties 5) (match-string-no-properties 3)))) + +(defun markdown--wiki-link-search-types () + (let ((ret (and markdown-wiki-link-search-type + (cl-copy-list markdown-wiki-link-search-type)))) + (when (and markdown-wiki-link-search-subdirectories + (not (memq 'sub-directories markdown-wiki-link-search-type))) + (push 'sub-directories ret)) + (when (and markdown-wiki-link-search-parent-directories + (not (memq 'parent-directories markdown-wiki-link-search-type))) + (push 'parent-directories ret)) + ret)) + +(defun markdown--project-root () + (or (cl-loop for dir in '(".git" ".hg" ".svn") + when (locate-dominating-file default-directory dir) + return it) + (progn + (require 'project) + (let ((project (project-current t))) + (with-no-warnings + (if (fboundp 'project-root) + (project-root project) + (car (project-roots project)))))))) + +(defun markdown-convert-wiki-link-to-filename (name) + "Generate a filename from the wiki link NAME. +Spaces in NAME are replaced with `markdown-link-space-sub-char'. +When in `gfm-mode', follow GitHub's conventions where [[Test Test]] +and [[test test]] both map to Test-test.ext. Look in the current +directory first, then in subdirectories if +`markdown-wiki-link-search-subdirectories' is non-nil, and then +in parent directories if +`markdown-wiki-link-search-parent-directories' is non-nil." + (save-match-data + ;; This function must not overwrite match data(PR #590) + (let* ((basename (replace-regexp-in-string + "[[:space:]\n]" markdown-link-space-sub-char name)) + (basename (if (derived-mode-p 'gfm-mode) + (concat (upcase (substring basename 0 1)) + (downcase (substring basename 1 nil))) + basename)) + (search-types (markdown--wiki-link-search-types)) + directory extension default candidates dir) + (when buffer-file-name + (setq directory (file-name-directory buffer-file-name) + extension (file-name-extension buffer-file-name))) + (setq default (concat basename + (when extension (concat "." extension)))) + (cond + ;; Look in current directory first. + ((or (null buffer-file-name) + (file-exists-p default)) + default) + ;; Possibly search in subdirectories, next. + ((and (memq 'sub-directories search-types) + (setq candidates + (directory-files-recursively + directory (concat "^" default "$")))) + (car candidates)) + ;; Possibly search in parent directories as a last resort. + ((and (memq 'parent-directories search-types) + (setq dir (locate-dominating-file directory default))) + (concat dir default)) + ((and (memq 'project search-types) + (setq candidates + (directory-files-recursively + (markdown--project-root) (concat "^" default "$")))) + (car candidates)) + ;; If nothing is found, return default in current directory. + (t default))))) + +(defun markdown-follow-wiki-link (name &optional other) + "Follow the wiki link NAME. +Convert the name to a file name and call `find-file'. Ensure that +the new buffer remains in `markdown-mode'. Open the link in another +window when OTHER is non-nil." + (let ((filename (markdown-convert-wiki-link-to-filename name)) + (wp (when buffer-file-name + (file-name-directory buffer-file-name)))) + (if (not wp) + (user-error "Must be visiting a file") + (when other (other-window 1)) + (let ((default-directory wp)) + (find-file filename))) + (unless (derived-mode-p 'markdown-mode) + (markdown-mode)))) + +(defun markdown-follow-wiki-link-at-point (&optional arg) + "Find Wiki Link at point. +With prefix argument ARG, open the file in other window. +See `markdown-wiki-link-p' and `markdown-follow-wiki-link'." + (interactive "P") + (if (markdown-wiki-link-p) + (markdown-follow-wiki-link (markdown-wiki-link-link) arg) + (user-error "Point is not at a Wiki Link"))) + +(defun markdown-highlight-wiki-link (from to face) + "Highlight the wiki link in the region between FROM and TO using FACE." + (put-text-property from to 'font-lock-face face)) + +(defun markdown-unfontify-region-wiki-links (from to) + "Remove wiki link faces from the region specified by FROM and TO." + (interactive "*r") + (let ((modified (buffer-modified-p))) + (remove-text-properties from to '(font-lock-face markdown-link-face)) + (remove-text-properties from to '(font-lock-face markdown-missing-link-face)) + ;; remove-text-properties marks the buffer modified in emacs 24.3, + ;; undo that if it wasn't originally marked modified + (set-buffer-modified-p modified))) + +(defun markdown-fontify-region-wiki-links (from to) + "Search region given by FROM and TO for wiki links and fontify them. +If a wiki link is found check to see if the backing file exists +and highlight accordingly." + (goto-char from) + (save-match-data + (while (re-search-forward markdown-regex-wiki-link to t) + (when (not (markdown-code-block-at-point-p)) + (let ((highlight-beginning (match-beginning 1)) + (highlight-end (match-end 1)) + (file-name + (markdown-convert-wiki-link-to-filename + (markdown-wiki-link-link)))) + (if (condition-case nil (file-exists-p file-name) (error nil)) + (markdown-highlight-wiki-link + highlight-beginning highlight-end 'markdown-link-face) + (markdown-highlight-wiki-link + highlight-beginning highlight-end 'markdown-missing-link-face))))))) + +(defun markdown-extend-changed-region (from to) + "Extend region given by FROM and TO so that we can fontify all links. +The region is extended to the first newline before and the first +newline after." + ;; start looking for the first new line before 'from + (goto-char from) + (re-search-backward "\n" nil t) + (let ((new-from (point-min)) + (new-to (point-max))) + (if (not (= (point) from)) + (setq new-from (point))) + ;; do the same thing for the first new line after 'to + (goto-char to) + (re-search-forward "\n" nil t) + (if (not (= (point) to)) + (setq new-to (point))) + (cl-values new-from new-to))) + +(defun markdown-check-change-for-wiki-link (from to) + "Check region between FROM and TO for wiki links and re-fontify as needed." + (interactive "*r") + (let* ((modified (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t) + deactivate-mark + buffer-file-truename) + (unwind-protect + (save-excursion + (save-match-data + (save-restriction + (cursor-intangible-mode +1) ;; inhibit-point-motion-hooks is obsoleted since Emacs 29 + ;; Extend the region to fontify so that it starts + ;; and ends at safe places. + (cl-multiple-value-bind (new-from new-to) + (markdown-extend-changed-region from to) + (goto-char new-from) + ;; Only refontify when the range contains text with a + ;; wiki link face or if the wiki link regexp matches. + (when (or (markdown-range-property-any + new-from new-to 'font-lock-face + '(markdown-link-face markdown-missing-link-face)) + (re-search-forward + markdown-regex-wiki-link new-to t)) + ;; Unfontify existing fontification (start from scratch) + (markdown-unfontify-region-wiki-links new-from new-to) + ;; Now do the fontification. + (markdown-fontify-region-wiki-links new-from new-to)))))) + (cursor-intangible-mode -1) + (and (not modified) + (buffer-modified-p) + (set-buffer-modified-p nil))))) + +(defun markdown-check-change-for-wiki-link-after-change (from to _) + "Check region between FROM and TO for wiki links and re-fontify as needed. +Designed to be used with the `after-change-functions' hook." + (markdown-check-change-for-wiki-link from to)) + +(defun markdown-fontify-buffer-wiki-links () + "Refontify all wiki links in the buffer." + (interactive) + (markdown-check-change-for-wiki-link (point-min) (point-max))) + +(defun markdown-toggle-wiki-links (&optional arg) + "Toggle support for wiki links. +With a prefix argument ARG, enable wiki link support if ARG is positive, +and disable it otherwise." + (interactive (list (or current-prefix-arg 'toggle))) + (setq markdown-enable-wiki-links + (if (eq arg 'toggle) + (not markdown-enable-wiki-links) + (> (prefix-numeric-value arg) 0))) + (when (called-interactively-p 'interactive) + (message "markdown-mode wiki link support %s" (if markdown-enable-wiki-links "enabled" "disabled"))) + (markdown-reload-extensions)) + +(defun markdown-setup-wiki-link-hooks () + "Add or remove hooks for fontifying wiki links. +These are only enabled when `markdown-wiki-link-fontify-missing' is non-nil." + ;; Anytime text changes make sure it gets fontified correctly + (if (and markdown-enable-wiki-links + markdown-wiki-link-fontify-missing) + (add-hook 'after-change-functions + #'markdown-check-change-for-wiki-link-after-change t t) + (remove-hook 'after-change-functions + #'markdown-check-change-for-wiki-link-after-change t)) + ;; If we left the buffer there is a really good chance we were + ;; creating one of the wiki link documents. Make sure we get + ;; refontified when we come back. + (if (and markdown-enable-wiki-links + markdown-wiki-link-fontify-missing) + (progn + (add-hook 'window-configuration-change-hook + #'markdown-fontify-buffer-wiki-links t t) + (markdown-fontify-buffer-wiki-links)) + (remove-hook 'window-configuration-change-hook + #'markdown-fontify-buffer-wiki-links t) + (markdown-unfontify-region-wiki-links (point-min) (point-max)))) + + +;;; Following & Doing ========================================================= + +(defun markdown-follow-thing-at-point (arg) + "Follow thing at point if possible, such as a reference link or wiki link. +Opens inline and reference links in a browser. Opens wiki links +to other files in the current window, or the another window if +ARG is non-nil. +See `markdown-follow-link-at-point' and +`markdown-follow-wiki-link-at-point'." + (interactive "P") + (cond ((markdown-link-p) + (markdown-follow-link-at-point)) + ((markdown-wiki-link-p) + (markdown-follow-wiki-link-at-point arg)) + (t + (let* ((values (markdown-link-at-pos (point))) + (url (nth 3 values))) + (unless url + (user-error "Nothing to follow at point")) + (markdown--browse-url url))))) + +(defun markdown-do () + "Do something sensible based on context at point. +Jumps between reference links and definitions; between footnote +markers and footnote text." + (interactive) + (cond + ;; Footnote definition + ((markdown-footnote-text-positions) + (markdown-footnote-return)) + ;; Footnote marker + ((markdown-footnote-marker-positions) + (markdown-footnote-goto-text)) + ;; Reference link + ((thing-at-point-looking-at markdown-regex-link-reference) + (markdown-reference-goto-definition)) + ;; Reference definition + ((thing-at-point-looking-at markdown-regex-reference-definition) + (markdown-reference-goto-link (match-string-no-properties 2))) + ;; Link + ((or (markdown-link-p) (markdown-wiki-link-p)) + (markdown-follow-thing-at-point nil)) + ;; GFM task list item + ((markdown-gfm-task-list-item-at-point) + (markdown-toggle-gfm-checkbox)) + ;; Align table + ((markdown-table-at-point-p) + (call-interactively #'markdown-table-align)) + ;; Otherwise + (t + (markdown-insert-gfm-checkbox)))) + + +;;; Miscellaneous ============================================================= + +(defun markdown-compress-whitespace-string (str) + "Compress whitespace in STR and return result. +Leading and trailing whitespace is removed. Sequences of multiple +spaces, tabs, and newlines are replaced with single spaces." + (replace-regexp-in-string "\\(^[ \t\n]+\\|[ \t\n]+$\\)" "" + (replace-regexp-in-string "[ \t\n]+" " " str))) + +(defun markdown--substitute-command-keys (string) + "Like `substitute-command-keys' but, but prefers control characters. +First pass STRING to `substitute-command-keys' and then +substitute `C-i` for `TAB` and `C-m` for `RET`." + (replace-regexp-in-string + "\\<TAB\\>" "C-i" + (replace-regexp-in-string + "\\<RET\\>" "C-m" (substitute-command-keys string) t) t)) + +(defun markdown-line-number-at-pos (&optional pos) + "Return (narrowed) buffer line number at position POS. +If POS is nil, use current buffer location. +This is an exact copy of `line-number-at-pos' for use in emacs21." + (let ((opoint (or pos (point))) start) + (save-excursion + (goto-char (point-min)) + (setq start (point)) + (goto-char opoint) + (forward-line 0) + (1+ (count-lines start (point)))))) + +(defun markdown-inside-link-p () + "Return t if point is within a link." + (save-match-data + (thing-at-point-looking-at (markdown-make-regex-link-generic)))) + +(defun markdown-line-is-reference-definition-p () + "Return whether the current line is a (non-footnote) reference definition." + (save-excursion + (move-beginning-of-line 1) + (and (looking-at-p markdown-regex-reference-definition) + (not (looking-at-p "[ \t]*\\[^"))))) + +(defun markdown-adaptive-fill-function () + "Return prefix for filling paragraph or nil if not determined." + (cond + ;; List item inside blockquote + ((looking-at "^[ \t]*>[ \t]*\\(\\(?:[0-9]+\\|#\\)\\.\\|[*+:-]\\)[ \t]+") + (replace-regexp-in-string + "[0-9\\.*+-]" " " (match-string-no-properties 0))) + ;; Blockquote + ((looking-at markdown-regex-blockquote) + (buffer-substring-no-properties (match-beginning 0) (match-end 2))) + ;; List items + ((looking-at markdown-regex-list) + (match-string-no-properties 0)) + ;; Footnote definition + ((looking-at-p markdown-regex-footnote-definition) + " ") ; four spaces + ;; No match + (t nil))) + +(defun markdown-fill-paragraph (&optional justify) + "Fill paragraph at or after point. +This function is like \\[fill-paragraph], but it skips Markdown +code blocks. If the point is in a code block, or just before one, +do not fill. Otherwise, call `fill-paragraph' as usual. If +JUSTIFY is non-nil, justify text as well. Since this function +handles filling itself, it always returns t so that +`fill-paragraph' doesn't run." + (interactive "P") + (unless (or (markdown-code-block-at-point-p) + (save-excursion + (back-to-indentation) + (skip-syntax-forward "-") + (markdown-code-block-at-point-p))) + (let ((fill-prefix (save-excursion + (goto-char (line-beginning-position)) + (when (looking-at "\\([ \t]*>[ \t]*\\(?:>[ \t]*\\)+\\)") + (match-string-no-properties 1))))) + (fill-paragraph justify))) + t) + +(defun markdown-fill-forward-paragraph (&optional arg) + "Function used by `fill-paragraph' to move over ARG paragraphs. +This is a `fill-forward-paragraph-function' for `markdown-mode'. +It is called with a single argument specifying the number of +paragraphs to move. Just like `forward-paragraph', it should +return the number of paragraphs left to move." + (or arg (setq arg 1)) + (if (> arg 0) + ;; With positive ARG, move across ARG non-code-block paragraphs, + ;; one at a time. When passing a code block, don't decrement ARG. + (while (and (not (eobp)) + (> arg 0) + (= (forward-paragraph 1) 0) + (or (markdown-code-block-at-pos (line-beginning-position 0)) + (setq arg (1- arg))))) + ;; Move backward by one paragraph with negative ARG (always -1). + (let ((start (point))) + (setq arg (forward-paragraph arg)) + (while (and (not (eobp)) + (progn (move-to-left-margin) (not (eobp))) + (looking-at-p paragraph-separate)) + (forward-line 1)) + (cond + ;; Move point past whitespace following list marker. + ((looking-at markdown-regex-list) + (goto-char (match-end 0))) + ;; Move point past whitespace following pipe at beginning of line + ;; to handle Pandoc line blocks. + ((looking-at "^|\\s-*") + (goto-char (match-end 0))) + ;; Return point if the paragraph passed was a code block. + ((markdown-code-block-at-pos (line-beginning-position 2)) + (goto-char start))))) + arg) + +(defun markdown--inhibit-electric-quote () + "Function added to `electric-quote-inhibit-functions'. +Return non-nil if the quote has been inserted inside a code block +or span." + (let ((pos (1- (point)))) + (or (markdown-inline-code-at-pos pos) + (markdown-code-block-at-pos pos)))) + + +;;; Extension Framework ======================================================= + +(defun markdown-reload-extensions () + "Check settings, update font-lock keywords and hooks, and re-fontify buffer." + (interactive) + (when (derived-mode-p 'markdown-mode) + ;; Refontify buffer + (font-lock-flush) + ;; Add or remove hooks related to extensions + (markdown-setup-wiki-link-hooks))) + +(defun markdown-handle-local-variables () + "Run in `hack-local-variables-hook' to update font lock rules. +Checks to see if there is actually a ‘markdown-mode’ file local variable +before regenerating font-lock rules for extensions." + (when (or (assoc 'markdown-enable-wiki-links file-local-variables-alist) + (assoc 'markdown-enable-math file-local-variables-alist)) + (when (assoc 'markdown-enable-math file-local-variables-alist) + (markdown-toggle-math markdown-enable-math)) + (markdown-reload-extensions))) + + +;;; Math Support ============================================================== + +(defconst markdown-mode-font-lock-keywords-math + (list + ;; Equation reference (eq:foo) + '("\\((eq:\\)\\([[:alnum:]:_]+\\)\\()\\)" . ((1 markdown-markup-face) + (2 markdown-reference-face) + (3 markdown-markup-face))) + ;; Equation reference \eqref{foo} + '("\\(\\\\eqref{\\)\\([[:alnum:]:_]+\\)\\(}\\)" . ((1 markdown-markup-face) + (2 markdown-reference-face) + (3 markdown-markup-face)))) + "Font lock keywords to add and remove when toggling math support.") + +(defun markdown-toggle-math (&optional arg) + "Toggle support for inline and display LaTeX math expressions. +With a prefix argument ARG, enable math mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil." + (interactive (list (or current-prefix-arg 'toggle))) + (setq markdown-enable-math + (if (eq arg 'toggle) + (not markdown-enable-math) + (> (prefix-numeric-value arg) 0))) + (if markdown-enable-math + (font-lock-add-keywords + 'markdown-mode markdown-mode-font-lock-keywords-math) + (font-lock-remove-keywords + 'markdown-mode markdown-mode-font-lock-keywords-math)) + (when (called-interactively-p 'interactive) + (message "markdown-mode math support %s" (if markdown-enable-math "enabled" "disabled"))) + (markdown-reload-extensions)) + + +;;; GFM Checkboxes ============================================================ + +(define-button-type 'markdown-gfm-checkbox-button + 'follow-link t + 'face 'markdown-gfm-checkbox-face + 'mouse-face 'markdown-highlight-face + 'action #'markdown-toggle-gfm-checkbox-button) + +(defun markdown-gfm-task-list-item-at-point (&optional bounds) + "Return non-nil if there is a GFM task list item at the point. +Optionally, the list item BOUNDS may be given if available, as +returned by `markdown-cur-list-item-bounds'. When a task list item +is found, the return value is the same value returned by +`markdown-cur-list-item-bounds'." + (unless bounds + (setq bounds (markdown-cur-list-item-bounds))) + (> (length (nth 5 bounds)) 0)) + +(defun markdown-insert-gfm-checkbox () + "Add GFM checkbox at point. +Returns t if added. +Returns nil if non-applicable." + (interactive) + (let ((bounds (markdown-cur-list-item-bounds))) + (if bounds + (unless (cl-sixth bounds) + (let ((pos (+ (cl-first bounds) (cl-fourth bounds))) + (markup "[ ] ")) + (if (< pos (point)) + (save-excursion + (goto-char pos) + (insert markup)) + (goto-char pos) + (insert markup)) + (syntax-propertize (+ (cl-second bounds) 4)) + t)) + (unless (save-excursion + (back-to-indentation) + (or (markdown-list-item-at-point-p) + (markdown-heading-at-point) + (markdown-in-comment-p) + (markdown-code-block-at-point-p))) + (let ((pos (save-excursion + (back-to-indentation) + (point))) + (markup (concat (or (save-excursion + (beginning-of-line 0) + (cl-fifth (markdown-cur-list-item-bounds))) + markdown-unordered-list-item-prefix) + "[ ] "))) + (if (< pos (point)) + (save-excursion + (goto-char pos) + (insert markup)) + (goto-char pos) + (insert markup)) + (syntax-propertize (line-end-position)) + t))))) + +(defun markdown-toggle-gfm-checkbox () + "Toggle GFM checkbox at point. +Returns the resulting status as a string, either \"[x]\" or \"[ ]\". +Returns nil if there is no task list item at the point." + (interactive) + (save-match-data + (save-excursion + (let ((bounds (markdown-cur-list-item-bounds))) + (when bounds + ;; Move to beginning of task list item + (goto-char (cl-first bounds)) + ;; Advance to column of first non-whitespace after marker + (forward-char (cl-fourth bounds)) + (cond ((looking-at "\\[ \\]") + (replace-match + (if markdown-gfm-uppercase-checkbox "[X]" "[x]") + nil t) + (match-string-no-properties 0)) + ((looking-at "\\[[xX]\\]") + (replace-match "[ ]" nil t) + (match-string-no-properties 0)))))))) + +(defun markdown-toggle-gfm-checkbox-button (button) + "Toggle GFM checkbox BUTTON on click." + (save-match-data + (save-excursion + (goto-char (button-start button)) + (markdown-toggle-gfm-checkbox)))) + +(defun markdown-make-gfm-checkboxes-buttons (start end) + "Make GFM checkboxes buttons in region between START and END." + (save-excursion + (goto-char start) + (let ((case-fold-search t)) + (save-excursion + (while (re-search-forward markdown-regex-gfm-checkbox end t) + (make-button (match-beginning 1) (match-end 1) + :type 'markdown-gfm-checkbox-button)))))) + +;; Called when any modification is made to buffer text. +(defun markdown-gfm-checkbox-after-change-function (beg end _) + "Add to `after-change-functions' to setup GFM checkboxes as buttons. +BEG and END are the limits of scanned region." + (save-excursion + (save-match-data + ;; Rescan between start of line from `beg' and start of line after `end'. + (markdown-make-gfm-checkboxes-buttons + (progn (goto-char beg) (beginning-of-line) (point)) + (progn (goto-char end) (forward-line 1) (point)))))) + +(defun markdown-remove-gfm-checkbox-overlays () + "Remove all GFM checkbox overlays in buffer." + (save-excursion + (save-restriction + (widen) + (remove-overlays nil nil 'face 'markdown-gfm-checkbox-face)))) + + +;;; Display inline image ====================================================== + +(defvar-local markdown-inline-image-overlays nil) + +(defun markdown-remove-inline-images () + "Remove inline image overlays from image links in the buffer. +This can be toggled with `markdown-toggle-inline-images' +or \\[markdown-toggle-inline-images]." + (interactive) + (mapc #'delete-overlay markdown-inline-image-overlays) + (setq markdown-inline-image-overlays nil) + (when (fboundp 'clear-image-cache) (clear-image-cache))) + +(defcustom markdown-display-remote-images nil + "If non-nil, download and display remote images. +See also `markdown-inline-image-overlays'. + +Only image URLs specified with a protocol listed in +`markdown-remote-image-protocols' are displayed." + :group 'markdown + :type 'boolean) + +(defcustom markdown-remote-image-protocols '("https") + "List of protocols to use to download remote images. +See also `markdown-display-remote-images'." + :group 'markdown + :type '(repeat string)) + +(defvar markdown--remote-image-cache + (make-hash-table :test 'equal) + "A map from URLs to image paths.") + +(defun markdown--get-remote-image (url) + "Retrieve the image path for a given URL." + (or (gethash url markdown--remote-image-cache) + (let ((dl-path (make-temp-file "markdown-mode--image"))) + (require 'url) + (url-copy-file url dl-path t) + (puthash url dl-path markdown--remote-image-cache)))) + +(defun markdown-display-inline-images () + "Add inline image overlays to image links in the buffer. +This can be toggled with `markdown-toggle-inline-images' +or \\[markdown-toggle-inline-images]." + (interactive) + (unless (display-images-p) + (error "Cannot show images")) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward markdown-regex-link-inline nil t) + (let* ((start (match-beginning 0)) + (imagep (match-beginning 1)) + (end (match-end 0)) + (file (match-string-no-properties 6))) + (when (and imagep + (not (zerop (length file)))) + (unless (file-exists-p file) + (let* ((download-file (funcall markdown-translate-filename-function file)) + (valid-url (ignore-errors + (member (downcase (url-type (url-generic-parse-url download-file))) + markdown-remote-image-protocols)))) + (if (and markdown-display-remote-images valid-url) + (setq file (markdown--get-remote-image download-file)) + (when (not valid-url) + ;; strip query parameter + (setq file (replace-regexp-in-string "?.+\\'" "" file)) + (unless (file-exists-p file) + (setq file (url-unhex-string file))))))) + (when (file-exists-p file) + (let* ((abspath (if (file-name-absolute-p file) + file + (concat default-directory file))) + (image + (cond ((and markdown-max-image-size + (image-type-available-p 'imagemagick)) + (create-image + abspath 'imagemagick nil + :max-width (car markdown-max-image-size) + :max-height (cdr markdown-max-image-size))) + (markdown-max-image-size + (create-image abspath nil nil + :max-width (car markdown-max-image-size) + :max-height (cdr markdown-max-image-size))) + (t (create-image abspath))))) + (when image + (let ((ov (make-overlay start end))) + (overlay-put ov 'display image) + (overlay-put ov 'face 'default) + (push ov markdown-inline-image-overlays))))))))))) + +(defun markdown-toggle-inline-images () + "Toggle inline image overlays in the buffer." + (interactive) + (if markdown-inline-image-overlays + (markdown-remove-inline-images) + (markdown-display-inline-images))) + + +;;; GFM Code Block Fontification ============================================== + +(defcustom markdown-fontify-code-blocks-natively nil + "When non-nil, fontify code in code blocks using the native major mode. +This only works for fenced code blocks where the language is +specified where we can automatically determine the appropriate +mode to use. The language to mode mapping may be customized by +setting the variable `markdown-code-lang-modes'." + :group 'markdown + :type 'boolean + :safe #'booleanp + :package-version '(markdown-mode . "2.3")) + +(defcustom markdown-fontify-code-block-default-mode nil + "Default mode to use to fontify code blocks. +This mode is used when automatic detection fails, such as for GFM +code blocks with no language specified." + :group 'markdown + :type '(choice function (const :tag "None" nil)) + :package-version '(markdown-mode . "2.4")) + +(defun markdown-toggle-fontify-code-blocks-natively (&optional arg) + "Toggle the native fontification of code blocks. +With a prefix argument ARG, enable if ARG is positive, +and disable otherwise." + (interactive (list (or current-prefix-arg 'toggle))) + (setq markdown-fontify-code-blocks-natively + (if (eq arg 'toggle) + (not markdown-fontify-code-blocks-natively) + (> (prefix-numeric-value arg) 0))) + (when (called-interactively-p 'interactive) + (message "markdown-mode native code block fontification %s" + (if markdown-fontify-code-blocks-natively "enabled" "disabled"))) + (markdown-reload-extensions)) + +;; This is based on `org-src-lang-modes' from org-src.el +(defcustom markdown-code-lang-modes + '(("ocaml" . tuareg-mode) ("elisp" . emacs-lisp-mode) ("ditaa" . artist-mode) + ("asymptote" . asy-mode) ("dot" . fundamental-mode) ("sqlite" . sql-mode) + ("calc" . fundamental-mode) ("C" . c-mode) ("cpp" . c++-mode) + ("C++" . c++-mode) ("screen" . shell-script-mode) ("shell" . sh-mode) + ("bash" . sh-mode)) + "Alist mapping languages to their major mode. +The key is the language name, the value is the major mode. For +many languages this is simple, but for language where this is not +the case, this variable provides a way to simplify things on the +user side. For example, there is no ocaml-mode in Emacs, but the +mode to use is `tuareg-mode'." + :group 'markdown + :type '(repeat + (cons + (string "Language name") + (symbol "Major mode"))) + :package-version '(markdown-mode . "2.3")) + +(defun markdown-get-lang-mode (lang) + "Return major mode that should be used for LANG. +LANG is a string, and the returned major mode is a symbol." + (cl-find-if + #'markdown--lang-mode-predicate + (nconc (list (cdr (assoc lang markdown-code-lang-modes)) + (cdr (assoc (downcase lang) markdown-code-lang-modes))) + (and (fboundp 'treesit-language-available-p) + (list (and (treesit-language-available-p (intern lang)) + (intern (concat lang "-ts-mode"))) + (and (treesit-language-available-p (intern (downcase lang))) + (intern (concat (downcase lang) "-ts-mode"))))) + (list + (intern (concat lang "-mode")) + (intern (concat (downcase lang) "-mode")))))) + +(defun markdown--lang-mode-predicate (mode) + (and mode + (fboundp mode) + (or + ;; https://github.com/jrblevin/markdown-mode/issues/787 + ;; major-mode-remap-alist was introduced at Emacs 29.1 + (cl-loop for pair in (bound-and-true-p major-mode-remap-alist) + for func = (cdr pair) + thereis (and (atom func) (eq mode func))) + ;; https://github.com/jrblevin/markdown-mode/issues/761 + (cl-loop for pair in auto-mode-alist + for func = (cdr pair) + thereis (and (atom func) (eq mode func)))))) + +(defun markdown-fontify-code-blocks-generic (matcher last) + "Add text properties to next code block from point to LAST. +Use matching function MATCHER." + (when (funcall matcher last) + (save-excursion + (save-match-data + (let* ((start (match-beginning 0)) + (end (match-end 0)) + ;; Find positions outside opening and closing backquotes. + (bol-prev (progn (goto-char start) + (if (bolp) (line-beginning-position 0) (line-beginning-position)))) + (eol-next (progn (goto-char end) + (if (bolp) (line-beginning-position 2) (line-beginning-position 3)))) + lang) + (if (and markdown-fontify-code-blocks-natively + (or (setq lang (markdown-code-block-lang)) + markdown-fontify-code-block-default-mode)) + (markdown-fontify-code-block-natively lang start end) + (add-text-properties start end '(face markdown-pre-face))) + ;; Set background for block as well as opening and closing lines. + (font-lock-append-text-property + bol-prev eol-next 'face 'markdown-code-face) + ;; Set invisible property for lines before and after, including newline. + (add-text-properties bol-prev start '(invisible markdown-markup)) + (add-text-properties end eol-next '(invisible markdown-markup))))) + t)) + +(defun markdown-fontify-gfm-code-blocks (last) + "Add text properties to next GFM code block from point to LAST." + (markdown-fontify-code-blocks-generic 'markdown-match-gfm-code-blocks last)) + +(defun markdown-fontify-fenced-code-blocks (last) + "Add text properties to next tilde fenced code block from point to LAST." + (markdown-fontify-code-blocks-generic 'markdown-match-fenced-code-blocks last)) + +;; Based on `org-src-font-lock-fontify-block' from org-src.el. +(defun markdown-fontify-code-block-natively (lang start end) + "Fontify given GFM or fenced code block. +This function is called by Emacs for automatic fontification when +`markdown-fontify-code-blocks-natively' is non-nil. LANG is the +language used in the block. START and END specify the block +position." + (let ((lang-mode (if lang (markdown-get-lang-mode lang) + markdown-fontify-code-block-default-mode))) + (when (fboundp lang-mode) + (let ((string (buffer-substring-no-properties start end)) + (modified (buffer-modified-p)) + (markdown-buffer (current-buffer)) pos next) + (remove-text-properties start end '(face nil)) + (with-current-buffer + (get-buffer-create + (format " *markdown-code-fontification:%s*" (symbol-name lang-mode))) + ;; Make sure that modification hooks are not inhibited in + ;; the org-src-fontification buffer in case we're called + ;; from `jit-lock-function' (Bug#25132). + (let ((inhibit-modification-hooks nil)) + (delete-region (point-min) (point-max)) + (insert string " ")) ;; so there's a final property change + (unless (eq major-mode lang-mode) (funcall lang-mode)) + (font-lock-ensure) + (setq pos (point-min)) + (while (setq next (next-single-property-change pos 'face)) + (let ((val (get-text-property pos 'face))) + (when val + (put-text-property + (+ start (1- pos)) (1- (+ start next)) 'face + val markdown-buffer))) + (setq pos next))) + (add-text-properties + start end + '(font-lock-fontified t fontified t font-lock-multiline t)) + (set-buffer-modified-p modified))))) + +(require 'edit-indirect nil t) +(defvar edit-indirect-guess-mode-function) +(defvar edit-indirect-after-commit-functions) + +(defun markdown--edit-indirect-after-commit-function (beg end) + "Corrective logic run on code block content from lines BEG to END. +Restores code block indentation from BEG to END, and ensures trailing newlines +at the END of code blocks." + ;; ensure trailing newlines + (goto-char end) + (unless (eq (char-before) ?\n) + (insert "\n")) + ;; restore code block indentation + (goto-char (- beg 1)) + (let ((block-indentation (current-indentation))) + (when (> block-indentation 0) + (indent-rigidly beg end block-indentation))) + (font-lock-ensure)) + +(defun markdown-edit-code-block () + "Edit Markdown code block in an indirect buffer." + (interactive) + (save-excursion + (if (fboundp 'edit-indirect-region) + (let* ((bounds (markdown-get-enclosing-fenced-block-construct)) + (begin (and bounds (not (null (nth 0 bounds))) (goto-char (nth 0 bounds)) (line-beginning-position 2))) + (end (and bounds(not (null (nth 1 bounds))) (goto-char (nth 1 bounds)) (line-beginning-position 1)))) + (if (and begin end) + (let* ((indentation (and (goto-char (nth 0 bounds)) (current-indentation))) + (lang (markdown-code-block-lang)) + (mode (or (and lang (markdown-get-lang-mode lang)) + markdown-edit-code-block-default-mode)) + (edit-indirect-guess-mode-function + (lambda (_parent-buffer _beg _end) + (funcall mode))) + (indirect-buf (edit-indirect-region begin end 'display-buffer))) + ;; reset `sh-shell' when indirect buffer + (when (and (not (member system-type '(ms-dos windows-nt))) + (member mode '(shell-script-mode sh-mode)) + (member lang (append + (mapcar (lambda (e) (symbol-name (car e))) + sh-ancestor-alist) + '("csh" "rc" "sh")))) + (with-current-buffer indirect-buf + (sh-set-shell lang))) + (when (> indentation 0) ;; un-indent in edit-indirect buffer + (with-current-buffer indirect-buf + (indent-rigidly (point-min) (point-max) (- indentation))))) + (user-error "Not inside a GFM or tilde fenced code block"))) + (when (y-or-n-p "Package edit-indirect needed to edit code blocks. Install it now? ") + (progn (package-refresh-contents) + (package-install 'edit-indirect) + (markdown-edit-code-block)))))) + + +;;; Table Editing ============================================================= + +;; These functions were originally adapted from `org-table.el'. + +;; General helper functions + +(defmacro markdown--with-gensyms (symbols &rest body) + (declare (debug (sexp body)) (indent 1)) + `(let ,(mapcar (lambda (s) + `(,s (make-symbol (concat "--" (symbol-name ',s))))) + symbols) + ,@body)) + +(defun markdown--split-string (string &optional separators) + "Splits STRING into substrings at SEPARATORS. +SEPARATORS is a regular expression. If nil it defaults to +`split-string-default-separators'. This version returns no empty +strings if there are matches at the beginning and end of string." + (let ((start 0) notfirst list) + (while (and (string-match + (or separators split-string-default-separators) + string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< (match-beginning 0) (length string))) + (setq notfirst t) + (or (eq (match-beginning 0) 0) + (and (eq (match-beginning 0) (match-end 0)) + (eq (match-beginning 0) start)) + (push (substring string start (match-beginning 0)) list)) + (setq start (match-end 0))) + (or (eq start (length string)) + (push (substring string start) list)) + (nreverse list))) + +(defun markdown--string-width (s) + "Return width of string S. +This version ignores characters with invisibility property +`markdown-markup'." + (let (b) + (when (or (eq t buffer-invisibility-spec) + (member 'markdown-markup buffer-invisibility-spec)) + (while (setq b (text-property-any + 0 (length s) + 'invisible 'markdown-markup s)) + (setq s (concat + (substring s 0 b) + (substring s (or (next-single-property-change + b 'invisible s) + (length s)))))))) + (string-width s)) + +(defun markdown--remove-invisible-markup (s) + "Remove Markdown markup from string S. +This version removes characters with invisibility property +`markdown-markup'." + (let (b) + (while (setq b (text-property-any + 0 (length s) + 'invisible 'markdown-markup s)) + (setq s (concat + (substring s 0 b) + (substring s (or (next-single-property-change + b 'invisible s) + (length s))))))) + s) + +;; Functions for maintaining tables + +(defvar markdown-table-at-point-p-function #'markdown--table-at-point-p + "Function to decide if point is inside a table. + +The indirection serves to differentiate between standard markdown +tables and gfm tables which are less strict about the markup.") + +(defconst markdown-table-line-regexp "^[ \t]*|" + "Regexp matching any line inside a table.") + +(defconst markdown-table-hline-regexp "^[ \t]*|[-:]" + "Regexp matching hline inside a table.") + +(defconst markdown-table-dline-regexp "^[ \t]*|[^-:]" + "Regexp matching dline inside a table.") + +(defun markdown-table-at-point-p () + "Return non-nil when point is inside a table." + (funcall markdown-table-at-point-p-function)) + +(defun markdown--table-at-point-p () + "Return non-nil when point is inside a table." + (save-excursion + (beginning-of-line) + (and (looking-at-p markdown-table-line-regexp) + (not (markdown-code-block-at-point-p))))) + +(defconst gfm-table-line-regexp "^.?*|" + "Regexp matching any line inside a table.") + +(defconst gfm-table-hline-regexp "^-+\\(|-\\)+" + "Regexp matching hline inside a table.") + +;; GFM simplified tables syntax is as follows: +;; - A header line for the column names, this is any text +;; separated by `|'. +;; - Followed by a string -|-|- ..., the number of dashes is optional +;; but must be higher than 1. The number of separators should match +;; the number of columns. +;; - Followed by the rows of data, which has the same format as the +;; header line. +;; Example: +;; +;; foo | bar +;; ------|--------- +;; bar | baz +;; bar | baz +(defun gfm--table-at-point-p () + "Return non-nil when point is inside a gfm-compatible table." + (or (markdown--table-at-point-p) + (save-excursion + (beginning-of-line) + (when (looking-at-p gfm-table-line-regexp) + ;; we might be at the first line of the table, check if the + ;; line below is the hline + (or (save-excursion + (forward-line 1) + (looking-at-p gfm-table-hline-regexp)) + ;; go up to find the header + (catch 'done + (while (looking-at-p gfm-table-line-regexp) + (cond + ((looking-at-p gfm-table-hline-regexp) + (throw 'done t)) + ((bobp) + (throw 'done nil))) + (forward-line -1)) + nil)))))) + +(defun markdown-table-hline-at-point-p () + "Return non-nil when point is on a hline in a table. +This function assumes point is on a table." + (save-excursion + (beginning-of-line) + (looking-at-p markdown-table-hline-regexp))) + +(defun markdown-table-begin () + "Find the beginning of the table and return its position. +This function assumes point is on a table." + (save-excursion + (while (and (not (bobp)) + (markdown-table-at-point-p)) + (forward-line -1)) + (unless (or (eobp) + (markdown-table-at-point-p)) + (forward-line 1)) + (point))) + +(defun markdown-table-end () + "Find the end of the table and return its position. +This function assumes point is on a table." + (save-excursion + (while (and (not (eobp)) + (markdown-table-at-point-p)) + (forward-line 1)) + (point))) + +(defun markdown-table-get-dline () + "Return index of the table data line at point. +This function assumes point is on a table." + (let ((pos (point)) (end (markdown-table-end)) (cnt 0)) + (save-excursion + (goto-char (markdown-table-begin)) + (while (and (re-search-forward + markdown-table-dline-regexp end t) + (setq cnt (1+ cnt)) + (< (line-end-position) pos)))) + cnt)) + +(defun markdown--thing-at-wiki-link (pos) + (when markdown-enable-wiki-links + (save-excursion + (save-match-data + (goto-char pos) + (thing-at-point-looking-at markdown-regex-wiki-link))))) + +(defun markdown-table-get-column () + "Return table column at point. +This function assumes point is on a table." + (let ((pos (point)) (cnt 0)) + (save-excursion + (beginning-of-line) + (while (search-forward "|" pos t) + (when (and (not (looking-back "\\\\|" (line-beginning-position))) + (not (markdown--thing-at-wiki-link (match-beginning 0)))) + (setq cnt (1+ cnt))))) + cnt)) + +(defun markdown-table-get-cell (&optional n) + "Return the content of the cell in column N of current row. +N defaults to column at point. This function assumes point is on +a table." + (and n (markdown-table-goto-column n)) + (skip-chars-backward "^|\n") (backward-char 1) + (if (looking-at "|[^|\r\n]*") + (let* ((pos (match-beginning 0)) + (val (buffer-substring (1+ pos) (match-end 0)))) + (goto-char (min (line-end-position) (+ 2 pos))) + ;; Trim whitespaces + (setq val (replace-regexp-in-string "\\`[ \t]+" "" val) + val (replace-regexp-in-string "[ \t]+\\'" "" val))) + (forward-char 1) "")) + +(defun markdown-table-goto-dline (n) + "Go to the Nth data line in the table at point. +Return t when the line exists, nil otherwise. This function +assumes point is on a table." + (goto-char (markdown-table-begin)) + (let ((end (markdown-table-end)) (cnt 0)) + (while (and (re-search-forward + markdown-table-dline-regexp end t) + (< (setq cnt (1+ cnt)) n))) + (= cnt n))) + +(defun markdown-table-goto-column (n &optional on-delim) + "Go to the Nth column in the table line at point. +With optional argument ON-DELIM, stop with point before the left +delimiter of the cell. If there are less than N cells, just go +beyond the last delimiter. This function assumes point is on a +table." + (beginning-of-line 1) + (when (> n 0) + (while (and (> n 0) (search-forward "|" (line-end-position) t)) + (when (and (not (looking-back "\\\\|" (line-beginning-position))) + (not (markdown--thing-at-wiki-link (match-beginning 0)))) + (cl-decf n))) + (if on-delim + (backward-char 1) + (when (looking-at " ") (forward-char 1))))) + +(defmacro markdown-table-save-cell (&rest body) + "Save cell at point, execute BODY and restore cell. +This function assumes point is on a table." + (declare (debug (body))) + (markdown--with-gensyms (line column) + `(let ((,line (copy-marker (line-beginning-position))) + (,column (markdown-table-get-column))) + (unwind-protect + (progn ,@body) + (goto-char ,line) + (markdown-table-goto-column ,column) + (set-marker ,line nil))))) + +(defun markdown-table-blank-line (s) + "Convert a table line S into a line with blank cells." + (if (string-match "^[ \t]*|-" s) + (setq s (mapconcat + (lambda (x) (if (member x '(?| ?+)) "|" " ")) + s "")) + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (when (re-search-forward "|" nil t) + (let ((cur (point)) + ret) + (while (re-search-forward "|" nil t) + (when (and (not (eql (char-before (match-beginning 0)) ?\\)) + (not (markdown--thing-at-wiki-link (match-beginning 0)))) + (push (make-string (- (match-beginning 0) cur) ? ) ret) + (setq cur (match-end 0)))) + (format "|%s|" (string-join (nreverse ret) "|"))))))) + +(defun markdown-table-colfmt (fmtspec) + "Process column alignment specifier FMTSPEC for tables." + (when (stringp fmtspec) + (mapcar (lambda (x) + (cond ((string-match-p "^:.*:$" x) 'c) + ((string-match-p "^:" x) 'l) + ((string-match-p ":$" x) 'r) + (t 'd))) + (markdown--split-string fmtspec "\\s-*|\\s-*")))) + +(defun markdown--first-column-p (bar-pos) + (save-excursion + (save-match-data + (goto-char bar-pos) + (looking-back "^\\s-*" (line-beginning-position))))) + +(defun markdown--table-line-to-columns (line) + (with-temp-buffer + (insert line) + (goto-char (point-min)) + (let ((cur (point)) + ret) + (while (and (re-search-forward "\\s-*\\(|\\)\\s-*" nil t)) + (when (not (markdown--face-p (match-beginning 1) '(markdown-inline-code-face))) + (if (markdown--first-column-p (match-beginning 1)) + (setq cur (match-end 0)) + (cond ((eql (char-before (match-beginning 1)) ?\\) + ;; keep spaces + (goto-char (match-end 1))) + ((markdown--thing-at-wiki-link (match-beginning 1))) ;; do nothing + (t + (push (buffer-substring-no-properties cur (match-beginning 0)) ret) + (setq cur (match-end 0))))))) + (when (< cur (length line)) + (push (buffer-substring-no-properties cur (point-max)) ret)) + (nreverse ret)))) + +(defsubst markdown--is-delimiter-row (line) + (and (string-match-p "\\`[ \t]*|[ \t]*[-:]" line) + (cl-loop for c across line + always (member c '(?| ?- ?: ?\t ? ))))) + +(defun markdown-table-align () + "Align table at point. +This function assumes point is on a table." + (interactive) + (let ((begin (markdown-table-begin)) + (end (copy-marker (markdown-table-end)))) + (markdown-table-save-cell + (goto-char begin) + (let* (fmtspec + ;; Store table indent + (indent (progn (looking-at "[ \t]*") (match-string 0))) + ;; Split table in lines and save column format specifier + (lines (mapcar (lambda (line) + (if (markdown--is-delimiter-row line) + (progn (setq fmtspec (or fmtspec line)) nil) + line)) + (markdown--split-string (buffer-substring begin end) "\n"))) + ;; Split lines in cells + (cells (mapcar (lambda (l) (markdown--table-line-to-columns l)) + (remq nil lines))) + ;; Calculate maximum number of cells in a line + (maxcells (if cells + (apply #'max (mapcar #'length cells)) + (user-error "Empty table"))) + ;; Empty cells to fill short lines + (emptycells (make-list maxcells "")) + maxwidths) + ;; Calculate maximum width for each column + (dotimes (i maxcells) + (let ((column (mapcar (lambda (x) (or (nth i x) "")) cells))) + (push (apply #'max 1 (mapcar #'markdown--string-width column)) + maxwidths))) + (setq maxwidths (nreverse maxwidths)) + ;; Process column format specifier + (setq fmtspec (markdown-table-colfmt fmtspec)) + ;; Compute formats needed for output of table lines + (let ((hfmt (concat indent "|")) + (rfmt (concat indent "|")) + hfmt1 rfmt1 fmt) + (dolist (width maxwidths (setq hfmt (concat (substring hfmt 0 -1) "|"))) + (setq fmt (pop fmtspec)) + (cond ((equal fmt 'l) (setq hfmt1 ":%s-|" rfmt1 " %%-%ds |")) + ((equal fmt 'r) (setq hfmt1 "-%s:|" rfmt1 " %%%ds |")) + ((equal fmt 'c) (setq hfmt1 ":%s:|" rfmt1 " %%-%ds |")) + (t (setq hfmt1 "-%s-|" rfmt1 " %%-%ds |"))) + (setq rfmt (concat rfmt (format rfmt1 width))) + (setq hfmt (concat hfmt (format hfmt1 (make-string width ?-))))) + ;; Replace modified lines only + (dolist (line lines) + (let ((line (if line + (apply #'format rfmt (append (pop cells) emptycells)) + hfmt)) + (previous (buffer-substring (point) (line-end-position)))) + (if (equal previous line) + (forward-line) + (insert line "\n") + (delete-region (point) (line-beginning-position 2)))))) + (set-marker end nil))))) + +(defun markdown-table-insert-row (&optional arg) + "Insert a new row above the row at point into the table. +With optional argument ARG, insert below the current row." + (interactive "P") + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let* ((line (buffer-substring + (line-beginning-position) (line-end-position))) + (new (markdown-table-blank-line line))) + (beginning-of-line (if arg 2 1)) + (unless (bolp) (insert "\n")) + (insert-before-markers new "\n") + (beginning-of-line 0) + (re-search-forward "| ?" (line-end-position) t))) + +(defun markdown-table-delete-row () + "Delete row or horizontal line at point from the table." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let ((col (current-column))) + (kill-region (line-beginning-position) + (min (1+ (line-end-position)) (point-max))) + (unless (markdown-table-at-point-p) (beginning-of-line 0)) + (move-to-column col))) + +(defun markdown-table-move-row (&optional up) + "Move table line at point down. +With optional argument UP, move it up." + (interactive "P") + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let* ((col (current-column)) (pos (point)) + (tonew (if up 0 2)) txt) + (beginning-of-line tonew) + (unless (markdown-table-at-point-p) + (goto-char pos) (user-error "Cannot move row further")) + (goto-char pos) (beginning-of-line 1) (setq pos (point)) + (setq txt (buffer-substring (point) (1+ (line-end-position)))) + (delete-region (point) (1+ (line-end-position))) + (beginning-of-line tonew) + (insert txt) (beginning-of-line 0) + (move-to-column col))) + +(defun markdown-table-move-row-up () + "Move table row at point up." + (interactive) + (markdown-table-move-row 'up)) + +(defun markdown-table-move-row-down () + "Move table row at point down." + (interactive) + (markdown-table-move-row nil)) + +(defun markdown-table-insert-column () + "Insert a new table column." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let* ((col (max 1 (markdown-table-get-column))) + (begin (markdown-table-begin)) + (end (copy-marker (markdown-table-end)))) + (markdown-table-save-cell + (goto-char begin) + (while (< (point) end) + (markdown-table-goto-column col t) + (if (markdown-table-hline-at-point-p) + (insert "|---") + (insert "| ")) + (forward-line))) + (set-marker end nil) + (when markdown-table-align-p + (markdown-table-align)))) + +(defun markdown-table-delete-column () + "Delete column at point from table." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let ((col (markdown-table-get-column)) + (begin (markdown-table-begin)) + (end (copy-marker (markdown-table-end)))) + (markdown-table-save-cell + (goto-char begin) + (while (< (point) end) + (markdown-table-goto-column col t) + (and (looking-at "|\\(?:\\\\|\\|[^|\n]\\)+|") + (replace-match "|")) + (forward-line))) + (set-marker end nil) + (markdown-table-goto-column (max 1 (1- col))) + (when markdown-table-align-p + (markdown-table-align)))) + +(defun markdown-table-move-column (&optional left) + "Move table column at point to the right. +With optional argument LEFT, move it to the left." + (interactive "P") + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let* ((col (markdown-table-get-column)) + (col1 (if left (1- col) col)) + (colpos (if left (1- col) (1+ col))) + (begin (markdown-table-begin)) + (end (copy-marker (markdown-table-end)))) + (when (and left (= col 1)) + (user-error "Cannot move column further left")) + (when (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) + (user-error "Cannot move column further right")) + (markdown-table-save-cell + (goto-char begin) + (while (< (point) end) + (markdown-table-goto-column col1 t) + (when (looking-at "|\\(\\(?:\\\\|\\|[^|\n]\\|\\)+\\)|\\(\\(?:\\\\|\\|[^|\n]\\|\\)+\\)|") + (replace-match "|\\2|\\1|")) + (forward-line))) + (set-marker end nil) + (markdown-table-goto-column colpos) + (when markdown-table-align-p + (markdown-table-align)))) + +(defun markdown-table-move-column-left () + "Move table column at point to the left." + (interactive) + (markdown-table-move-column 'left)) + +(defun markdown-table-move-column-right () + "Move table column at point to the right." + (interactive) + (markdown-table-move-column nil)) + +(defun markdown-table-next-row () + "Go to the next row (same column) in the table. +Create new table lines if required." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (if (or (looking-at "[ \t]*$") + (save-excursion (skip-chars-backward " \t") (bolp))) + (newline) + (when markdown-table-align-p + (markdown-table-align)) + (let ((col (markdown-table-get-column))) + (beginning-of-line 2) + (if (or (not (markdown-table-at-point-p)) + (markdown-table-hline-at-point-p)) + (progn + (beginning-of-line 0) + (markdown-table-insert-row 'below))) + (markdown-table-goto-column col) + (skip-chars-backward "^|\n\r") + (when (looking-at " ") (forward-char 1))))) + +(defun markdown-table-forward-cell () + "Go to the next cell in the table. +Create new table lines if required." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (when markdown-table-align-p + (markdown-table-align)) + (let ((end (markdown-table-end))) + (when (markdown-table-hline-at-point-p) (end-of-line 1)) + (condition-case nil + (progn + (re-search-forward "\\(?:^\\|[^\\]\\)|" end) + (when (looking-at "[ \t]*$") + (re-search-forward "\\(?:^\\|[^\\]:\\)|" end)) + (when (and (looking-at "[-:]") + (re-search-forward "^\\(?:[ \t]*\\|[^\\]\\)|\\([^-:]\\)" end t)) + (goto-char (match-beginning 1))) + (if (looking-at "[-:]") + (progn + (beginning-of-line 0) + (markdown-table-insert-row 'below)) + (when (looking-at " ") (forward-char 1)))) + (error (markdown-table-insert-row 'below))))) + +(defun markdown-table-backward-cell () + "Go to the previous cell in the table." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (when markdown-table-align-p + (markdown-table-align)) + (when (markdown-table-hline-at-point-p) (beginning-of-line 1)) + (condition-case nil + (progn + (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin)) + ;; When this function is called while in the first cell in a + ;; table, the point will now be at the beginning of a line. In + ;; this case, we need to move past one additional table + ;; boundary, the end of the table on the previous line. + (when (= (point) (line-beginning-position)) + (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin))) + (re-search-backward "\\(?:^\\|[^\\]\\)|" (markdown-table-begin))) + (error (user-error "Cannot move to previous table cell"))) + (when (looking-at "\\(?:^\\|[^\\]\\)| ?") (goto-char (match-end 0))) + + ;; This may have dropped point on the hline. + (when (markdown-table-hline-at-point-p) + (markdown-table-backward-cell))) + +(defun markdown-table-transpose () + "Transpose table at point. +Horizontal separator lines will be eliminated." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + (let* ((table (buffer-substring-no-properties + (markdown-table-begin) (markdown-table-end))) + ;; Convert table to Lisp structure + (table (delq nil + (mapcar + (lambda (x) + (unless (string-match-p + markdown-table-hline-regexp x) + (markdown--table-line-to-columns x))) + (markdown--split-string table "[ \t]*\n[ \t]*")))) + (dline_old (markdown-table-get-dline)) + (col_old (markdown-table-get-column)) + (contents (mapcar (lambda (_) + (let ((tp table)) + (mapcar + (lambda (_) + (prog1 + (pop (car tp)) + (setq tp (cdr tp)))) + table))) + (car table)))) + (goto-char (markdown-table-begin)) + (save-excursion + (re-search-forward "|") (backward-char) + (delete-region (point) (markdown-table-end)) + (insert (mapconcat + (lambda(x) + (concat "| " (mapconcat 'identity x " | " ) " |\n")) + contents ""))) + (markdown-table-goto-dline col_old) + (markdown-table-goto-column dline_old)) + (when markdown-table-align-p + (markdown-table-align))) + +(defun markdown-table-sort-lines (&optional sorting-type) + "Sort table lines according to the column at point. + +The position of point indicates the column to be used for +sorting, and the range of lines is the range between the nearest +horizontal separator lines, or the entire table of no such lines +exist. If point is before the first column, user will be prompted +for the sorting column. If there is an active region, the mark +specifies the first line and the sorting column, while point +should be in the last line to be included into the sorting. + +The command then prompts for the sorting type which can be +alphabetically or numerically. Sorting in reverse order is also +possible. + +If SORTING-TYPE is specified when this function is called from a +Lisp program, no prompting will take place. SORTING-TYPE must be +a character, any of (?a ?A ?n ?N) where the capital letters +indicate that sorting should be done in reverse order." + (interactive) + (unless (markdown-table-at-point-p) + (user-error "Not at a table")) + ;; Set sorting type and column used for sorting + (let ((column (let ((c (markdown-table-get-column))) + (cond ((> c 0) c) + ((called-interactively-p 'any) + (read-number "Use column N for sorting: ")) + (t 1)))) + (sorting-type + (or sorting-type + (progn + ;; workaround #641 + ;; Emacs < 28 hides prompt message by another message. This erases it. + (message "") + (read-char-exclusive + "Sort type: [a]lpha [n]umeric (A/N means reversed): "))))) + (save-restriction + ;; Narrow buffer to appropriate sorting area + (if (region-active-p) + (narrow-to-region + (save-excursion + (progn + (goto-char (region-beginning)) (line-beginning-position))) + (save-excursion + (progn + (goto-char (region-end)) (line-end-position)))) + (let ((start (markdown-table-begin)) + (end (markdown-table-end))) + (narrow-to-region + (save-excursion + (if (re-search-backward + markdown-table-hline-regexp start t) + (line-beginning-position 2) + start)) + (if (save-excursion (re-search-forward + markdown-table-hline-regexp end t)) + (match-beginning 0) + end)))) + ;; Determine arguments for `sort-subr' + (let* ((extract-key-from-cell + (cl-case sorting-type + ((?a ?A) #'markdown--remove-invisible-markup) ;; #'identity) + ((?n ?N) #'string-to-number) + (t (user-error "Invalid sorting type: %c" sorting-type)))) + (predicate + (cl-case sorting-type + ((?n ?N) #'<) + ((?a ?A) #'string<)))) + ;; Sort selected area + (goto-char (point-min)) + (sort-subr (memq sorting-type '(?A ?N)) + (lambda () + (forward-line) + (while (and (not (eobp)) + (not (looking-at + markdown-table-dline-regexp))) + (forward-line))) + #'end-of-line + (lambda () + (funcall extract-key-from-cell + (markdown-table-get-cell column))) + nil + predicate) + (goto-char (point-min)))))) + +(defun markdown-table-convert-region (begin end &optional separator) + "Convert region from BEGIN to END to table with SEPARATOR. + +If every line contains at least one TAB character, the function +assumes that the material is tab separated (TSV). If every line +contains a comma, comma-separated values (CSV) are assumed. If +not, lines are split at whitespace into cells. + +You can use a prefix argument to force a specific separator: +\\[universal-argument] once forces CSV, \\[universal-argument] +twice forces TAB, and \\[universal-argument] three times will +prompt for a regular expression to match the separator, and a +numeric argument N indicates that at least N consecutive +spaces, or alternatively a TAB should be used as the separator." + + (interactive "r\nP") + (let* ((begin (min begin end)) (end (max begin end)) re) + (goto-char begin) (beginning-of-line 1) + (setq begin (point-marker)) + (goto-char end) + (if (bolp) (backward-char 1) (end-of-line 1)) + (setq end (point-marker)) + (when (equal separator '(64)) + (setq separator (read-regexp "Regexp for cell separator: "))) + (unless separator + ;; Get the right cell separator + (goto-char begin) + (setq separator + (cond + ((not (re-search-forward "^[^\n\t]+$" end t)) '(16)) + ((not (re-search-forward "^[^\n,]+$" end t)) '(4)) + (t 1)))) + (goto-char begin) + (if (equal separator '(4)) + ;; Parse CSV + (while (< (point) end) + (cond + ((looking-at "^") (insert "| ")) + ((looking-at "[ \t]*$") (replace-match " |") (beginning-of-line 2)) + ((looking-at "[ \t]*\"\\([^\"\n]*\\)\"") + (replace-match "\\1") (if (looking-at "\"") (insert "\""))) + ((looking-at "[^,\n]+") (goto-char (match-end 0))) + ((looking-at "[ \t]*,") (replace-match " | ")) + (t (beginning-of-line 2)))) + (setq re + (cond + ((equal separator '(4)) "^\\|\"?[ \t]*,[ \t]*\"?") + ((equal separator '(16)) "^\\|\t") + ((integerp separator) + (if (< separator 1) + (user-error "Cell separator must contain one or more spaces") + (format "^ *\\| *\t *\\| \\{%d,\\}\\|$" separator))) + ((stringp separator) (format "^ *\\|%s" separator)) + (t (error "Invalid cell separator")))) + (let (finish) + (while (and (not finish) (re-search-forward re end t)) + (if (eolp) + (progn + (replace-match "|" t t) + (forward-line 1) + (when (eobp) + (setq finish t))) + (replace-match "| " t t))))) + (goto-char begin) + (when markdown-table-align-p + (markdown-table-align)))) + +(defun markdown-insert-table (&optional rows columns align) + "Insert an empty pipe table. +Optional arguments ROWS, COLUMNS, and ALIGN specify number of +rows and columns and the column alignment." + (interactive) + (let* ((rows (or rows (read-number "Number of Rows: "))) + (columns (or columns (read-number "Number of Columns: "))) + (align (or align (read-string "Alignment ([l]eft, [r]ight, [c]enter, or RET for default): "))) + (align (cond ((equal align "l") ":--") + ((equal align "r") "--:") + ((equal align "c") ":-:") + (t "---"))) + (pos (point)) + (indent (make-string (current-column) ?\ )) + (line (concat + (apply 'concat indent "|" + (make-list columns " |")) "\n")) + (hline (apply 'concat indent "|" + (make-list columns (concat align "|"))))) + (if (string-match + "^[ \t]*$" (buffer-substring-no-properties + (line-beginning-position) (point))) + (beginning-of-line 1) + (newline)) + (dotimes (_ rows) (insert line)) + (goto-char pos) + (if (> rows 1) + (progn + (end-of-line 1) (insert (concat "\n" hline)) (goto-char pos))) + (markdown-table-forward-cell))) + + +;;; ElDoc Support ============================================================= + +(defun markdown-eldoc-function (&rest _ignored) + "Return a helpful string when appropriate based on context. +* Report URL when point is at a hidden URL. +* Report language name when point is a code block with hidden markup." + (cond + ;; Hidden URL or reference for inline link + ((and (or (thing-at-point-looking-at markdown-regex-link-inline) + (thing-at-point-looking-at markdown-regex-link-reference)) + (or markdown-hide-urls markdown-hide-markup)) + (let* ((imagep (string-equal (match-string 1) "!")) + (referencep (string-equal (match-string 5) "[")) + (link (match-string-no-properties 6)) + (edit-keys (markdown--substitute-command-keys + (if imagep + "\\[markdown-insert-image]" + "\\[markdown-insert-link]"))) + (edit-str (propertize edit-keys 'face 'font-lock-constant-face)) + (object (if referencep "reference" "URL"))) + (format "Hidden %s (%s to edit): %s" object edit-str + (if referencep + (concat + (propertize "[" 'face 'markdown-markup-face) + (propertize link 'face 'markdown-reference-face) + (propertize "]" 'face 'markdown-markup-face)) + (propertize link 'face 'markdown-url-face))))) + ;; Hidden language name for fenced code blocks + ((and (markdown-code-block-at-point-p) + (not (get-text-property (point) 'markdown-pre)) + markdown-hide-markup) + (let ((lang (save-excursion (markdown-code-block-lang)))) + (unless lang (setq lang "[unspecified]")) + (format "Hidden code block language: %s (%s to toggle markup)" + (propertize lang 'face 'markdown-language-keyword-face) + (markdown--substitute-command-keys + "\\[markdown-toggle-markup-hiding]")))))) + +(defun markdown--image-media-handler (mimetype data) + (let* ((ext (symbol-name (mailcap-mime-type-to-extension mimetype))) + (filename (read-string "Insert filename for image: ")) + (link-text (read-string "Link text: ")) + (filepath (file-name-with-extension filename ext)) + (dir (file-name-directory filepath))) + (when (and dir (not (file-directory-p dir))) + (make-directory dir t)) + (with-temp-file filepath + (insert data)) + (when (string-match-p "\\s-" filepath) + (setq filepath (concat "<" filepath ">"))) + (markdown-insert-inline-image link-text filepath))) + +(defun markdown--file-media-handler (_mimetype data) + (let* ((data (split-string data "[\0\r\n]" t "^file://")) + (files (cdr data))) + (while (not (null files)) + (let* ((file (url-unhex-string (car files))) + (file (file-relative-name file)) + (prompt (format "Link text(%s): " (file-name-nondirectory file))) + (link-text (read-string prompt))) + (when (string-match-p "\\s-" file) + (setq file (concat "<" file ">"))) + (markdown-insert-inline-image link-text file) + (when (not (null (cdr files))) + (insert " ")) + (setq files (cdr files)))))) + +(defun markdown--dnd-local-file-handler (url _action) + (require 'mailcap) + (require 'dnd) + (let* ((filename (dnd-get-local-file-name url)) + (mimetype (mailcap-file-name-to-mime-type filename)) + (file (file-relative-name filename)) + (link-text "link text")) + (when (string-match-p "\\s-" file) + (setq file (concat "<" file ">"))) + (if (string-prefix-p "image/" mimetype) + (markdown-insert-inline-image link-text file) + (markdown-insert-inline-link link-text file)))) + + +;;; Mode Definition ========================================================== + +(defun markdown-show-version () + "Show the version number in the minibuffer." + (interactive) + (message "markdown-mode, version %s" markdown-mode-version)) + +(defun markdown-mode-info () + "Open the `markdown-mode' homepage." + (interactive) + (browse-url "https://jblevins.org/projects/markdown-mode/")) + +;;;###autoload +(define-derived-mode markdown-mode text-mode "Markdown" + "Major mode for editing Markdown files." + (when buffer-read-only + (when (or (not (buffer-file-name)) (file-writable-p (buffer-file-name))) + (setq-local buffer-read-only nil))) + ;; Natural Markdown tab width + (setq tab-width 4) + ;; Comments + (setq-local comment-start "<!-- ") + (setq-local comment-end " -->") + (setq-local comment-start-skip "<!--[ \t]*") + (setq-local comment-column 0) + (setq-local comment-auto-fill-only-comments nil) + (setq-local comment-use-syntax t) + ;; Sentence + (setq-local sentence-end-base "[.?!…‽][]\"'”’)}»›*_`~]*") + ;; Syntax + (add-hook 'syntax-propertize-extend-region-functions + #'markdown-syntax-propertize-extend-region nil t) + (add-hook 'jit-lock-after-change-extend-region-functions + #'markdown-font-lock-extend-region-function t t) + (setq-local syntax-propertize-function #'markdown-syntax-propertize) + (syntax-propertize (point-max)) ;; Propertize before hooks run, etc. + ;; Font lock. + (setq font-lock-defaults + '(markdown-mode-font-lock-keywords + nil nil nil nil + (font-lock-multiline . t) + (font-lock-syntactic-face-function . markdown-syntactic-face) + (font-lock-extra-managed-props + . (composition display invisible rear-nonsticky + keymap help-echo mouse-face)))) + (if markdown-hide-markup + (add-to-invisibility-spec 'markdown-markup) + (remove-from-invisibility-spec 'markdown-markup)) + ;; Wiki links + (markdown-setup-wiki-link-hooks) + ;; Math mode + (when markdown-enable-math (markdown-toggle-math t)) + ;; Add a buffer-local hook to reload after file-local variables are read + (add-hook 'hack-local-variables-hook #'markdown-handle-local-variables nil t) + ;; For imenu support + (setq imenu-create-index-function + (if markdown-nested-imenu-heading-index + #'markdown-imenu-create-nested-index + #'markdown-imenu-create-flat-index)) + + ;; Defun movement + (setq-local beginning-of-defun-function #'markdown-beginning-of-defun) + (setq-local end-of-defun-function #'markdown-end-of-defun) + ;; Paragraph filling + (setq-local fill-paragraph-function #'markdown-fill-paragraph) + (setq-local paragraph-start + ;; Should match start of lines that start or separate paragraphs + (mapconcat #'identity + '( + "\f" ; starts with a literal line-feed + "[ \t\f]*$" ; space-only line + "\\(?:[ \t]*>\\)+[ \t\f]*$"; empty line in blockquote + "[ \t]*[*+-][ \t]+" ; unordered list item + "[ \t]*\\(?:[0-9]+\\|#\\)\\.[ \t]+" ; ordered list item + "[ \t]*\\[\\S-*\\]:[ \t]+" ; link ref def + "[ \t]*:[ \t]+" ; definition + "^|" ; table or Pandoc line block + ) + "\\|")) + (setq-local paragraph-separate + ;; Should match lines that separate paragraphs without being + ;; part of any paragraph: + (mapconcat #'identity + '("[ \t\f]*$" ; space-only line + "\\(?:[ \t]*>\\)+[ \t\f]*$"; empty line in blockquote + ;; The following is not ideal, but the Fill customization + ;; options really only handle paragraph-starting prefixes, + ;; not paragraph-ending suffixes: + ".* $" ; line ending in two spaces + "^#+" + "^\\(?: \\)?[-=]+[ \t]*$" ;; setext + "[ \t]*\\[\\^\\S-*\\]:[ \t]*$") ; just the start of a footnote def + "\\|")) + (setq-local adaptive-fill-first-line-regexp "\\`[ \t]*[A-Z]?>[ \t]*?\\'") + (setq-local adaptive-fill-regexp "\\s-*") + (setq-local adaptive-fill-function #'markdown-adaptive-fill-function) + (setq-local fill-forward-paragraph-function #'markdown-fill-forward-paragraph) + ;; Outline mode + (setq-local outline-regexp markdown-regex-header) + (setq-local outline-level #'markdown-outline-level) + ;; Cause use of ellipses for invisible text. + (add-to-invisibility-spec '(outline . t)) + ;; ElDoc support + (if (boundp 'eldoc-documentation-functions) + (add-hook 'eldoc-documentation-functions #'markdown-eldoc-function nil t) + (add-function :before-until (local 'eldoc-documentation-function) + #'markdown-eldoc-function)) + ;; Inhibiting line-breaking: + ;; Separating out each condition into a separate function so that users can + ;; override if desired (with remove-hook) + (add-hook 'fill-nobreak-predicate + #'markdown-line-is-reference-definition-p nil t) + (add-hook 'fill-nobreak-predicate + #'markdown-pipe-at-bol-p nil t) + + ;; Indentation + (setq-local indent-line-function markdown-indent-function) + (setq-local indent-region-function #'markdown--indent-region) + + ;; Flyspell + (setq-local flyspell-generic-check-word-predicate + #'markdown-flyspell-check-word-p) + + ;; Electric quoting + (add-hook 'electric-quote-inhibit-functions + #'markdown--inhibit-electric-quote nil :local) + + ;; drag and drop handler + (setq-local dnd-protocol-alist (cons '("^file:///" . markdown--dnd-local-file-handler) + dnd-protocol-alist)) + + ;; media handler + (when (version< "29" emacs-version) + (yank-media-handler "image/.*" #'markdown--image-media-handler) + ;; TODO support other than GNOME, like KDE etc + (yank-media-handler "x-special/gnome-copied-files" #'markdown--file-media-handler)) + + ;; Make checkboxes buttons + (when markdown-make-gfm-checkboxes-buttons + (markdown-make-gfm-checkboxes-buttons (point-min) (point-max)) + (add-hook 'after-change-functions #'markdown-gfm-checkbox-after-change-function t t) + (add-hook 'change-major-mode-hook #'markdown-remove-gfm-checkbox-overlays t t)) + + ;; edit-indirect + (add-hook 'edit-indirect-after-commit-functions + #'markdown--edit-indirect-after-commit-function + nil 'local) + + ;; Marginalized headings + (when markdown-marginalize-headers + (add-hook 'window-configuration-change-hook + #'markdown-marginalize-update-current nil t)) + + ;; add live preview export hook + (add-hook 'after-save-hook #'markdown-live-preview-if-markdown t t) + (add-hook 'kill-buffer-hook #'markdown-live-preview-remove-on-kill t t) + + ;; Add a custom keymap for `visual-line-mode' so that activating + ;; this minor mode does not override markdown-mode's keybindings. + ;; FIXME: Probably `visual-line-mode' should take care of this. + (let ((oldmap (cdr (assoc 'visual-line-mode minor-mode-map-alist))) + (newmap (make-sparse-keymap))) + (set-keymap-parent newmap oldmap) + (define-key newmap [remap move-beginning-of-line] nil) + (define-key newmap [remap move-end-of-line] nil) + (make-local-variable 'minor-mode-overriding-map-alist) + (push `(visual-line-mode . ,newmap) minor-mode-overriding-map-alist))) + +;;;###autoload +(add-to-list 'auto-mode-alist + '("\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'" . markdown-mode)) + + +;;; GitHub Flavored Markdown Mode ============================================ + +(defun gfm--electric-pair-fence-code-block () + (when (and electric-pair-mode + (not markdown-gfm-use-electric-backquote) + (eql last-command-event ?`) + (let ((count 0)) + (while (eql (char-before (- (point) count)) ?`) + (cl-incf count)) + (= count 3)) + (eql (char-after) ?`)) + (save-excursion (insert (make-string 2 ?`))))) + +(defvar gfm-mode-hook nil + "Hook run when entering GFM mode.") + +;;;###autoload +(define-derived-mode gfm-mode markdown-mode "GFM" + "Major mode for editing GitHub Flavored Markdown files." + (setq markdown-link-space-sub-char "-") + (setq markdown-wiki-link-search-subdirectories t) + (setq-local markdown-table-at-point-p-function #'gfm--table-at-point-p) + (setq-local paragraph-separate + (concat paragraph-separate + "\\|" + ;; GFM alert syntax + "^>\s-*\\[!\\(?:NOTE\\|TIP\\|IMPORTANT\\|WARNING\\|CAUTION\\)\\]")) + (add-hook 'post-self-insert-hook #'gfm--electric-pair-fence-code-block 'append t) + (markdown-gfm-parse-buffer-for-languages)) + + +;;; Viewing modes ============================================================= + +(defcustom markdown-hide-markup-in-view-modes t + "Enable hidden markup mode in `markdown-view-mode' and `gfm-view-mode'." + :group 'markdown + :type 'boolean + :safe #'booleanp) + +(defvar markdown-view-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "p") #'markdown-outline-previous) + (define-key map (kbd "n") #'markdown-outline-next) + (define-key map (kbd "f") #'markdown-outline-next-same-level) + (define-key map (kbd "b") #'markdown-outline-previous-same-level) + (define-key map (kbd "u") #'markdown-outline-up) + (define-key map (kbd "DEL") #'scroll-down-command) + (define-key map (kbd "SPC") #'scroll-up-command) + (define-key map (kbd ">") #'end-of-buffer) + (define-key map (kbd "<") #'beginning-of-buffer) + (define-key map (kbd "q") #'kill-this-buffer) + (define-key map (kbd "?") #'describe-mode) + map) + "Keymap for `markdown-view-mode'.") + +(defun markdown--filter-visible (beg end &optional delete) + (let ((result "") + (invisible-faces '(markdown-header-delimiter-face markdown-header-rule-face))) + (while (< beg end) + (when (markdown--face-p beg invisible-faces) + (cl-incf beg) + (while (and (markdown--face-p beg invisible-faces) (< beg end)) + (cl-incf beg))) + (let ((next (next-single-char-property-change beg 'invisible))) + (unless (get-char-property beg 'invisible) + (setq result (concat result (buffer-substring beg (min end next))))) + (setq beg next))) + (prog1 result + (when delete + (let ((inhibit-read-only t)) + (delete-region beg end)))))) + +;;;###autoload +(define-derived-mode markdown-view-mode markdown-mode "Markdown-View" + "Major mode for viewing Markdown content." + (setq-local markdown-hide-markup markdown-hide-markup-in-view-modes) + (add-to-invisibility-spec 'markdown-markup) + (setq-local filter-buffer-substring-function #'markdown--filter-visible) + (read-only-mode 1)) + +(defvar gfm-view-mode-map + markdown-view-mode-map + "Keymap for `gfm-view-mode'.") + +;;;###autoload +(define-derived-mode gfm-view-mode gfm-mode "GFM-View" + "Major mode for viewing GitHub Flavored Markdown content." + (setq-local markdown-hide-markup markdown-hide-markup-in-view-modes) + (setq-local markdown-fontify-code-blocks-natively t) + (setq-local filter-buffer-substring-function #'markdown--filter-visible) + (add-to-invisibility-spec 'markdown-markup) + (read-only-mode 1)) + + +;;; Live Preview Mode ======================================================== +;;;###autoload +(define-minor-mode markdown-live-preview-mode + "Toggle native previewing on save for a specific markdown file." + :lighter " MD-Preview" + (if markdown-live-preview-mode + (if (markdown-live-preview-get-filename) + (markdown-display-buffer-other-window (markdown-live-preview-export)) + (markdown-live-preview-mode -1) + (user-error "Buffer %s does not visit a file" (current-buffer))) + (markdown-live-preview-remove))) + + +(provide 'markdown-mode) + +;; Local Variables: +;; indent-tabs-mode: nil +;; coding: utf-8 +;; End: +;;; markdown-mode.el ends here diff --git a/emacs/elpa/markdown-mode-20241117.307/markdown-mode.elc b/emacs/elpa/markdown-mode-20241117.307/markdown-mode.elc Binary files differ. diff --git a/emacs/elpa/transient-20241111.1438/transient-pkg.el b/emacs/elpa/transient-20241111.1438/transient-pkg.el @@ -1,12 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "transient" "20241111.1438" - "Transient commands." - '((emacs "26.1") - (compat "30.0.0.0") - (seq "2.24")) - :url "https://github.com/magit/transient" - :commit "d90d65b822001fa6f4a85e5fa65b3fddffa43942" - :revdesc "d90d65b82200" - :keywords '("extensions") - :authors '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) - :maintainers '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev"))) diff --git a/emacs/elpa/transient-20241111.1438/transient.el b/emacs/elpa/transient-20241111.1438/transient.el @@ -1,4681 +0,0 @@ -;;; transient.el --- Transient commands -*- lexical-binding:t -*- - -;; Copyright (C) 2018-2024 Free Software Foundation, Inc. - -;; Author: Jonas Bernoulli <emacs.transient@jonas.bernoulli.dev> -;; Homepage: https://github.com/magit/transient -;; Keywords: extensions - -;; Package-Version: 20241111.1438 -;; Package-Revision: d90d65b82200 -;; Package-Requires: ((emacs "26.1") (compat "30.0.0.0") (seq "2.24")) - -;; SPDX-License-Identifier: GPL-3.0-or-later - -;; 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 this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Transient is the library used to implement the keyboard-driven menus -;; in Magit. It is distributed as a separate package, so that it can be -;; used to implement similar menus in other packages. - -;;; Code: - -(require 'cl-lib) -(require 'compat) -(require 'eieio) -(require 'edmacro) -(require 'format-spec) -(require 'pcase) - -(eval-and-compile - (when (and (featurep 'seq) - (not (fboundp 'seq-keep))) - (unload-feature 'seq 'force))) -(require 'seq) -(unless (fboundp 'seq-keep) - (display-warning 'transient (substitute-command-keys "\ -Transient requires `seq' >= 2.24, -but due to bad defaults, Emacs's package manager, refuses to -upgrade this and other built-in packages to higher releases -from GNU Elpa, when a package specifies that this is needed. - -To fix this, you have to add this to your init file: - - (setq package-install-upgrade-built-in t) - -Then evaluate that expression by placing the cursor after it -and typing \\[eval-last-sexp]. - -Once you have done that, you have to explicitly upgrade `seq': - - \\[package-upgrade] seq \\`RET' - -Then you also must make sure the updated version is loaded, -by evaluating this form: - - (progn (unload-feature 'seq t) (require 'seq)) - -Until you do this, you will get random errors about `seq-keep' -being undefined while using Transient. - -If you don't use the `package' package manager but still get -this warning, then your chosen package manager likely has a -similar defect.") :emergency)) - -(eval-when-compile (require 'subr-x)) - -(declare-function info "info" (&optional file-or-node buffer)) -(declare-function Man-find-section "man" (section)) -(declare-function Man-next-section "man" (n)) -(declare-function Man-getpage-in-background "man" (topic)) - -(defvar Man-notify-method) -(defvar pp-default-function) ; since Emacs 29.1 - -(eval-and-compile - (when (< emacs-major-version 28) - (pcase-defmacro cl-type (type) - "Pcase pattern that matches objects of TYPE. -TYPE is a type descriptor as accepted by `cl-typep', which see." - (static-if (< emacs-major-version 30) - `(pred (pcase--flip cl-typep ',type)) - `(pred (cl-typep _ ',type)))))) - -(defmacro transient--with-emergency-exit (id &rest body) - (declare (indent defun)) - (unless (keywordp id) - (setq body (cons id body)) - (setq id nil)) - `(condition-case err - (let ((debugger #'transient--exit-and-debug)) - ,(macroexp-progn body)) - ((debug error) - (transient--emergency-exit ,id) - (signal (car err) (cdr err))))) - -(defun transient--exit-and-debug (&rest args) - (transient--emergency-exit :debugger) - (apply #'debug args)) - -;;; Options - -(defgroup transient nil - "Transient commands." - :group 'extensions) - -(defcustom transient-show-popup t - "Whether to show the current transient in a popup buffer. -\\<transient-map> -- If t, then show the popup as soon as a transient prefix command - is invoked. - -- If nil, then do not show the popup unless the user explicitly - requests it, by pressing \\[transient-show] or a prefix key. - -- If a number, then delay displaying the popup and instead show - a brief one-line summary. If zero or negative, then suppress - even showing that summary and display the pressed key only. - - Show the popup when the user explicitly requests it by pressing - \\[transient-show] or a prefix key. Unless zero, then also show the popup - after that many seconds of inactivity (using the absolute value)." - :package-version '(transient . "0.1.0") - :group 'transient - :type '(choice (const :tag "instantly" t) - (const :tag "on demand" nil) - (const :tag "on demand (no summary)" 0) - (number :tag "after delay" 1))) - -(defcustom transient-enable-popup-navigation 'verbose - "Whether navigation commands are enabled in the transient popup. - -If the value is `verbose', additionally show brief documentation -about the command under point in the echo area. - -While a transient is active the transient popup buffer is not the -current buffer, making it necessary to use dedicated commands to -act on that buffer itself. If this is non-nil, then the following -bindings are available: - -\\<transient-popup-navigation-map>\ -- \\[transient-backward-button] moves the cursor to the previous suffix. -- \\[transient-forward-button] moves the cursor to the next suffix. -- \\[transient-push-button] invokes the suffix the cursor is on. -\\<transient-button-map>\ -- \\`<mouse-1>' and \\`<mouse-2>' invoke the clicked on suffix. -\\<transient-popup-navigation-map>\ -- \\[transient-isearch-backward]\ - and \\[transient-isearch-forward] start isearch in the popup buffer. - -\\`<mouse-1>' and \\`<mouse-2>' are bound in `transient-push-button'. -All other bindings are in `transient-popup-navigation-map'. - -By default \\`M-RET' is bound to `transient-push-button', instead of -\\`RET', because if a transient allows the invocation of non-suffixes, -then it is likely, that you would want \\`RET' to do what it would do -if no transient were active." - :package-version '(transient . "0.7.8") - :group 'transient - :type '(choice (const :tag "enable navigation and echo summary" verbose) - (const :tag "enable navigation commands" t) - (const :tag "disable navigation commands" nil))) - -(defcustom transient-display-buffer-action - '(display-buffer-in-side-window - (side . bottom) - (dedicated . t) - (inhibit-same-window . t)) - "The action used to display the transient popup buffer. - -The transient popup buffer is displayed in a window using - - (display-buffer BUFFER transient-display-buffer-action) - -The value of this option has the form (FUNCTION . ALIST), -where FUNCTION is a function or a list of functions. Each such -function should accept two arguments: a buffer to display and an -alist of the same form as ALIST. See info node `(elisp)Choosing -Window' for details. - -The default is: - - (display-buffer-in-side-window - (side . bottom) - (dedicated . t) - (inhibit-same-window . t)) - -This displays the window at the bottom of the selected frame. -Another useful FUNCTION is `display-buffer-below-selected', which -is what `magit-popup' used by default. For more alternatives see -info node `(elisp)Display Action Functions' and info node -`(elisp)Buffer Display Action Alists'. - -Note that the buffer that was current before the transient buffer -is shown should remain the current buffer. Many suffix commands -act on the thing at point, if appropriate, and if the transient -buffer became the current buffer, then that would change what is -at point. To that effect `inhibit-same-window' ensures that the -selected window is not used to show the transient buffer. - -It may be possible to display the window in another frame, but -whether that works in practice depends on the window-manager. -If the window manager selects the new window (Emacs frame), -then that unfortunately changes which buffer is current. - -If you change the value of this option, then you might also -want to change the value of `transient-mode-line-format'." - :package-version '(transient . "0.7.5") - :group 'transient - :type '(cons (choice function (repeat :tag "Functions" function)) - alist)) - -(defcustom transient-mode-line-format 'line - "The mode-line format for the transient popup buffer. - -If nil, then the buffer has no mode-line. If the buffer is not -displayed right above the echo area, then this probably is not -a good value. - -If `line' (the default) or a natural number, then the buffer has no -mode-line, but a line is drawn in its place. If a number is used, -that specifies the thickness of the line. On termcap frames we -cannot draw lines, so there `line' and numbers are synonyms for nil. - -The color of the line is used to indicate if non-suffixes are -allowed and whether they exit the transient. The foreground -color of `transient-key-noop' (if non-suffixes are disallowed), -`transient-key-stay' (if allowed and transient stays active), or -`transient-key-exit' (if allowed and they exit the transient) is -used to draw the line. - -Otherwise this can be any mode-line format. -See `mode-line-format' for details." - :package-version '(transient . "0.2.0") - :group 'transient - :type '(choice (const :tag "hide mode-line" nil) - (const :tag "substitute thin line" line) - (number :tag "substitute line with thickness") - (const :tag "name of prefix command" - ("%e" mode-line-front-space - mode-line-buffer-identification)) - (sexp :tag "custom mode-line format"))) - -(defcustom transient-show-common-commands nil - "Whether to show common transient suffixes in the popup buffer. - -These commands are always shown after typing the prefix key -\"C-x\" when a transient command is active. To toggle the value -of this variable use \"C-x t\" when a transient is active." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'boolean) - -(defcustom transient-read-with-initial-input nil - "Whether to use the last history element as initial minibuffer input." - :package-version '(transient . "0.2.0") - :group 'transient - :type 'boolean) - -(defcustom transient-highlight-mismatched-keys nil - "Whether to highlight keys that do not match their argument. - -This only affects infix arguments that represent command-line -arguments. When this option is non-nil, then the key binding -for infix argument are highlighted when only a long argument -\(e.g., \"--verbose\") is specified but no shorthand (e.g., \"-v\"). -In the rare case that a short-hand is specified but does not -match the key binding, then it is highlighted differently. - -The highlighting is done using `transient-mismatched-key' -and `transient-nonstandard-key'." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'boolean) - -(defcustom transient-highlight-higher-levels nil - "Whether to highlight suffixes on higher levels. - -This is primarily intended for package authors. - -When non-nil then highlight the description of suffixes whose -level is above 4, the default of `transient-default-level'. -Assuming you have set that variable to 7, this highlights all -suffixes that won't be available to users without them making -the same customization." - :package-version '(transient . "0.3.6") - :group 'transient - :type 'boolean) - -(defcustom transient-substitute-key-function nil - "Function used to modify key bindings. - -This function is called with one argument, the prefix object, -and must return a key binding description, either the existing -key description it finds in the `key' slot, or a substitution. - -This is intended to let users replace certain prefix keys. It -could also be used to make other substitutions, but that is -discouraged. - -For example, \"=\" is hard to reach using my custom keyboard -layout, so I substitute \"(\" for that, which is easy to reach -using a layout optimized for Lisp. - - (setq transient-substitute-key-function - (lambda (obj) - (let ((key (oref obj key))) - (if (string-match \"\\\\`\\\\(=\\\\)[a-zA-Z]\" key) - (replace-match \"(\" t t key 1) - key)))))" - :package-version '(transient . "0.1.0") - :group 'transient - :type '(choice (const :tag "Transform no keys (nil)" nil) function)) - -(defcustom transient-semantic-coloring t - "Whether to use colors to indicate transient behavior. - -If non-nil, then the key binding of each suffix is colorized to -indicate whether it exits the transient state or not, and the -line that is drawn below the transient popup buffer is used to -indicate the behavior of non-suffix commands." - :package-version '(transient . "0.5.0") - :group 'transient - :type 'boolean) - -(defcustom transient-detect-key-conflicts nil - "Whether to detect key binding conflicts. - -Conflicts are detected when a transient prefix command is invoked -and results in an error, which prevents the transient from being -used." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'boolean) - -(defcustom transient-align-variable-pitch nil - "Whether to align columns pixel-wise in the popup buffer. - -If this is non-nil, then columns are aligned pixel-wise to -support variable-pitch fonts. Keys are not aligned, so you -should use a fixed-pitch font for the `transient-key' face. -Other key faces inherit from that face unless a theme is -used that breaks that relationship. - -This option is intended for users who use a variable-pitch -font for the `default' face. - -Also see `transient-force-fixed-pitch'." - :package-version '(transient . "0.4.0") - :group 'transient - :type 'boolean) - -(defcustom transient-force-fixed-pitch nil - "Whether to force use of monospaced font in the popup buffer. - -Even if you use a proportional font for the `default' face, -you might still want to use a monospaced font in transient's -popup buffer. Setting this option to t causes `default' to -be remapped to `fixed-pitch' in that buffer. - -Also see `transient-align-variable-pitch'." - :package-version '(transient . "0.2.0") - :group 'transient - :type 'boolean) - -(defcustom transient-force-single-column nil - "Whether to force use of a single column to display suffixes. - -This might be useful for users with low vision who use large -text and might otherwise have to scroll in two dimensions." - :package-version '(transient . "0.3.6") - :group 'transient - :type 'boolean) - -(defcustom transient-hide-during-minibuffer-read nil - "Whether to hide the transient buffer while reading in the minibuffer." - :package-version '(transient . "0.4.0") - :group 'transient - :type 'boolean) - -(defconst transient--max-level 7) -(defconst transient--default-child-level 1) -(defconst transient--default-prefix-level 4) - -(defcustom transient-default-level transient--default-prefix-level - "Control what suffix levels are made available by default. - -Each suffix command is placed on a level and each prefix command -has a level, which controls which suffix commands are available. -Integers between 1 and 7 (inclusive) are valid levels. - -The levels of individual transients and/or their individual -suffixes can be changed individually, by invoking the prefix and -then pressing \"C-x l\". - -The default level for both transients and their suffixes is 4. -This option only controls the default for transients. The default -suffix level is always 4. The author of a transient should place -certain suffixes on a higher level if they expect that it won't be -of use to most users, and they should place very important suffixes -on a lower level so that they remain available even if the user -lowers the transient level. - -\(Magit currently places nearly all suffixes on level 4 and lower -levels are not used at all yet. So for the time being you should -not set a lower level here and using a higher level might not -give you as many additional suffixes as you hoped.)" - :package-version '(transient . "0.1.0") - :group 'transient - :type '(choice (const :tag "1 - fewest suffixes" 1) - (const 2) - (const 3) - (const :tag "4 - default" 4) - (const 5) - (const 6) - (const :tag "7 - most suffixes" 7))) - -(defcustom transient-levels-file - (locate-user-emacs-file "transient/levels.el") - "File used to save levels of transients and their suffixes." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'file) - -(defcustom transient-values-file - (locate-user-emacs-file "transient/values.el") - "File used to save values of transients." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'file) - -(defcustom transient-history-file - (locate-user-emacs-file "transient/history.el") - "File used to save history of transients and their infixes." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'file) - -(defcustom transient-history-limit 10 - "Number of history elements to keep when saving to file." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'integer) - -(defcustom transient-save-history t - "Whether to save history of transient commands when exiting Emacs." - :package-version '(transient . "0.1.0") - :group 'transient - :type 'boolean) - -;;; Faces - -(defgroup transient-faces nil - "Faces used by Transient." - :group 'transient) - -(defface transient-heading '((t :inherit font-lock-keyword-face)) - "Face used for headings." - :group 'transient-faces) - -(defface transient-argument '((t :inherit font-lock-string-face :weight bold)) - "Face used for enabled arguments." - :group 'transient-faces) - -(defface transient-inactive-argument '((t :inherit shadow)) - "Face used for inactive arguments." - :group 'transient-faces) - -(defface transient-value '((t :inherit font-lock-string-face :weight bold)) - "Face used for values." - :group 'transient-faces) - -(defface transient-inactive-value '((t :inherit shadow)) - "Face used for inactive values." - :group 'transient-faces) - -(defface transient-unreachable '((t :inherit shadow)) - "Face used for suffixes unreachable from the current prefix sequence." - :group 'transient-faces) - -(defface transient-inapt-suffix '((t :inherit shadow :italic t)) - "Face used for suffixes that are inapt at this time." - :group 'transient-faces) - -(defface transient-active-infix '((t :inherit highlight)) - "Face used for the infix for which the value is being read." - :group 'transient-faces) - -(defface transient-enabled-suffix - '((t :background "green" :foreground "black" :weight bold)) - "Face used for enabled levels while editing suffix levels. -See info node `(transient)Enabling and Disabling Suffixes'." - :group 'transient-faces) - -(defface transient-disabled-suffix - '((t :background "red" :foreground "black" :weight bold)) - "Face used for disabled levels while editing suffix levels. -See info node `(transient)Enabling and Disabling Suffixes'." - :group 'transient-faces) - -(defface transient-higher-level - `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) - :color ,(let ((color (face-attribute 'shadow :foreground nil t))) - (or (and (not (eq color 'unspecified)) color) - "grey60"))))) - "Face optionally used to highlight suffixes on higher levels. -Also see option `transient-highlight-higher-levels'." - :group 'transient-faces) - -(defface transient-delimiter '((t :inherit shadow)) - "Face used for delimiters and separators. -This includes the parentheses around values and the pipe -character used to separate possible values from each other." - :group 'transient-faces) - -(defface transient-key '((t :inherit font-lock-builtin-face)) - "Face used for keys." - :group 'transient-faces) - -(defface transient-key-stay - `((((class color) (background light)) - :inherit transient-key - :foreground "#22aa22") - (((class color) (background dark)) - :inherit transient-key - :foreground "#ddffdd")) - "Face used for keys of suffixes that don't exit transient state." - :group 'transient-faces) - -(defface transient-key-noop - `((((class color) (background light)) - :inherit transient-key - :foreground "grey80") - (((class color) (background dark)) - :inherit transient-key - :foreground "grey30")) - "Face used for keys of suffixes that currently cannot be invoked." - :group 'transient-faces) - -(defface transient-key-return - `((((class color) (background light)) - :inherit transient-key - :foreground "#aaaa11") - (((class color) (background dark)) - :inherit transient-key - :foreground "#ffffcc")) - "Face used for keys of suffixes that return to the parent transient." - :group 'transient-faces) - -(defface transient-key-exit - `((((class color) (background light)) - :inherit transient-key - :foreground "#aa2222") - (((class color) (background dark)) - :inherit transient-key - :foreground "#ffdddd")) - "Face used for keys of suffixes that exit transient state." - :group 'transient-faces) - -(defface transient-unreachable-key - '((t :inherit (shadow transient-key) :weight normal)) - "Face used for keys unreachable from the current prefix sequence." - :group 'transient-faces) - -(defface transient-nonstandard-key - `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) - :color "cyan"))) - "Face optionally used to highlight keys conflicting with short-argument. -Also see option `transient-highlight-mismatched-keys'." - :group 'transient-faces) - -(defface transient-mismatched-key - `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) - :color "magenta"))) - "Face optionally used to highlight keys without a short-argument. -Also see option `transient-highlight-mismatched-keys'." - :group 'transient-faces) - -;;; Persistence - -(defun transient--read-file-contents (file) - (with-demoted-errors "Transient error: %S" - (and (file-exists-p file) - (with-temp-buffer - (insert-file-contents file) - (read (current-buffer)))))) - -(defun transient--pp-to-file (list file) - (make-directory (file-name-directory file) t) - (setq list (cl-sort (copy-sequence list) #'string< :key #'car)) - (with-temp-file file - (let ((print-level nil) - (print-length nil) - (pp-default-function 'pp-28) - (fill-column 999)) - (pp list (current-buffer))))) - -(defvar transient-values - (transient--read-file-contents transient-values-file) - "Values of transient commands. -The value of this variable persists between Emacs sessions -and you usually should not change it manually.") - -(defun transient-save-values () - (transient--pp-to-file transient-values transient-values-file)) - -(defvar transient-levels - (transient--read-file-contents transient-levels-file) - "Levels of transient commands. -The value of this variable persists between Emacs sessions -and you usually should not change it manually.") - -(defun transient-save-levels () - (transient--pp-to-file transient-levels transient-levels-file)) - -(defvar transient-history - (transient--read-file-contents transient-history-file) - "History of transient commands and infix arguments. -The value of this variable persists between Emacs sessions -\(unless `transient-save-history' is nil) and you usually -should not change it manually.") - -(defun transient-save-history () - (setq transient-history - (cl-sort (mapcar (pcase-lambda (`(,key . ,val)) - (cons key (seq-take (delete-dups val) - transient-history-limit))) - transient-history) - #'string< :key #'car)) - (transient--pp-to-file transient-history transient-history-file)) - -(defun transient-maybe-save-history () - "Save the value of `transient-history'. -If `transient-save-history' is nil, then do nothing." - (when transient-save-history - (transient-save-history))) - -(unless noninteractive - (add-hook 'kill-emacs-hook #'transient-maybe-save-history)) - -;;; Classes -;;;; Prefix - -(defclass transient-prefix () - ((prototype :initarg :prototype) - (command :initarg :command) - (level :initarg :level) - (variable :initarg :variable :initform nil) - (init-value :initarg :init-value) - (value) (default-value :initarg :value) - (scope :initarg :scope :initform nil) - (history :initarg :history :initform nil) - (history-pos :initarg :history-pos :initform 0) - (history-key :initarg :history-key :initform nil) - (show-help :initarg :show-help :initform nil) - (info-manual :initarg :info-manual :initform nil) - (man-page :initarg :man-page :initform nil) - (transient-suffix :initarg :transient-suffix :initform nil) - (transient-non-suffix :initarg :transient-non-suffix :initform nil) - (transient-switch-frame :initarg :transient-switch-frame) - (refresh-suffixes :initarg :refresh-suffixes :initform nil) - (environment :initarg :environment :initform nil) - (incompatible :initarg :incompatible :initform nil) - (suffix-description :initarg :suffix-description) - (variable-pitch :initarg :variable-pitch :initform nil) - (column-widths :initarg :column-widths :initform nil) - (unwind-suffix :documentation "Internal use." :initform nil)) - "Transient prefix command. - -Each transient prefix command consists of a command, which is -stored in a symbol's function slot and an object, which is -stored in the `transient--prefix' property of the same symbol. - -When a transient prefix command is invoked, then a clone of that -object is stored in the global variable `transient--prefix' and -the prototype is stored in the clone's `prototype' slot.") - -;;;; Suffix - -(defclass transient-child () - ((level - :initarg :level - :initform (symbol-value 'transient--default-child-level) - :documentation "Enable if level of prefix is equal or greater.") - (if - :initarg :if - :initform nil - :documentation "Enable if predicate returns non-nil.") - (if-not - :initarg :if-not - :initform nil - :documentation "Enable if predicate returns nil.") - (if-non-nil - :initarg :if-non-nil - :initform nil - :documentation "Enable if variable's value is non-nil.") - (if-nil - :initarg :if-nil - :initform nil - :documentation "Enable if variable's value is nil.") - (if-mode - :initarg :if-mode - :initform nil - :documentation "Enable if major-mode matches value.") - (if-not-mode - :initarg :if-not-mode - :initform nil - :documentation "Enable if major-mode does not match value.") - (if-derived - :initarg :if-derived - :initform nil - :documentation "Enable if major-mode derives from value.") - (if-not-derived - :initarg :if-not-derived - :initform nil - :documentation "Enable if major-mode does not derive from value.") - (inapt - :initform nil) - (inapt-face - :initarg :inapt-face - :initform 'transient-inapt-suffix) - (inapt-if - :initarg :inapt-if - :initform nil - :documentation "Inapt if predicate returns non-nil.") - (inapt-if-not - :initarg :inapt-if-not - :initform nil - :documentation "Inapt if predicate returns nil.") - (inapt-if-non-nil - :initarg :inapt-if-non-nil - :initform nil - :documentation "Inapt if variable's value is non-nil.") - (inapt-if-nil - :initarg :inapt-if-nil - :initform nil - :documentation "Inapt if variable's value is nil.") - (inapt-if-mode - :initarg :inapt-if-mode - :initform nil - :documentation "Inapt if major-mode matches value.") - (inapt-if-not-mode - :initarg :inapt-if-not-mode - :initform nil - :documentation "Inapt if major-mode does not match value.") - (inapt-if-derived - :initarg :inapt-if-derived - :initform nil - :documentation "Inapt if major-mode derives from value.") - (inapt-if-not-derived - :initarg :inapt-if-not-derived - :initform nil - :documentation "Inapt if major-mode does not derive from value.")) - "Abstract superclass for group and suffix classes. - -It is undefined what happens if more than one `if*' predicate -slot is non-nil." - :abstract t) - -(defclass transient-suffix (transient-child) - ((definition :allocation :class :initform nil) - (key :initarg :key) - (command :initarg :command) - (transient :initarg :transient) - (format :initarg :format :initform " %k %d") - (description :initarg :description :initform nil) - (face :initarg :face :initform nil) - (show-help :initarg :show-help :initform nil) - (summary :initarg :summary :initform nil)) - "Superclass for suffix command.") - -(defclass transient-information (transient-suffix) - ((format :initform " %k %d") - (key :initform " ")) - "Display-only information, aligned with suffix keys. -Technically a suffix object with no associated command.") - -(defclass transient-information* (transient-information) - ((format :initform " %d")) - "Display-only information, aligned with suffix descriptions. -Technically a suffix object with no associated command.") - -(defclass transient-infix (transient-suffix) - ((transient :initform t) - (argument :initarg :argument) - (shortarg :initarg :shortarg) - (value :initform nil) - (init-value :initarg :init-value) - (unsavable :initarg :unsavable :initform nil) - (multi-value :initarg :multi-value :initform nil) - (always-read :initarg :always-read :initform nil) - (allow-empty :initarg :allow-empty :initform nil) - (history-key :initarg :history-key :initform nil) - (reader :initarg :reader :initform nil) - (prompt :initarg :prompt :initform nil) - (choices :initarg :choices :initform nil) - (format :initform " %k %d (%v)")) - "Transient infix command." - :abstract t) - -(defclass transient-argument (transient-infix) () - "Abstract superclass for infix arguments." - :abstract t) - -(defclass transient-switch (transient-argument) () - "Class used for command-line argument that can be turned on and off.") - -(defclass transient-option (transient-argument) () - "Class used for command-line argument that can take a value.") - -(defclass transient-variable (transient-infix) - ((variable :initarg :variable) - (format :initform " %k %d %v")) - "Abstract superclass for infix commands that set a variable." - :abstract t) - -(defclass transient-switches (transient-argument) - ((argument-format :initarg :argument-format) - (argument-regexp :initarg :argument-regexp)) - "Class used for sets of mutually exclusive command-line switches.") - -(defclass transient-files (transient-option) () - ((key :initform "--") - (argument :initform "--") - (multi-value :initform rest) - (reader :initform transient-read-files)) - "Class used for the \"--\" argument or similar. -All remaining arguments are treated as files. -They become the value of this argument.") - -(defclass transient-value-preset (transient-suffix) - ((transient :initform t) - (set :initarg := :initform nil)) - "Class used by the `transient-preset' suffix command.") - -;;;; Group - -(defclass transient-group (transient-child) - ((suffixes :initarg :suffixes :initform nil) - (hide :initarg :hide :initform nil) - (description :initarg :description :initform nil) - (pad-keys :initarg :pad-keys :initform nil) - (info-format :initarg :info-format :initform nil) - (setup-children :initarg :setup-children)) - "Abstract superclass of all group classes." - :abstract t) - -(defclass transient-column (transient-group) () - "Group class that displays each element on a separate line.") - -(defclass transient-row (transient-group) () - "Group class that displays all elements on a single line.") - -(defclass transient-columns (transient-group) () - "Group class that displays elements organized in columns. -Direct elements have to be groups whose elements have to be -commands or strings. Each subgroup represents a column. -This class takes care of inserting the subgroups' elements.") - -(defclass transient-subgroups (transient-group) () - "Group class that wraps other groups. - -Direct elements have to be groups whose elements have to be -commands or strings. This group inserts an empty line between -subgroups. The subgroups are responsible for displaying their -elements themselves.") - -;;; Define - -(defmacro transient-define-prefix (name arglist &rest args) - "Define NAME as a transient prefix command. - -ARGLIST are the arguments that command takes. -DOCSTRING is the documentation string and is optional. - -These arguments can optionally be followed by key-value pairs. -Each key has to be a keyword symbol, either `:class' or a keyword -argument supported by the constructor of that class. The -`transient-prefix' class is used if the class is not specified -explicitly. - -GROUPs add key bindings for infix and suffix commands and specify -how these bindings are presented in the popup buffer. At least -one GROUP has to be specified. See info node `(transient)Binding -Suffix and Infix Commands'. - -The BODY is optional. If it is omitted, then ARGLIST is also -ignored and the function definition becomes: - - (lambda () - (interactive) - (transient-setup \\='NAME)) - -If BODY is specified, then it must begin with an `interactive' -form that matches ARGLIST, and it must call `transient-setup'. -It may however call that function only when some condition is -satisfied; that is one of the reason why you might want to use -an explicit BODY. - -All transients have a (possibly nil) value, which is exported -when suffix commands are called, so that they can consume that -value. For some transients it might be necessary to have a sort -of secondary value, called a scope. Such a scope would usually -be set in the commands `interactive' form and has to be passed -to the setup function: - - (transient-setup \\='NAME nil nil :scope SCOPE) - -\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" - (declare (debug ( &define name lambda-list - [&optional lambda-doc] - [&rest keywordp sexp] - [&rest vectorp] - [&optional ("interactive" interactive) def-body])) - (indent defun) - (doc-string 3)) - (pcase-let - ((`(,class ,slots ,suffixes ,docstr ,body ,interactive-only) - (transient--expand-define-args args arglist 'transient-define-prefix))) - `(progn - (defalias ',name - ,(if body - `(lambda ,arglist ,@body) - `(lambda () - (interactive) - (transient-setup ',name)))) - (put ',name 'interactive-only ,interactive-only) - (put ',name 'function-documentation ,docstr) - (put ',name 'transient--prefix - (,(or class 'transient-prefix) :command ',name ,@slots)) - (put ',name 'transient--layout - (list ,@(cl-mapcan (lambda (s) (transient--parse-child name s)) - suffixes)))))) - -(defmacro transient-define-suffix (name arglist &rest args) - "Define NAME as a transient suffix command. - -ARGLIST are the arguments that the command takes. -DOCSTRING is the documentation string and is optional. - -These arguments can optionally be followed by key-value pairs. -Each key has to be a keyword symbol, either `:class' or a -keyword argument supported by the constructor of that class. -The `transient-suffix' class is used if the class is not -specified explicitly. - -The BODY must begin with an `interactive' form that matches -ARGLIST. The infix arguments are usually accessed by using -`transient-args' inside `interactive'. - -\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... [BODY...])" - (declare (debug ( &define name lambda-list - [&optional lambda-doc] - [&rest keywordp sexp] - [&optional ("interactive" interactive) def-body])) - (indent defun) - (doc-string 3)) - (pcase-let - ((`(,class ,slots ,_ ,docstr ,body ,interactive-only) - (transient--expand-define-args args arglist 'transient-define-suffix))) - `(progn - (defalias ',name - ,(if (and (not body) class (oref-default class definition)) - `(oref-default ',class definition) - `(lambda ,arglist ,@body))) - (put ',name 'interactive-only ,interactive-only) - (put ',name 'function-documentation ,docstr) - (put ',name 'transient--suffix - (,(or class 'transient-suffix) :command ',name ,@slots))))) - -(defmacro transient-augment-suffix (name &rest args) - "Augment existing command NAME with a new transient suffix object. -Similar to `transient-define-suffix' but define a suffix object only. -\n\(fn NAME [KEYWORD VALUE]...)" - (declare (debug (&define name [&rest keywordp sexp])) - (indent defun)) - (pcase-let - ((`(,class ,slots) - (transient--expand-define-args args nil 'transient-augment-suffix t))) - `(put ',name 'transient--suffix - (,(or class 'transient-suffix) :command ',name ,@slots)))) - -(defmacro transient-define-infix (name arglist &rest args) - "Define NAME as a transient infix command. - -ARGLIST is always ignored and reserved for future use. -DOCSTRING is the documentation string and is optional. - -At least one key-value pair is required. All transient infix -commands are equal to each other (but not eq). It is meaning- -less to define an infix command, without providing at least one -keyword argument (usually `:argument' or `:variable', depending -on the class). The suffix class defaults to `transient-switch' -and can be set using the `:class' keyword. - -The function definitions is always: - - (lambda () - (interactive) - (let ((obj (transient-suffix-object))) - (transient-infix-set obj (transient-infix-read obj))) - (transient--show)) - -`transient-infix-read' and `transient-infix-set' are generic -functions. Different infix commands behave differently because -the concrete methods are different for different infix command -classes. In rare case the above command function might not be -suitable, even if you define your own infix command class. In -that case you have to use `transient-define-suffix' to define -the infix command and use t as the value of the `:transient' -keyword. - -\(fn NAME ARGLIST [DOCSTRING] KEYWORD VALUE [KEYWORD VALUE]...)" - (declare (debug ( &define name lambda-list - [&optional lambda-doc] - keywordp sexp - [&rest keywordp sexp])) - (indent defun) - (doc-string 3)) - (pcase-let - ((`(,class ,slots ,_ ,docstr ,_ ,interactive-only) - (transient--expand-define-args args arglist 'transient-define-infix t))) - `(progn - (defalias ',name #'transient--default-infix-command) - (put ',name 'interactive-only ,interactive-only) - (put ',name 'completion-predicate #'transient--suffix-only) - (put ',name 'function-documentation ,docstr) - (put ',name 'transient--suffix - (,(or class 'transient-switch) :command ',name ,@slots))))) - -(defalias 'transient-define-argument #'transient-define-infix - "Define NAME as a transient infix command. - -Only use this alias to define an infix command that actually -sets an infix argument. To define a infix command that, for -example, sets a variable, use `transient-define-infix' instead. - -\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)") - -(defun transient--default-infix-command () - ;; Most infix commands are but an alias for this command. - "Cannot show any documentation for this transient infix command. - -When you request help for an infix command using `transient-help', that -usually shows the respective man-page and tries to jump to the location -where the respective argument is being described. - -If no man-page is specified for the containing transient menu, then the -docstring is displayed instead, if any. - -If the infix command doesn't have a docstring, as is the case here, then -this docstring is displayed instead, because technically infix commands -are aliases for `transient--default-infix-command'. - -`describe-function' also shows the docstring of the infix command, -falling back to that of the same aliased command." - (interactive) - (let ((obj (transient-suffix-object))) - (transient-infix-set obj (transient-infix-read obj))) - (transient--show)) -(put 'transient--default-infix-command 'interactive-only t) -(put 'transient--default-infix-command 'completion-predicate - #'transient--suffix-only) - -(define-advice find-function-advised-original - (:around (fn func) transient-default-infix) - "Return nil instead of `transient--default-infix-command'. -When using `find-function' to jump to the definition of a transient -infix command/argument, then we want to actually jump to that, not to -the definition of `transient--default-infix-command', which all infix -commands are aliases for." - (let ((val (funcall fn func))) - (and val (not (eq val 'transient--default-infix-command)) val))) - -(eval-and-compile ;transient--expand-define-args - (defun transient--expand-define-args (args &optional arglist form nobody) - ;; ARGLIST and FORM are only optional for backward compatibility. - ;; This is necessary because "emoji.el" from Emacs 29 calls this - ;; function directly, with just one argument. - (unless (listp arglist) - (error "Mandatory ARGLIST is missing")) - (let (class keys suffixes docstr declare (interactive-only t)) - (when (stringp (car args)) - (setq docstr (pop args))) - (while (keywordp (car args)) - (let ((k (pop args)) - (v (pop args))) - (if (eq k :class) - (setq class v) - (push k keys) - (push v keys)))) - (while (let ((arg (car args))) - (or (vectorp arg) - (and arg (symbolp arg)))) - (push (pop args) suffixes)) - (when (eq (car-safe (car args)) 'declare) - (setq declare (car args)) - (setq args (cdr args)) - (when-let ((int (assq 'interactive-only declare))) - (setq interactive-only (cadr int)) - (delq int declare)) - (unless (cdr declare) - (setq declare nil))) - (cond - ((not args)) - (nobody - (error "%s: No function body allowed" form)) - ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive)) - (error "%s: Interactive form missing" form))) - (list (if (eq (car-safe class) 'quote) - (cadr class) - class) - (nreverse keys) - (nreverse suffixes) - docstr - (if declare (cons declare args) args) - interactive-only)))) - -(defun transient--parse-child (prefix spec) - (cl-typecase spec - (null (error "Invalid transient--parse-child spec: %s" spec)) - (symbol (let ((value (symbol-value spec))) - (if (and (listp value) - (or (listp (car value)) - (vectorp (car value)))) - (cl-mapcan (lambda (s) (transient--parse-child prefix s)) value) - (transient--parse-child prefix value)))) - (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) - (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) - (string (list spec)) - (t (error "Invalid transient--parse-child spec: %s" spec)))) - -(defun transient--parse-group (prefix spec) - (let ((spec (append spec nil)) - level class args) - (when (integerp (car spec)) - (setq level (pop spec))) - (when (stringp (car spec)) - (setq args (plist-put args :description (pop spec)))) - (while (keywordp (car spec)) - (let* ((key (pop spec)) - (val (if spec (pop spec) (error "No value for `%s'" key)))) - (cond ((eq key :class) - (setq class val)) - ((or (symbolp val) - (and (listp val) (not (eq (car val) 'lambda)))) - (setq args (plist-put args key (macroexp-quote val)))) - ((setq args (plist-put args key val)))))) - (unless (or spec class (not (plist-get args :setup-children))) - (message "WARNING: %s: When %s is used, %s must also be specified" - 'transient-define-prefix :setup-children :class)) - (list 'vector - (or level transient--default-child-level) - (list 'quote - (cond (class) - ((cl-typep (car spec) - '(or vector (and symbol (not null)))) - 'transient-columns) - ('transient-column))) - (and args (cons 'list args)) - (cons 'list - (cl-mapcan (lambda (s) (transient--parse-child prefix s)) - spec))))) - -(defun transient--parse-suffix (prefix spec) - (let (level class args) - (cl-flet ((use (prop value) - (setq args (plist-put args prop value)))) - (pcase (car spec) - ((cl-type integer) - (setq level (pop spec)))) - (pcase (car spec) - ((cl-type (or string vector)) - (use :key (pop spec)))) - (pcase (car spec) - ((guard (or (stringp (car spec)) - (and (eq (car-safe (car spec)) 'lambda) - (not (commandp (car spec)))))) - (use :description (pop spec))) - ((and (cl-type (and symbol (not keyword) (not command))) - (guard (commandp (cadr spec)))) - (use :description (macroexp-quote (pop spec))))) - (pcase (car spec) - ((or :info :info*)) - ((and (cl-type keyword) invalid) - (error "Need command, argument, `:info' or `:info*'; got `%s'" invalid)) - ((cl-type symbol) - (use :command (macroexp-quote (pop spec)))) - ;; During macro-expansion this is expected to be a `lambda' - ;; expression (i.e., source code). When this is called from a - ;; `:setup-children' function, it may also be a function object - ;; (a.k.a a function value). However, we never treat a string - ;; as a command, so we have to check for that explicitly. - ((cl-type (and command (not string))) - (let ((cmd (pop spec)) - (sym (intern - (format - "transient:%s:%s:%d" prefix - (replace-regexp-in-string (plist-get args :key) " " "") - (prog1 gensym-counter (cl-incf gensym-counter)))))) - (use :command - `(prog1 ',sym - (put ',sym 'interactive-only t) - (put ',sym 'completion-predicate #'transient--suffix-only) - (defalias ',sym ,cmd))))) - ((cl-type (or string (and list (not null)))) - (let ((arg (pop spec))) - (cl-typecase arg - (list - (use :shortarg (car arg)) - (use :argument (cadr arg)) - (setq arg (cadr arg))) - (string - (when-let ((shortarg (transient--derive-shortarg arg))) - (use :shortarg shortarg)) - (use :argument arg))) - (use :command - (let ((sym (intern (format "transient:%s:%s" prefix arg)))) - `(prog1 ',sym - (put ',sym 'interactive-only t) - (put ',sym 'completion-predicate #'transient--suffix-only) - (defalias ',sym #'transient--default-infix-command)))) - (pcase (car spec) - ((cl-type (and (not null) (not keyword))) - (setq class 'transient-option) - (use :reader (macroexp-quote (pop spec)))) - ((guard (string-suffix-p "=" arg)) - (setq class 'transient-option)) - (_ (setq class 'transient-switch))))) - (invalid - (error "Need command, argument, `:info' or `:info*'; got %s" invalid))) - (while (keywordp (car spec)) - (let* ((key (pop spec)) - (val (if spec (pop spec) (error "No value for `%s'" key)))) - (pcase key - (:class (setq class val)) - (:level (setq level val)) - (:info (setq class 'transient-information) - (use :description val)) - (:info* (setq class 'transient-information*) - (use :description val)) - ((guard (eq (car-safe val) '\,)) - (use key (cadr val))) - ((guard (or (symbolp val) - (and (listp val) (not (eq (car val) 'lambda))))) - (use key (macroexp-quote val))) - (_ (use key val))))) - (when spec - (error "Need keyword, got %S" (car spec))) - (when-let* (((not (plist-get args :key))) - (shortarg (plist-get args :shortarg))) - (use :key shortarg))) - (list 'list - (or level transient--default-child-level) - (macroexp-quote (or class 'transient-suffix)) - (cons 'list args)))) - -(defun transient--derive-shortarg (arg) - (save-match-data - (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) - (match-string 1 arg)))) - -(defun transient-command-completion-not-suffix-only-p (symbol _buffer) - "Say whether SYMBOL should be offered as a completion. -If the value of SYMBOL's `completion-predicate' property is -`transient--suffix-only', then return nil, otherwise return t. -This is the case when a command should only ever be used as a -suffix of a transient prefix command (as opposed to bindings -in regular keymaps or by using `execute-extended-command')." - (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) - -(defalias 'transient--suffix-only #'ignore - "Ignore ARGUMENTS, do nothing, and return nil. -Also see `transient-command-completion-not-suffix-only-p'. -Only use this alias as the value of the `completion-predicate' -symbol property.") - -(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 - (not read-extended-command-predicate)) - (setq read-extended-command-predicate - #'transient-command-completion-not-suffix-only-p)) - -(defun transient-parse-suffix (prefix suffix) - "Parse SUFFIX, to be added to PREFIX. -PREFIX is a prefix command, a symbol. -SUFFIX is a suffix command or a group specification (of - the same forms as expected by `transient-define-prefix'). -Intended for use in a group's `:setup-children' function." - (cl-assert (and prefix (symbolp prefix))) - (eval (car (transient--parse-child prefix suffix)) t)) - -(defun transient-parse-suffixes (prefix suffixes) - "Parse SUFFIXES, to be added to PREFIX. -PREFIX is a prefix command, a symbol. -SUFFIXES is a list of suffix command or a group specification - (of the same forms as expected by `transient-define-prefix'). -Intended for use in a group's `:setup-children' function." - (cl-assert (and prefix (symbolp prefix))) - (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) - -;;; Edit - -(defun transient--insert-suffix (prefix loc suffix action &optional keep-other) - (let* ((suf (cl-etypecase suffix - (vector (transient--parse-group prefix suffix)) - (list (transient--parse-suffix prefix suffix)) - (string suffix))) - (mem (transient--layout-member loc prefix)) - (elt (car mem))) - (setq suf (eval suf t)) - (cond - ((not mem) - (message "Cannot insert %S into %s; %s not found" - suffix prefix loc)) - ((or (and (vectorp suffix) (not (vectorp elt))) - (and (listp suffix) (vectorp elt)) - (and (stringp suffix) (vectorp elt))) - (message "Cannot place %S into %s at %s; %s" - suffix prefix loc - "suffixes and groups cannot be siblings")) - (t - (when-let* ((bindingp (listp suf)) - (key (transient--spec-key suf)) - (conflict (car (transient--layout-member key prefix))) - (conflictp - (and (not (and (eq action 'replace) - (eq conflict elt))) - (or (not keep-other) - (eq (plist-get (nth 2 suf) :command) - (plist-get (nth 2 conflict) :command))) - (equal (transient--suffix-predicate suf) - (transient--suffix-predicate conflict))))) - (transient-remove-suffix prefix key)) - (pcase-exhaustive action - ('insert (setcdr mem (cons elt (cdr mem))) - (setcar mem suf)) - ('append (setcdr mem (cons suf (cdr mem)))) - ('replace (setcar mem suf))))))) - -;;;###autoload -(defun transient-insert-suffix (prefix loc suffix &optional keep-other) - "Insert a SUFFIX into PREFIX before LOC. -PREFIX is a prefix command, a symbol. -SUFFIX is a suffix command or a group specification (of - the same forms as expected by `transient-define-prefix'). -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -Remove a conflicting binding unless optional KEEP-OTHER is - non-nil. -See info node `(transient)Modifying Existing Transients'." - (declare (indent defun)) - (transient--insert-suffix prefix loc suffix 'insert keep-other)) - -;;;###autoload -(defun transient-append-suffix (prefix loc suffix &optional keep-other) - "Insert a SUFFIX into PREFIX after LOC. -PREFIX is a prefix command, a symbol. -SUFFIX is a suffix command or a group specification (of - the same forms as expected by `transient-define-prefix'). -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -Remove a conflicting binding unless optional KEEP-OTHER is - non-nil. -See info node `(transient)Modifying Existing Transients'." - (declare (indent defun)) - (transient--insert-suffix prefix loc suffix 'append keep-other)) - -;;;###autoload -(defun transient-replace-suffix (prefix loc suffix) - "Replace the suffix at LOC in PREFIX with SUFFIX. -PREFIX is a prefix command, a symbol. -SUFFIX is a suffix command or a group specification (of - the same forms as expected by `transient-define-prefix'). -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -See info node `(transient)Modifying Existing Transients'." - (declare (indent defun)) - (transient--insert-suffix prefix loc suffix 'replace)) - -;;;###autoload -(defun transient-remove-suffix (prefix loc) - "Remove the suffix or group at LOC in PREFIX. -PREFIX is a prefix command, a symbol. -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -See info node `(transient)Modifying Existing Transients'." - (declare (indent defun)) - (transient--layout-member loc prefix 'remove)) - -(defun transient-get-suffix (prefix loc) - "Return the suffix or group at LOC in PREFIX. -PREFIX is a prefix command, a symbol. -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -See info node `(transient)Modifying Existing Transients'." - (if-let ((mem (transient--layout-member loc prefix))) - (car mem) - (error "%s not found in %s" loc prefix))) - -(defun transient-suffix-put (prefix loc prop value) - "Edit the suffix at LOC in PREFIX, setting PROP to VALUE. -PREFIX is a prefix command, a symbol. -SUFFIX is a suffix command or a group specification (of - the same forms as expected by `transient-define-prefix'). -LOC is a command, a key vector, a key description (a string - as returned by `key-description'), or a coordination list - (whose last element may also be a command or key). -See info node `(transient)Modifying Existing Transients'." - (let ((suf (transient-get-suffix prefix loc))) - (setf (elt suf 2) - (plist-put (elt suf 2) prop value)))) - -(defun transient--layout-member (loc prefix &optional remove) - (let ((val (or (get prefix 'transient--layout) - (error "%s is not a transient command" prefix)))) - (when (listp loc) - (while (integerp (car loc)) - (let* ((children (if (vectorp val) (aref val 3) val)) - (mem (transient--nthcdr (pop loc) children))) - (if (and remove (not loc)) - (let ((rest (delq (car mem) children))) - (if (vectorp val) - (aset val 3 rest) - (put prefix 'transient--layout rest)) - (setq val nil)) - (setq val (if loc (car mem) mem))))) - (setq loc (car loc))) - (if loc - (transient--layout-member-1 (transient--kbd loc) val remove) - val))) - -(defun transient--layout-member-1 (loc layout remove) - (cond ((listp layout) - (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove)) - layout)) - ((vectorp (car (aref layout 3))) - (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove)) - (aref layout 3))) - (remove - (aset layout 3 - (delq (car (transient--group-member loc layout)) - (aref layout 3))) - nil) - ((transient--group-member loc layout)))) - -(defun transient--group-member (loc group) - (cl-member-if (lambda (suffix) - (and (listp suffix) - (let* ((def (nth 2 suffix)) - (cmd (plist-get def :command))) - (if (symbolp loc) - (eq cmd loc) - (equal (transient--kbd - (or (plist-get def :key) - (transient--command-key cmd))) - loc))))) - (aref group 3))) - -(defun transient--kbd (keys) - (when (vectorp keys) - (setq keys (key-description keys))) - (when (stringp keys) - (setq keys (kbd keys))) - keys) - -(defun transient--spec-key (spec) - (let ((plist (nth 2 spec))) - (or (plist-get plist :key) - (transient--command-key - (plist-get plist :command))))) - -(defun transient--command-key (cmd) - (and-let* ((obj (transient--suffix-prototype cmd))) - (cond ((slot-boundp obj 'key) - (oref obj key)) - ((slot-exists-p obj 'shortarg) - (if (slot-boundp obj 'shortarg) - (oref obj shortarg) - (transient--derive-shortarg (oref obj argument))))))) - -(defun transient--nthcdr (n list) - (nthcdr (if (< n 0) (- (length list) (abs n)) n) list)) - -;;; Variables - -(defvar transient-current-prefix nil - "The transient from which this suffix command was invoked. -This is an object representing that transient, use -`transient-current-command' to get the respective command.") - -(defvar transient-current-command nil - "The transient from which this suffix command was invoked. -This is a symbol representing that transient, use -`transient-current-prefix' to get the respective object.") - -(defvar transient-current-suffixes nil - "The suffixes of the transient from which this suffix command was invoked. -This is a list of objects. Usually it is sufficient to instead -use the function `transient-args', which returns a list of -values. In complex cases it might be necessary to use this -variable instead.") - -(defvar transient-exit-hook nil - "Hook run after exiting a transient.") - -(defvar transient-setup-buffer-hook nil - "Hook run when setting up the transient buffer. -That buffer is current and empty when this hook runs.") - -(defvar transient--prefix nil) -(defvar transient--layout nil) -(defvar transient--suffixes nil) - -(defconst transient--stay t "Do not exit the transient.") -(defconst transient--exit nil "Do exit the transient.") - -(defvar transient--exitp nil "Whether to exit the transient.") -(defvar transient--showp nil "Whether to show the transient popup buffer.") -(defvar transient--helpp nil "Whether help-mode is active.") -(defvar transient--editp nil "Whether edit-mode is active.") - -(defvar transient--refreshp nil - "Whether to refresh the transient completely.") - -(defvar transient--all-levels-p nil - "Whether temporary display of suffixes on all levels is active.") - -(defvar transient--timer nil) - -(defvar transient--stack nil) - -(defvar transient--minibuffer-depth 0) - -(defvar transient--buffer-name " *transient*" - "Name of the transient buffer.") - -(defvar transient--buffer nil - "The transient menu buffer.") - -(defvar transient--window nil - "The window used to display the transient popup buffer.") - -(defvar transient--original-window nil - "The window that was selected before the transient was invoked. -Usually it remains selected while the transient is active.") - -(defvar transient--original-buffer nil - "The buffer that was current before the transient was invoked. -Usually it remains current while the transient is active.") - -(defvar transient--restore-winconf nil - "Window configuration to restore after exiting help.") - -(defvar transient--shadowed-buffer nil - "The buffer that is temporarily shadowed by the transient buffer. -This is bound while the suffix predicate is being evaluated and while -drawing in the transient buffer.") - -(defvar transient--pending-suffix nil - "The suffix that is currently being processed. -This is bound while the suffix predicate is being evaluated, -and while functions that return faces are being evaluated.") - -(defvar transient--pending-group nil - "The group that is currently being processed. -This is bound while the suffixes are drawn in the transient buffer.") - -(defvar transient--debug nil - "Whether to put debug information into *Messages*.") - -(defvar transient--history nil) - -(defvar transient--scroll-commands - '(transient-scroll-up - transient-scroll-down - mwheel-scroll - scroll-bar-toolkit-scroll)) - -;;; Identities - -(defun transient-active-prefix (&optional prefixes) - "Return the active transient object. - -Return nil if there is no active transient, if the transient buffer -isn't shown, and while the active transient is suspended (e.g., while -the minibuffer is in use). - -Unlike `transient-current-prefix', which is only ever non-nil in code -that is run directly by a command that is invoked while a transient -is current, this function is also suitable for use in asynchronous -code, such as timers and callbacks (this function's main use-case). - -If optional PREFIXES is non-nil, it must be a prefix command symbol -or a list of symbols, in which case the active transient object is -only returned if it matches one of PREFIXES." - (and transient--showp - transient--prefix - (or (not prefixes) - (memq (oref transient--prefix command) (ensure-list prefixes))) - (or (memq 'transient--pre-command pre-command-hook) - (and (memq t pre-command-hook) - (memq 'transient--pre-command - (default-value 'pre-command-hook)))) - transient--prefix)) - -(defun transient-prefix-object () - "Return the current prefix as an object. - -While a transient is being setup or refreshed (which involves -preparing its suffixes) the variable `transient--prefix' can be -used to access the prefix object. Thus this is what has to be -used in suffix methods such as `transient-format-description', -and in object-specific functions that are stored in suffix slots -such as `description'. - -When a suffix command is invoked (i.e., in its `interactive' form -and function body) then the variable `transient-current-prefix' -has to be used instead. - -Two distinct variables are needed, because any prefix may itself -be used as a suffix of another prefix, and such sub-prefixes have -to be able to tell themselves apart from the prefix they were -invoked from. - -Regular suffix commands, which are not prefixes, do not have to -concern themselves with this distinction, so they can use this -function instead. In the context of a plain suffix, it always -returns the value of the appropriate variable." - (or transient--prefix transient-current-prefix)) - -(defun transient-suffix-object (&optional command) - "Return the object associated with the current suffix command. - -Each suffix commands is associated with an object, which holds -additional information about the suffix, such as its value (in -the case of an infix command, which is a kind of suffix command). - -This function is intended to be called by infix commands, which -are usually aliases of `transient--default-infix-command', which -is defined like this: - - (defun transient--default-infix-command () - (interactive) - (let ((obj (transient-suffix-object))) - (transient-infix-set obj (transient-infix-read obj))) - (transient--show)) - -\(User input is read outside of `interactive' to prevent the -command from being added to `command-history'. See #23.) - -Such commands need to be able to access their associated object -to guide how `transient-infix-read' reads the new value and to -store the read value. Other suffix commands (including non-infix -commands) may also need the object to guide their behavior. - -This function attempts to return the object associated with the -current suffix command even if the suffix command was not invoked -from a transient. (For some suffix command that is a valid thing -to do, for others it is not.) In that case nil may be returned, -if the command was not defined using one of the macros intended -to define such commands. - -The optional argument COMMAND is intended for internal use. If -you are contemplating using it in your own code, then you should -probably use this instead: - - (get COMMAND \\='transient--suffix)" - (when command - (cl-check-type command command)) - (cond - (transient--pending-suffix) - ((or transient--prefix - transient-current-prefix) - (let ((suffixes - (cl-remove-if-not - (lambda (obj) - (eq (oref obj command) - (or command - (if (eq this-command 'transient-set-level) - ;; This is how it can look up for which - ;; command it is setting the level. - this-original-command - this-command)))) - (or transient--suffixes - transient-current-suffixes)))) - (or (if (cdr suffixes) - (cl-find-if - (lambda (obj) - (equal (listify-key-sequence (transient--kbd (oref obj key))) - (listify-key-sequence (this-command-keys)))) - suffixes) - (car suffixes)) - ;; COMMAND is only provided if `this-command' is meaningless, in - ;; which case `this-command-keys' is also meaningless, making it - ;; impossible to disambiguate redundant bindings. - (if command - (car suffixes) - (error "BUG: Cannot determine suffix object"))))) - ((and-let* ((obj (transient--suffix-prototype (or command this-command))) - (obj (clone obj))) - (progn ; work around debbugs#31840 - (transient-init-scope obj) - (transient-init-value obj) - obj))))) - -(defun transient--suffix-prototype (command) - (or (get command 'transient--suffix) - (seq-some (lambda (cmd) (get cmd 'transient--suffix)) - (function-alias-p command)))) - -;;; Keymaps - -(defvar-keymap transient-base-map - :doc "Parent of other keymaps used by Transient. - -This is the parent keymap of all the keymaps that are used in -all transients: `transient-map' (which in turn is the parent -of the transient-specific keymaps), `transient-edit-map' and -`transient-sticky-map'. - -If you change a binding here, then you might also have to edit -`transient-sticky-map' and `transient-common-commands'. While -the latter isn't a proper transient prefix command, it can be -edited using the same functions as used for transients. - -If you add a new command here, then you must also add a binding -to `transient-predicate-map'." - "ESC ESC ESC" #'transient-quit-all - "C-g" #'transient-quit-one - "C-q" #'transient-quit-all - "C-z" #'transient-suspend - "C-v" #'transient-scroll-up - "C-M-v" #'transient-scroll-down - "<next>" #'transient-scroll-up - "<prior>" #'transient-scroll-down) - -(defvar transient-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map transient-base-map) - (keymap-set map "C-u" #'universal-argument) - (keymap-set map "C--" #'negative-argument) - (keymap-set map "C-t" #'transient-show) - (keymap-set map "?" #'transient-help) - (keymap-set map "C-h" #'transient-help) - ;; Also bound to "C-x p" and "C-x n" in transient-common-commands. - (keymap-set map "C-M-p" #'transient-history-prev) - (keymap-set map "C-M-n" #'transient-history-next) - (when (fboundp 'other-frame-prefix) ;Emacs >= 28.1 - (keymap-set map "C-x 5 5" 'other-frame-prefix) - (keymap-set map "C-x 4 4" 'other-window-prefix)) - map) - "Top-level keymap used by all transients. - -If you add a new command here, then you must also add a binding -to `transient-predicate-map'. Also see `transient-base-map'.") - -(defvar-keymap transient-edit-map - :doc "Keymap that is active while a transient in is in \"edit mode\"." - :parent transient-base-map - "?" #'transient-help - "C-h" #'transient-help - "C-x l" #'transient-set-level) - -(defvar-keymap transient-sticky-map - :doc "Keymap that is active while an incomplete key sequence is active." - :parent transient-base-map - "C-g" #'transient-quit-seq) - -(defvar transient--common-command-prefixes '(?\C-x)) - -(put 'transient-common-commands - 'transient--layout - (list - (eval - (car (transient--parse-child - 'transient-common-commands - (vector - :hide - (lambda () - (and (not (memq - (car (bound-and-true-p transient--redisplay-key)) - transient--common-command-prefixes)) - (not transient-show-common-commands))) - (vector - "Value commands" - (list "C-x s " "Set" #'transient-set) - (list "C-x C-s" "Save" #'transient-save) - (list "C-x C-k" "Reset" #'transient-reset) - (list "C-x p " "Previous value" #'transient-history-prev) - (list "C-x n " "Next value" #'transient-history-next)) - (vector - "Sticky commands" - ;; Like `transient-sticky-map' except that - ;; "C-g" has to be bound to a different command. - (list "C-g" "Quit prefix or transient" #'transient-quit-one) - (list "C-q" "Quit transient stack" #'transient-quit-all) - (list "C-z" "Suspend transient stack" #'transient-suspend)) - (vector - "Customize" - (list "C-x t" 'transient-toggle-common :description - (lambda () - (if transient-show-common-commands - "Hide common commands" - "Show common permanently"))) - (list "C-x l" "Show/hide suffixes" #'transient-set-level) - (list "C-x a" #'transient-toggle-level-limit))))) - t))) - -(defvar-keymap transient-popup-navigation-map - :doc "One of the keymaps used when popup navigation is enabled. -See `transient-enable-popup-navigation'." - "<down-mouse-1>" #'transient-noop - "<up>" #'transient-backward-button - "<down>" #'transient-forward-button - "C-r" #'transient-isearch-backward - "C-s" #'transient-isearch-forward - "M-RET" #'transient-push-button) - -(defvar-keymap transient-button-map - :doc "One of the keymaps used when popup navigation is enabled. -See `transient-enable-popup-navigation'." - "<mouse-1>" #'transient-push-button - "<mouse-2>" #'transient-push-button) - -(defvar-keymap transient-resume-mode-map - :doc "Keymap for `transient-resume-mode'. - -This keymap remaps every command that would usually just quit the -documentation buffer to `transient-resume', which additionally -resumes the suspended transient." - "<remap> <Man-quit>" #'transient-resume - "<remap> <Info-exit>" #'transient-resume - "<remap> <quit-window>" #'transient-resume) - -(defvar-keymap transient-predicate-map - :doc "Base keymap used to map common commands to their transient behavior. - -The \"transient behavior\" of a command controls, among other -things, whether invoking the command causes the transient to be -exited or not, and whether infix arguments are exported before -doing so. - -Each \"key\" is a command that is common to all transients and -that is bound in `transient-map', `transient-edit-map', -`transient-sticky-map' and/or `transient-common-command'. - -Each binding is a \"pre-command\", a function that controls the -transient behavior of the respective command. - -For transient commands that are bound in individual transients, -the transient behavior is specified using the `:transient' slot -of the corresponding object." - "<transient-suspend>" #'transient--do-suspend - "<transient-help>" #'transient--do-stay - "<transient-set-level>" #'transient--do-stay - "<transient-history-prev>" #'transient--do-stay - "<transient-history-next>" #'transient--do-stay - "<universal-argument>" #'transient--do-stay - "<universal-argument-more>" #'transient--do-stay - "<negative-argument>" #'transient--do-minus - "<digit-argument>" #'transient--do-stay - "<other-frame-prefix>" #'transient--do-stay - "<other-window-prefix>" #'transient--do-stay - "<top-level>" #'transient--do-quit-all - "<transient-quit-all>" #'transient--do-quit-all - "<transient-quit-one>" #'transient--do-quit-one - "<transient-quit-seq>" #'transient--do-stay - "<transient-show>" #'transient--do-stay - "<transient-update>" #'transient--do-stay - "<transient-toggle-common>" #'transient--do-stay - "<transient-set>" #'transient--do-call - "<transient-set-and-exit>" #'transient--do-exit - "<transient-save>" #'transient--do-call - "<transient-save-and-exit>" #'transient--do-exit - "<transient-reset>" #'transient--do-call - "<describe-key-briefly>" #'transient--do-stay - "<describe-key>" #'transient--do-stay - "<transient-scroll-up>" #'transient--do-stay - "<transient-scroll-down>" #'transient--do-stay - "<mwheel-scroll>" #'transient--do-stay - "<scroll-bar-toolkit-scroll>" #'transient--do-stay - "<transient-noop>" #'transient--do-noop - "<transient-mouse-push-button>" #'transient--do-move - "<transient-push-button>" #'transient--do-push-button - "<transient-backward-button>" #'transient--do-move - "<transient-forward-button>" #'transient--do-move - "<transient-isearch-backward>" #'transient--do-move - "<transient-isearch-forward>" #'transient--do-move - ;; If a valid but incomplete prefix sequence is followed by - ;; an unbound key, then Emacs calls the `undefined' command - ;; but does not set `this-command', `this-original-command' - ;; or `real-this-command' accordingly. Instead they are nil. - "<nil>" #'transient--do-warn - ;; Bound to the `mouse-movement' event, this command is similar - ;; to `ignore'. - "<ignore-preserving-kill-region>" #'transient--do-noop) - -(defvar transient--transient-map nil) -(defvar transient--predicate-map nil) -(defvar transient--redisplay-map nil) -(defvar transient--redisplay-key nil) - -(defun transient--push-keymap (var) - (let ((map (symbol-value var))) - (transient--debug " push %s%s" var (if map "" " VOID")) - (when map - (with-demoted-errors "transient--push-keymap: %S" - (internal-push-keymap map 'overriding-terminal-local-map))))) - -(defun transient--pop-keymap (var) - (let ((map (symbol-value var))) - (when map - (transient--debug " pop %s" var) - (with-demoted-errors "transient--pop-keymap: %S" - (internal-pop-keymap map 'overriding-terminal-local-map))))) - -(defun transient--make-transient-map () - (let ((map (make-sparse-keymap))) - (set-keymap-parent map (if transient--editp - transient-edit-map - transient-map)) - (dolist (obj transient--suffixes) - (let ((key (oref obj key))) - (when (vectorp key) - (setq key (key-description key)) - (oset obj key key)) - (when transient-substitute-key-function - (setq key (save-match-data - (funcall transient-substitute-key-function obj))) - (oset obj key key)) - (let* ((kbd (kbd key)) - (cmd (oref obj command)) - (alt (transient--lookup-key map kbd))) - (cond ((not alt) - (define-key map kbd cmd)) - ((eq alt cmd)) - ((transient--inapt-suffix-p obj)) - ((and-let* ((obj (transient-suffix-object alt))) - (transient--inapt-suffix-p obj)) - (define-key map kbd cmd)) - (transient-detect-key-conflicts - (error "Cannot bind %S to %s and also %s" - (string-trim key) cmd alt)) - ((define-key map kbd cmd)))))) - (when-let ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) - (when-let ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) - (when-let ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) - (when transient-enable-popup-navigation - ;; `transient--make-redisplay-map' maps only over bindings that are - ;; directly in the base keymap, so that cannot be a composed keymap. - (set-keymap-parent - map (make-composed-keymap - (keymap-parent map) - transient-popup-navigation-map))) - map)) - -(defun transient--make-predicate-map () - (let* ((default (transient--resolve-pre-command - (oref transient--prefix transient-suffix))) - (return (and transient--stack (eq default t))) - (map (make-sparse-keymap))) - (set-keymap-parent map transient-predicate-map) - (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) - (transient--resolve-pre-command - (not (oref transient--prefix transient-switch-frame)))) - (memq (transient--resolve-pre-command - (oref transient--prefix transient-non-suffix)) - '(nil transient--do-warn transient--do-noop))) - (define-key map [handle-switch-frame] #'transient--do-suspend)) - (dolist (obj transient--suffixes) - (let* ((cmd (oref obj command)) - (kind (cond ((get cmd 'transient--prefix) 'prefix) - ((cl-typep obj 'transient-infix) 'infix) - (t 'suffix)))) - (cond - ((oref obj inapt) - (define-key map (vector cmd) #'transient--do-warn-inapt)) - ((slot-boundp obj 'transient) - (define-key map (vector cmd) - (pcase (list kind - (transient--resolve-pre-command (oref obj transient)) - return) - (`(prefix t ,_) #'transient--do-recurse) - (`(prefix nil ,_) #'transient--do-stack) - (`(infix t ,_) #'transient--do-stay) - (`(suffix t ,_) #'transient--do-call) - ('(suffix nil t) #'transient--do-return) - (`(,_ nil ,_) #'transient--do-exit) - (`(,_ ,do ,_) do)))) - ((not (lookup-key transient-predicate-map (vector cmd))) - (define-key map (vector cmd) - (pcase (list kind default return) - (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_) - #'transient--do-recurse) - (`(prefix t ,_) #'transient--do-recurse) - (`(prefix ,_ ,_) #'transient--do-stack) - (`(infix ,_ ,_) #'transient--do-stay) - (`(suffix t ,_) #'transient--do-call) - ('(suffix nil t) #'transient--do-return) - (`(suffix nil ,_) #'transient--do-exit) - (`(suffix ,do ,_) do))))))) - map)) - -(defun transient--make-redisplay-map () - (setq transient--redisplay-key - (pcase this-command - ('transient-update - (setq transient--showp t) - (let ((keys (listify-key-sequence (this-single-command-raw-keys)))) - (setq unread-command-events (mapcar (lambda (key) (cons t key)) keys)) - keys)) - ('transient-quit-seq - (setq unread-command-events - (butlast (listify-key-sequence - (this-single-command-raw-keys)) - 2)) - (butlast transient--redisplay-key)) - (_ nil))) - (let ((topmap (make-sparse-keymap)) - (submap (make-sparse-keymap))) - (when transient--redisplay-key - (define-key topmap (vconcat transient--redisplay-key) submap) - (set-keymap-parent submap transient-sticky-map)) - (map-keymap-internal - (lambda (key def) - (when (and (not (eq key ?\e)) - (listp def) - (keymapp def)) - (define-key topmap (vconcat transient--redisplay-key (list key)) - #'transient-update))) - (if transient--redisplay-key - (let ((key (vconcat transient--redisplay-key))) - (or (lookup-key transient--transient-map key) - (and-let* ((regular (lookup-key local-function-key-map key))) - (lookup-key transient--transient-map (vconcat regular))))) - transient--transient-map)) - topmap)) - -;;; Setup - -(defun transient-setup (&optional name layout edit &rest params) - "Setup the transient specified by NAME. - -This function is called by transient prefix commands to setup the -transient. In that case NAME is mandatory, LAYOUT and EDIT must -be nil and PARAMS may be (but usually is not) used to set, e.g., -the \"scope\" of the transient (see `transient-define-prefix'). - -This function is also called internally, in which case LAYOUT and -EDIT may be non-nil." - (transient--debug 'setup) - (transient--with-emergency-exit :setup - (cond - ((not name) - ;; Switching between regular and edit mode. - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (setq name (oref transient--prefix command)) - (setq params (list :scope (oref transient--prefix scope)))) - (transient--prefix - ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}" - ;; of an outer prefix. Unlike the usual `transient--do-stack', - ;; these predicates fail to clean up after the outer prefix. - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map)) - ((not (or layout ; resuming parent/suspended prefix - transient-current-command)) ; entering child prefix - (transient--stack-zap)) ; replace suspended prefix, if any - (edit - ;; Returning from help to edit. - (setq transient--editp t))) - (transient--env-apply - (lambda () - (transient--init-transient name layout params) - (transient--history-init transient--prefix) - (setq transient--original-window (selected-window)) - (setq transient--original-buffer (current-buffer)) - (setq transient--minibuffer-depth (minibuffer-depth)) - (transient--redisplay)) - (get name 'transient--prefix)) - (transient--setup-transient) - (transient--suspend-which-key-mode))) - -(cl-defgeneric transient-setup-children (group children) - "Setup the CHILDREN of GROUP. -If the value of the `setup-children' slot is non-nil, then call -that function with CHILDREN as the only argument and return the -value. Otherwise return CHILDREN as is." - (if (slot-boundp group 'setup-children) - (funcall (oref group setup-children) children) - children)) - -(defun transient--env-apply (fn &optional prefix) - (if-let ((env (oref (or prefix transient--prefix) environment))) - (funcall env fn) - (funcall fn))) - -(defun transient--init-transient (&optional name layout params) - (unless name - ;; Re-init. - (if (eq transient--refreshp 'updated-value) - ;; Preserve the prefix value this once, because the - ;; invoked suffix indicates that it has updated that. - (setq transient--refreshp (oref transient--prefix refresh-suffixes)) - ;; Otherwise update the prefix value from suffix values. - (oset transient--prefix value (transient-get-value)))) - (transient--init-objects name layout params) - (transient--init-keymaps)) - -(defun transient--init-keymaps () - (setq transient--predicate-map (transient--make-predicate-map)) - (setq transient--transient-map (transient--make-transient-map)) - (setq transient--redisplay-map (transient--make-redisplay-map))) - -(defun transient--init-objects (&optional name layout params) - (if name - (setq transient--prefix (transient--init-prefix name params)) - (setq name (oref transient--prefix command))) - (setq transient--refreshp (oref transient--prefix refresh-suffixes)) - (setq transient--layout (or layout (transient--init-suffixes name))) - (setq transient--suffixes (transient--flatten-suffixes transient--layout))) - -(defun transient--init-prefix (name &optional params) - (let ((obj (let ((proto (get name 'transient--prefix))) - (apply #'clone proto - :prototype proto - :level (or (alist-get t (alist-get name transient-levels)) - transient-default-level) - params)))) - (transient--setup-recursion obj) - (transient-init-value obj) - obj)) - -(defun transient--init-suffixes (name) - (let ((levels (alist-get name transient-levels))) - (cl-mapcan (lambda (c) (transient--init-child levels c nil)) - (append (get name 'transient--layout) - (and (not transient--editp) - (get 'transient-common-commands - 'transient--layout)))))) - -(defun transient--flatten-suffixes (layout) - (cl-labels ((s (def) - (cond - ((stringp def) nil) - ((cl-typep def 'transient-information) nil) - ((listp def) (cl-mapcan #'s def)) - ((cl-typep def 'transient-group) - (cl-mapcan #'s (oref def suffixes))) - ((cl-typep def 'transient-suffix) - (list def))))) - (cl-mapcan #'s layout))) - -(defun transient--init-child (levels spec parent) - (cl-etypecase spec - (vector (transient--init-group levels spec parent)) - (list (transient--init-suffix levels spec parent)) - (string (list spec)))) - -(defun transient--init-group (levels spec parent) - (pcase-let ((`(,level ,class ,args ,children) (append spec nil))) - (and-let* (((transient--use-level-p level)) - (obj (apply class :level level args)) - ((transient--use-suffix-p obj)) - ((prog1 t - (when (or (and parent (oref parent inapt)) - (transient--inapt-suffix-p obj)) - (oset obj inapt t)))) - (suffixes (cl-mapcan - (lambda (c) (transient--init-child levels c obj)) - (transient-setup-children obj children)))) - (progn ; work around debbugs#31840 - (oset obj suffixes suffixes) - (list obj))))) - -(defun transient--init-suffix (levels spec parent) - (pcase-let* ((`(,level ,class ,args) spec) - (cmd (plist-get args :command)) - (key (transient--kbd (plist-get args :key))) - (level (or (alist-get (cons cmd key) levels nil nil #'equal) - (alist-get cmd levels) - level))) - (let ((fn (and (symbolp cmd) - (symbol-function cmd)))) - (when (autoloadp fn) - (transient--debug " autoload %s" cmd) - (autoload-do-load fn))) - (when (transient--use-level-p level) - (let ((obj (if (child-of-class-p class 'transient-information) - (apply class :level level args) - (unless (and cmd (symbolp cmd)) - (error "BUG: Non-symbolic suffix command: %s" cmd)) - (if-let ((proto (and cmd (transient--suffix-prototype cmd)))) - (apply #'clone proto :level level args) - (apply class :command cmd :level level args))))) - (cond ((not cmd)) - ((commandp cmd)) - ((or (cl-typep obj 'transient-switch) - (cl-typep obj 'transient-option)) - ;; As a temporary special case, if the package was compiled - ;; with an older version of Transient, then we must define - ;; "anonymous" switch and option commands here. - (defalias cmd #'transient--default-infix-command)) - ((transient--use-suffix-p obj) - (error "Suffix command %s is not defined or autoloaded" cmd))) - (unless (cl-typep obj 'transient-information) - (transient--init-suffix-key obj)) - (when (transient--use-suffix-p obj) - (if (or (and parent (oref parent inapt)) - (transient--inapt-suffix-p obj)) - (oset obj inapt t) - (transient-init-scope obj) - (transient-init-value obj)) - (list obj)))))) - -(cl-defmethod transient--init-suffix-key ((obj transient-suffix)) - (unless (slot-boundp obj 'key) - (error "No key for %s" (oref obj command)))) - -(cl-defmethod transient--init-suffix-key ((obj transient-argument)) - (if (transient-switches--eieio-childp obj) - (cl-call-next-method obj) - (when-let* (((not (slot-boundp obj 'shortarg))) - (shortarg (transient--derive-shortarg (oref obj argument)))) - (oset obj shortarg shortarg)) - (unless (slot-boundp obj 'key) - (if (slot-boundp obj 'shortarg) - (oset obj key (oref obj shortarg)) - (error "No key for %s" (oref obj command)))))) - -(defun transient--use-level-p (level &optional edit) - (or transient--all-levels-p - (and transient--editp (not edit)) - (and (>= level 1) - (<= level (oref transient--prefix level))))) - -(defun transient--use-suffix-p (obj) - (let ((transient--shadowed-buffer (current-buffer)) - (transient--pending-suffix obj)) - (transient--do-suffix-p - (oref obj if) - (oref obj if-not) - (oref obj if-nil) - (oref obj if-non-nil) - (oref obj if-mode) - (oref obj if-not-mode) - (oref obj if-derived) - (oref obj if-not-derived) - t))) - -(defun transient--inapt-suffix-p (obj) - (let ((transient--shadowed-buffer (current-buffer)) - (transient--pending-suffix obj)) - (transient--do-suffix-p - (oref obj inapt-if) - (oref obj inapt-if-not) - (oref obj inapt-if-nil) - (oref obj inapt-if-non-nil) - (oref obj inapt-if-mode) - (oref obj inapt-if-not-mode) - (oref obj inapt-if-derived) - (oref obj inapt-if-not-derived) - nil))) - -(defun transient--do-suffix-p - (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived - default) - (cond - (if (funcall if)) - (if-not (not (funcall if-not))) - (if-non-nil (symbol-value if-non-nil)) - (if-nil (not (symbol-value if-nil))) - (if-mode (if (atom if-mode) - (eq major-mode if-mode) - (memq major-mode if-mode))) - (if-not-mode (not (if (atom if-not-mode) - (eq major-mode if-not-mode) - (memq major-mode if-not-mode)))) - (if-derived (if (or (atom if-derived) - (>= emacs-major-version 30)) - (derived-mode-p if-derived) - (apply #'derived-mode-p if-derived))) - (if-not-derived (not (if (or (atom if-not-derived) - (>= emacs-major-version 30)) - (derived-mode-p if-not-derived) - (apply #'derived-mode-p if-not-derived)))) - (default))) - -(defun transient--suffix-predicate (spec) - (let ((plist (nth 2 spec))) - (seq-some (lambda (prop) - (and-let* ((pred (plist-get plist prop))) - (list prop pred))) - '( :if :if-not - :if-nil :if-non-nil - :if-mode :if-not-mode - :if-derived :if-not-derived - :inapt-if :inapt-if-not - :inapt-if-nil :inapt-if-non-nil - :inapt-if-mode :inapt-if-not-mode - :inapt-if-derived :inapt-if-not-derived)))) - -;;; Flow-Control - -(defun transient--setup-transient () - (transient--debug 'setup-transient) - (transient--push-keymap 'transient--transient-map) - (transient--push-keymap 'transient--redisplay-map) - (add-hook 'pre-command-hook #'transient--pre-command) - (add-hook 'post-command-hook #'transient--post-command) - (advice-add 'recursive-edit :around #'transient--recursive-edit) - (when transient--exitp - ;; This prefix command was invoked as the suffix of another. - ;; Prevent `transient--post-command' from removing the hooks - ;; that we just added. - (setq transient--exitp 'replace))) - -(defun transient--refresh-transient () - (transient--debug 'refresh-transient) - (transient--pop-keymap 'transient--predicate-map) - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (transient--init-transient) - (transient--push-keymap 'transient--transient-map) - (transient--push-keymap 'transient--redisplay-map) - (transient--redisplay)) - -(defun transient--pre-command () - (transient--debug 'pre-command) - (transient--with-emergency-exit :pre-command - ;; The use of `overriding-terminal-local-map' does not prevent the - ;; lookup of command remappings in the overridden maps, which can - ;; lead to a suffix being remapped to a non-suffix. We have to undo - ;; the remapping in that case. However, remapping a non-suffix to - ;; another should remain possible. - (when (and (transient--get-pre-command this-original-command 'suffix) - (not (transient--get-pre-command this-command 'suffix))) - (setq this-command this-original-command)) - (cond - ((memq this-command '(transient-update transient-quit-seq)) - (transient--pop-keymap 'transient--redisplay-map)) - ((and transient--helpp - (not (memq this-command '(transient-quit-one - transient-quit-all)))) - (cond - ((transient-help) - (transient--do-suspend) - (setq this-command 'transient-suspend) - (transient--pre-exit)) - ((not (transient--edebug-command-p)) - (setq this-command 'transient-undefined)))) - ((and transient--editp - (transient-suffix-object) - (not (memq this-command '(transient-quit-one - transient-quit-all - transient-help)))) - (setq this-command 'transient-set-level) - (transient--wrap-command)) - (t - (setq transient--exitp nil) - (let ((exitp (eq (transient--call-pre-command) transient--exit))) - (transient--wrap-command) - (when exitp - (transient--pre-exit))))))) - -(defun transient--pre-exit () - (transient--debug 'pre-exit) - (transient--delete-window) - (transient--timer-cancel) - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (unless transient--showp - (let ((message-log-max nil)) - (message ""))) - (setq transient--transient-map nil) - (setq transient--predicate-map nil) - (setq transient--redisplay-map nil) - (setq transient--redisplay-key nil) - (setq transient--helpp nil) - (setq transient--editp nil) - (setq transient--prefix nil) - (setq transient--layout nil) - (setq transient--suffixes nil) - (setq transient--original-window nil) - (setq transient--original-buffer nil) - (setq transient--window nil)) - -(defun transient--delete-window () - (when (window-live-p transient--window) - (let ((win transient--window) - (remain-in-minibuffer-window - (and (minibuffer-selected-window) - (selected-window)))) - (cond - ((eq (car (window-parameter win 'quit-restore)) 'other) - ;; Window used to display another buffer. - (set-window-parameter win 'no-other-window - (window-parameter win 'prev--no-other-window)) - (set-window-parameter win 'prev--no-other-window nil)) - ((with-demoted-errors "Error while exiting transient: %S" - (delete-window win)))) - (when (buffer-live-p transient--buffer) - (kill-buffer transient--buffer)) - (setq transient--buffer nil) - (when remain-in-minibuffer-window - (select-window remain-in-minibuffer-window))))) - -(defun transient--export () - (setq transient-current-prefix transient--prefix) - (setq transient-current-command (oref transient--prefix command)) - (setq transient-current-suffixes transient--suffixes) - (transient--history-push transient--prefix)) - -(defun transient--suspend-override (&optional nohide) - (transient--debug 'suspend-override) - (transient--timer-cancel) - (cond ((and (not nohide) transient-hide-during-minibuffer-read) - (transient--delete-window)) - ((and transient--prefix transient--redisplay-key) - (setq transient--redisplay-key nil) - (when transient--showp - (if-let ((win (minibuffer-selected-window))) - (with-selected-window win - (transient--show)) - (transient--show))))) - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (remove-hook 'pre-command-hook #'transient--pre-command) - (remove-hook 'post-command-hook #'transient--post-command)) - -(defun transient--resume-override (&optional _ignore) - (transient--debug 'resume-override) - (when (and transient--showp transient-hide-during-minibuffer-read) - (transient--show)) - (transient--push-keymap 'transient--transient-map) - (transient--push-keymap 'transient--redisplay-map) - (add-hook 'pre-command-hook #'transient--pre-command) - (add-hook 'post-command-hook #'transient--post-command)) - -(defun transient--recursive-edit (fn) - (transient--debug 'recursive-edit) - (if (not transient--prefix) - (funcall fn) - (transient--suspend-override (bound-and-true-p edebug-active)) - (funcall fn) ; Already unwind protected. - (cond ((memq this-command '(top-level abort-recursive-edit)) - (setq transient--exitp t) - (transient--post-exit this-command) - (transient--delete-window)) - (transient--prefix - (transient--resume-override))))) - -(defmacro transient--with-suspended-override (&rest body) - (let ((depth (make-symbol "depth")) - (setup (make-symbol "setup")) - (exit (make-symbol "exit"))) - `(if (and transient--transient-map - (memq transient--transient-map - overriding-terminal-local-map)) - (let ((,depth (1+ (minibuffer-depth))) ,setup ,exit) - (setq ,setup - (lambda () "@transient--with-suspended-override" - (transient--debug 'minibuffer-setup) - (remove-hook 'minibuffer-setup-hook ,setup) - (transient--suspend-override))) - (setq ,exit - (lambda () "@transient--with-suspended-override" - (transient--debug 'minibuffer-exit) - (when (= (minibuffer-depth) ,depth) - (transient--resume-override)))) - (unwind-protect - (progn - (add-hook 'minibuffer-setup-hook ,setup) - (add-hook 'minibuffer-exit-hook ,exit) - ,@body) - (remove-hook 'minibuffer-setup-hook ,setup) - (remove-hook 'minibuffer-exit-hook ,exit))) - ,@body))) - -(defun transient--wrap-command () - (static-if (>= emacs-major-version 30) - (letrec - ((prefix transient--prefix) - (suffix this-command) - (advice - (lambda (fn &rest args) - (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (let ((debugger #'transient--exit-and-debug)) - (advice-eval-interactive-spec spec)) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (unwind-protect - (let ((debugger #'transient--exit-and-debug)) - (apply fn args)) - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (when (symbolp this-command) - (advice-add suffix :around advice '((depth . -99)))) - (cl-assert - (>= emacs-major-version 30) nil - "Emacs was downgraded, making it necessary to recompile Transient")) - ;; (< emacs-major-version 30) - (let* ((prefix transient--prefix) - (suffix this-command) - (advice nil) - (advice-interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (let ((debugger #'transient--exit-and-debug)) - (advice-eval-interactive-spec spec)) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (advice-body - (lambda (fn &rest args) - (unwind-protect - (let ((debugger #'transient--exit-and-debug)) - (apply fn args)) - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (setq advice `(lambda (fn &rest args) - (interactive ,advice-interactive) - (apply ',advice-body fn args))) - (when (symbolp this-command) - (advice-add suffix :around advice '((depth . -99))))))) - -(defun transient--premature-post-command () - (and (equal (this-command-keys-vector) []) - (= (minibuffer-depth) - (1+ transient--minibuffer-depth)) - (progn - (transient--debug 'premature-post-command) - (transient--suspend-override) - (oset (or transient--prefix transient-current-prefix) - unwind-suffix - (if transient--exitp - #'transient--post-exit - #'transient--resume-override)) - t))) - -(defun transient--post-command () - (unless (transient--premature-post-command) - (transient--debug 'post-command) - (transient--with-emergency-exit :post-command - (cond (transient--exitp (transient--post-exit)) - ;; If `this-command' is the current transient prefix, then we - ;; have already taken care of updating the transient buffer... - ((and (eq this-command (oref transient--prefix command)) - ;; ... but if `prefix-arg' is non-nil, then the values - ;; of `this-command' and `real-this-command' are untrue - ;; because `prefix-command-preserve-state' changes them. - ;; We cannot use `current-prefix-arg' because it is set - ;; too late (in `command-execute'), and if it were set - ;; earlier, then we likely still would not be able to - ;; rely on it, and `prefix-command-preserve-state-hook' - ;; would have to be used to record that a universal - ;; argument is in effect. - (not prefix-arg))) - (transient--refreshp - (transient--env-apply #'transient--refresh-transient)) - ((let ((old transient--redisplay-map) - (new (transient--make-redisplay-map))) - (unless (equal old new) - (transient--pop-keymap 'transient--redisplay-map) - (setq transient--redisplay-map new) - (transient--push-keymap 'transient--redisplay-map)) - (transient--env-apply #'transient--redisplay))))) - (setq transient-current-prefix nil) - (setq transient-current-command nil) - (setq transient-current-suffixes nil))) - -(defun transient--post-exit (&optional command) - (transient--debug 'post-exit) - (unless (and (eq transient--exitp 'replace) - (or transient--prefix - ;; The current command could act as a prefix, - ;; but decided not to call `transient-setup', - ;; or it is prevented from doing so because it - ;; uses the minibuffer and the user aborted - ;; that. - (prog1 nil - (if (let ((obj (transient-suffix-object command))) - (and (slot-boundp obj 'transient) - (oref obj transient))) - ;; This sub-prefix is a transient suffix; - ;; go back to outer prefix, by calling - ;; `transient--stack-pop' further down. - (setq transient--exitp nil) - (transient--stack-zap))))) - (remove-hook 'pre-command-hook #'transient--pre-command) - (remove-hook 'post-command-hook #'transient--post-command) - (advice-remove 'recursive-edit #'transient--recursive-edit)) - (let ((resume (and transient--stack - (not (memq transient--exitp '(replace suspend)))))) - (unless (or resume (eq transient--exitp 'replace)) - (setq transient--showp nil)) - (setq transient--exitp nil) - (setq transient--helpp nil) - (setq transient--editp nil) - (setq transient--all-levels-p nil) - (setq transient--minibuffer-depth 0) - (run-hooks 'transient-exit-hook) - (when command - (setq transient-current-prefix nil) - (setq transient-current-command nil) - (setq transient-current-suffixes nil)) - (when resume - (transient--stack-pop)))) - -(defun transient--stack-push () - (transient--debug 'stack-push) - (push (list (oref transient--prefix command) - transient--layout - transient--editp - :transient-suffix (oref transient--prefix transient-suffix) - :scope (oref transient--prefix scope)) - transient--stack)) - -(defun transient--stack-pop () - (transient--debug 'stack-pop) - (and transient--stack - (prog1 t (apply #'transient-setup (pop transient--stack))))) - -(defun transient--stack-zap () - (transient--debug 'stack-zap) - (setq transient--stack nil)) - -(defun transient--redisplay () - (if (or (eq transient-show-popup t) - transient--showp) - (unless - (or (memq this-command transient--scroll-commands) - (and (or (memq this-command '(mouse-drag-region - mouse-set-region)) - (equal (key-description (this-command-keys-vector)) - "<mouse-movement>")) - (and (eq (current-buffer) transient--buffer)))) - (transient--show)) - (when (and (numberp transient-show-popup) - (not (zerop transient-show-popup)) - (not transient--timer)) - (transient--timer-start)) - (transient--show-brief))) - -(defun transient--timer-start () - (setq transient--timer - (run-at-time (abs transient-show-popup) nil - (lambda () - (transient--timer-cancel) - (transient--show) - (let ((message-log-max nil)) - (message "")))))) - -(defun transient--timer-cancel () - (when transient--timer - (cancel-timer transient--timer) - (setq transient--timer nil))) - -(defun transient--debug (arg &rest args) - (when transient--debug - (let ((inhibit-message (not (eq transient--debug 'message)))) - (if (symbolp arg) - (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" - arg - (cond ((and (symbolp this-command) this-command)) - ((fboundp 'help-fns-function-name) - (help-fns-function-name this-command)) - ((byte-code-function-p this-command) - "#[...]") - (this-command)) - (key-description (this-command-keys-vector)) - transient--exitp - (cond ((keywordp (car args)) - (format ", from: %s" - (substring (symbol-name (car args)) 1))) - ((stringp (car args)) - (concat ", " (apply #'format args))) - ((functionp (car args)) - (concat ", " (apply (car args) (cdr args)))) - (""))) - (apply #'message arg args))))) - -(defun transient--emergency-exit (&optional id) - "Exit the current transient command after an error occurred. -When no transient is active (i.e., when `transient--prefix' is -nil) then do nothing. Optional ID is a keyword identifying the -exit." - (transient--debug 'emergency-exit id) - (when transient--prefix - (setq transient--stack nil) - (setq transient--exitp t) - (transient--pre-exit) - (transient--post-exit this-command))) - -;;; Pre-Commands - -(defun transient--call-pre-command () - (if-let ((fn (transient--get-pre-command this-command))) - (let ((action (funcall fn))) - (when (eq action transient--exit) - (setq transient--exitp (or transient--exitp t))) - action) - (if (let ((keys (this-command-keys-vector))) - (eq (aref keys (1- (length keys))) ?\C-g)) - (setq this-command 'transient-noop) - (unless (transient--edebug-command-p) - (setq this-command 'transient-undefined))) - transient--stay)) - -(defun transient--get-pre-command (&optional cmd enforce-type) - (or (and (not (eq enforce-type 'non-suffix)) - (symbolp cmd) - (lookup-key transient--predicate-map (vector cmd))) - (and (not (eq enforce-type 'suffix)) - (transient--resolve-pre-command - (oref transient--prefix transient-non-suffix) - t)))) - -(defun transient--resolve-pre-command (pre &optional resolve-boolean) - (cond ((booleanp pre) - (if resolve-boolean - (if pre #'transient--do-stay #'transient--do-warn) - pre)) - ((string-match-p "--do-" (symbol-name pre)) pre) - ((let ((sym (intern (format "transient--do-%s" pre)))) - (if (functionp sym) sym pre))))) - -(defun transient--do-stay () - "Call the command without exporting variables and stay transient." - transient--stay) - -(defun transient--do-noop () - "Call `transient-noop' and stay transient." - (setq this-command 'transient-noop) - transient--stay) - -(defun transient--do-warn () - "Call `transient-undefined' and stay transient." - (setq this-command 'transient-undefined) - transient--stay) - -(defun transient--do-warn-inapt () - "Call `transient-inapt' and stay transient." - (setq this-command 'transient-inapt) - transient--stay) - -(defun transient--do-call () - "Call the command after exporting variables and stay transient." - (transient--export) - transient--stay) - -(defun transient--do-return () - "Call the command after exporting variables and return to parent prefix. -If there is no parent prefix, then behave like `transient--do-exit'." - (if (not transient--stack) - (transient--do-exit) - (transient--export) - transient--exit)) - -(defun transient--do-exit () - "Call the command after exporting variables and exit the transient." - (transient--export) - (transient--stack-zap) - transient--exit) - -(defun transient--do-leave () - "Call the command without exporting variables and exit the transient." - (transient--stack-zap) - transient--exit) - -(defun transient--do-push-button () - "Call the command represented by the activated button. -Use that command's pre-command to determine transient behavior." - (if (and (mouse-event-p last-command-event) - (not (eq (posn-window (event-start last-command-event)) - transient--window))) - transient--stay - (setq this-command - (with-selected-window transient--window - (get-text-property (if (mouse-event-p last-command-event) - (posn-point (event-start last-command-event)) - (point)) - 'command))) - (transient--call-pre-command))) - -(defun transient--do-recurse () - "Call the transient prefix command, preparing for return to active transient. -If there is no parent prefix, then just call the command." - (transient--do-stack)) - -(defun transient--setup-recursion (prefix-obj) - (when transient--stack - (let ((command (oref prefix-obj command))) - (when-let ((suffix-obj (transient-suffix-object command))) - (when (memq (if (slot-boundp suffix-obj 'transient) - (oref suffix-obj transient) - (oref transient-current-prefix transient-suffix)) - (list t #'transient--do-recurse)) - (oset prefix-obj transient-suffix t)))))) - -(defun transient--do-stack () - "Call the transient prefix command, stacking the active transient. -Push the active transient to the transient stack." - (transient--export) - (transient--stack-push) - (setq transient--exitp 'replace) - transient--exit) - -(defun transient--do-replace () - "Call the transient prefix command, replacing the active transient. -Do not push the active transient to the transient stack." - (transient--export) - (setq transient--exitp 'replace) - transient--exit) - -(defun transient--do-suspend () - "Suspend the active transient, saving the transient stack." - (transient--stack-push) - (setq transient--exitp 'suspend) - transient--exit) - -(defun transient--do-quit-one () - "If active, quit help or edit mode, else exit the active transient." - (cond (transient--helpp - (setq transient--helpp nil) - transient--stay) - (transient--editp - (setq transient--editp nil) - (transient-setup) - transient--stay) - (prefix-arg - transient--stay) - (transient--exit))) - -(defun transient--do-quit-all () - "Exit all transients without saving the transient stack." - (transient--stack-zap) - transient--exit) - -(defun transient--do-move () - "Call the command if `transient-enable-popup-navigation' is non-nil. -In that case behave like `transient--do-stay', otherwise similar -to `transient--do-warn'." - (unless transient-enable-popup-navigation - (setq this-command 'transient-inhibit-move)) - transient--stay) - -(defun transient--do-minus () - "Call `negative-argument' or pivot to `transient-update'. -If `negative-argument' is invoked using \"-\" then preserve the -prefix argument and pivot to `transient-update'." - (when (equal (this-command-keys) "-") - (setq this-command 'transient-update)) - transient--stay) - -(put 'transient--do-stay 'transient-face 'transient-key-stay) -(put 'transient--do-noop 'transient-face 'transient-key-noop) -(put 'transient--do-warn 'transient-face 'transient-key-noop) -(put 'transient--do-warn-inapt 'transient-face 'transient-key-noop) -(put 'transient--do-call 'transient-face 'transient-key-stay) -(put 'transient--do-return 'transient-face 'transient-key-return) -(put 'transient--do-exit 'transient-face 'transient-key-exit) -(put 'transient--do-leave 'transient-face 'transient-key-exit) - -(put 'transient--do-recurse 'transient-face 'transient-key-stay) -(put 'transient--do-stack 'transient-face 'transient-key-stay) -(put 'transient--do-replace 'transient-face 'transient-key-exit) -(put 'transient--do-suspend 'transient-face 'transient-key-exit) - -(put 'transient--do-quit-one 'transient-face 'transient-key-return) -(put 'transient--do-quit-all 'transient-face 'transient-key-exit) -(put 'transient--do-move 'transient-face 'transient-key-stay) -(put 'transient--do-minus 'transient-face 'transient-key-stay) - -;;; Commands -;;;; Noop - -(defun transient-noop () - "Do nothing at all." - (interactive)) - -(defun transient-undefined () - "Warn the user that the pressed key is not bound to any suffix." - (interactive) - (transient--invalid "Unbound suffix")) - -(defun transient-inapt () - "Warn the user that the invoked command is inapt." - (interactive) - (transient--invalid "Inapt command")) - -(defun transient--invalid (msg) - (ding) - (message "%s: `%s' (Use `%s' to abort, `%s' for help)%s" - msg - (propertize (key-description (this-single-command-keys)) - 'face 'font-lock-warning-face) - (propertize "C-g" 'face 'transient-key) - (propertize "?" 'face 'transient-key) - ;; `this-command' is `transient-undefined' or `transient-inapt'. - ;; Show the command (`this-original-command') the user actually - ;; tried to invoke. - (if-let ((cmd (or (ignore-errors (symbol-name this-original-command)) - (ignore-errors (symbol-name this-command))))) - (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) - "")) - (unless (and transient--transient-map - (memq transient--transient-map overriding-terminal-local-map)) - (let ((transient--prefix (or transient--prefix 'sic))) - (transient--emergency-exit)) - (view-lossage) - (other-window 1) - (display-warning 'transient "Inconsistent transient state detected. -This should never happen. -Please open an issue and post the shown command log." :error))) - -(defun transient-inhibit-move () - "Warn the user that popup navigation is disabled." - (interactive) - (message "To enable use of `%s', please customize `%s'" - this-original-command - 'transient-enable-popup-navigation)) - -;;;; Core - -(defun transient-quit-all () - "Exit all transients without saving the transient stack." - (interactive)) - -(defun transient-quit-one () - "Exit the current transients, returning to outer transient, if any." - (interactive)) - -(defun transient-quit-seq () - "Abort the current incomplete key sequence." - (interactive)) - -(defun transient-update () - "Redraw the transient's state in the popup buffer." - (interactive) - (setq prefix-arg current-prefix-arg)) - -(defun transient-show () - "Show the transient's state in the popup buffer." - (interactive) - (setq transient--showp t)) - -(defun transient-push-button () - "Invoke the suffix command represented by this button." - (interactive)) - -;;;; Suspend - -(defun transient-suspend () - "Suspend the current transient. -It can later be resumed using `transient-resume', while no other -transient is active." - (interactive)) - -(define-minor-mode transient-resume-mode - "Auxiliary minor-mode used to resume a transient after viewing help.") - -(defun transient-resume () - "Resume a previously suspended stack of transients." - (interactive) - (cond (transient--stack - (let ((winconf transient--restore-winconf)) - (kill-local-variable 'transient--restore-winconf) - (when transient-resume-mode - (transient-resume-mode -1) - (quit-window)) - (when winconf - (set-window-configuration winconf))) - (transient--stack-pop)) - (transient-resume-mode - (kill-local-variable 'transient--restore-winconf) - (transient-resume-mode -1) - (quit-window)) - (t - (message "No suspended transient command")))) - -;;;; Help - -(defun transient-help (&optional interactive) - "Show help for the active transient or one of its suffixes.\n\n(fn)" - (interactive (list t)) - (if interactive - (setq transient--helpp t) - (with-demoted-errors "transient-help: %S" - (when (lookup-key transient--transient-map - (this-single-command-raw-keys)) - (setq transient--helpp nil) - (let ((winconf (current-window-configuration))) - (transient-show-help - (if (eq this-original-command 'transient-help) - transient--prefix - (or (transient-suffix-object) - this-original-command))) - (setq-local transient--restore-winconf winconf)) - (fit-window-to-buffer nil (frame-height) (window-height)) - (transient-resume-mode) - (message (substitute-command-keys - "Type \\`q' to resume transient command.")) - t)))) - -;;;; Level - -(defun transient-set-level (&optional command level) - "Set the level of the transient or one of its suffix commands." - (interactive - (let ((command this-original-command) - (prefix (oref transient--prefix command))) - (and (or (not (eq command 'transient-set-level)) - (and transient--editp - (setq command prefix))) - (list command - (let ((keys (this-single-command-raw-keys))) - (and (lookup-key transient--transient-map keys) - (progn - (transient--show) - (string-to-number - (transient--read-number-N - (format "Set level for `%s': " command) - nil nil (not (eq command prefix))))))))))) - (cond - ((not command) - (setq transient--editp t) - (transient-setup)) - (level - (let* ((prefix (oref transient--prefix command)) - (alist (alist-get prefix transient-levels)) - (akey command)) - (cond ((eq command prefix) - (oset transient--prefix level level) - (setq akey t)) - (t - (oset (transient-suffix-object command) level level) - (when (cdr (cl-remove-if-not (lambda (obj) - (eq (oref obj command) command)) - transient--suffixes)) - (setq akey (cons command (this-command-keys)))))) - (setf (alist-get akey alist) level) - (setf (alist-get prefix transient-levels) alist)) - (transient-save-levels) - (transient--show)) - (t - (transient-undefined)))) - -(transient-define-suffix transient-toggle-level-limit () - "Toggle whether to temporarily displayed suffixes on all levels." - :description - (lambda () - (cond - ((= transient-default-level transient--max-level) - "Always displaying all levels") - (transient--all-levels-p - (format "Hide suffix %s" - (propertize - (format "levels > %s" (oref (transient-prefix-object) level)) - 'face 'transient-higher-level))) - ("Show all suffix levels"))) - :inapt-if (lambda () (= transient-default-level transient--max-level)) - :transient t - (interactive) - (setq transient--all-levels-p (not transient--all-levels-p)) - (setq transient--refreshp t)) - -;;;; Value - -(defun transient-set () - "Set active transient's value for this Emacs session." - (interactive) - (transient-set-value (transient-prefix-object))) - -(defalias 'transient-set-and-exit #'transient-set - "Set active transient's value for this Emacs session and exit.") - -(defun transient-save () - "Save active transient's value for this and future Emacs sessions." - (interactive) - (transient-save-value (transient-prefix-object))) - -(defalias 'transient-save-and-exit #'transient-save - "Save active transient's value for this and future Emacs sessions and exit.") - -(defun transient-reset () - "Clear the set and saved values of the active transient." - (interactive) - (transient-reset-value (transient-prefix-object))) - -(defun transient-history-next () - "Switch to the next value used for the active transient." - (interactive) - (let* ((obj transient--prefix) - (pos (1- (oref obj history-pos))) - (hst (oref obj history))) - (if (< pos 0) - (user-error "End of history") - (oset obj history-pos pos) - (oset obj value (nth pos hst)) - (mapc #'transient-init-value transient--suffixes)))) - -(defun transient-history-prev () - "Switch to the previous value used for the active transient." - (interactive) - (let* ((obj transient--prefix) - (pos (1+ (oref obj history-pos))) - (hst (oref obj history)) - (len (length hst))) - (if (> pos (1- len)) - (user-error "End of history") - (oset obj history-pos pos) - (oset obj value (nth pos hst)) - (mapc #'transient-init-value transient--suffixes)))) - -(transient-define-suffix transient-preset () - "Put this preset into action." - :class transient-value-preset - (interactive) - (transient-prefix-set (oref (transient-suffix-object) set))) - -;;;; Auxiliary - -(defun transient-toggle-common () - "Toggle whether common commands are permanently shown." - (interactive) - (setq transient-show-common-commands (not transient-show-common-commands))) - -(defun transient-toggle-debug () - "Toggle debugging statements for transient commands." - (interactive) - (setq transient--debug (not transient--debug)) - (message "Debugging transient %s" - (if transient--debug "enabled" "disabled"))) - -(transient-define-suffix transient-echo-arguments (arguments) - "Show the transient's active ARGUMENTS in the echo area. -Intended for use in prefixes used for demonstration purposes, -such as when suggesting a new feature or reporting an issue." - :transient t - :description "Echo arguments" - :key "x" - (interactive (list (transient-args transient-current-command))) - (message "%s: %s" - (key-description (this-command-keys)) - (mapconcat (lambda (arg) - (propertize (if (string-match-p " " arg) - (format "%S" arg) - arg) - 'face 'transient-argument)) - arguments " "))) - -;;; Value -;;;; Init - -(cl-defgeneric transient-init-scope (obj) - "Set the scope of the suffix object OBJ. - -The scope is actually a property of the transient prefix, not of -individual suffixes. However it is possible to invoke a suffix -command directly instead of from a transient. In that case, if -the suffix expects a scope, then it has to determine that itself -and store it in its `scope' slot. - -This function is called for all suffix commands, but unless a -concrete method is implemented this falls through to the default -implementation, which is a noop.") - -(cl-defmethod transient-init-scope ((_ transient-suffix)) - "Noop." nil) - -(cl-defgeneric transient-init-value (_) - "Set the initial value of the object OBJ. - -This function is called for all prefix and suffix commands. - -For suffix commands (including infix argument commands) the -default implementation is a noop. Classes derived from the -abstract `transient-infix' class must implement this function. -Non-infix suffix commands usually don't have a value." - nil) - -(cl-defmethod transient-init-value :around ((obj transient-prefix)) - "If bound, then call OBJ's `init-value' function. -Otherwise call the primary method according to object's class." - (if (slot-boundp obj 'init-value) - (funcall (oref obj init-value) obj) - (cl-call-next-method obj))) - -(cl-defmethod transient-init-value :around ((obj transient-infix)) - "If bound, then call OBJ's `init-value' function. -Otherwise call the primary method according to object's class." - (if (slot-boundp obj 'init-value) - (funcall (oref obj init-value) obj) - (cl-call-next-method obj))) - -(cl-defmethod transient-init-value ((obj transient-prefix)) - (if (slot-boundp obj 'value) - (oref obj value) - (oset obj value - (if-let ((saved (assq (oref obj command) transient-values))) - (cdr saved) - (transient-default-value obj))))) - -(cl-defmethod transient-init-value ((obj transient-argument)) - (oset obj value - (let ((value (oref transient--prefix value)) - (argument (and (slot-boundp obj 'argument) - (oref obj argument))) - (multi-value (oref obj multi-value)) - (case-fold-search nil) - (regexp (if (slot-exists-p obj 'argument-regexp) - (oref obj argument-regexp) - (format "\\`%s\\(.*\\)" (oref obj argument))))) - (if (memq multi-value '(t rest)) - (cdr (assoc argument value)) - (let ((match (lambda (v) - (and (stringp v) - (string-match regexp v) - (match-string 1 v))))) - (if multi-value - (delq nil (mapcar match value)) - (cl-some match value))))))) - -(cl-defmethod transient-init-value ((obj transient-switch)) - (oset obj value - (car (member (oref obj argument) - (oref transient--prefix value))))) - -;;;; Default - -(cl-defgeneric transient-default-value (_) - "Return the default value." - nil) - -(cl-defmethod transient-default-value ((obj transient-prefix)) - (if-let ((default (and (slot-boundp obj 'default-value) - (oref obj default-value)))) - (if (functionp default) - (funcall default) - default) - nil)) - -;;;; Read - -(cl-defgeneric transient-infix-read (obj) - "Determine the new value of the infix object OBJ. - -This function merely determines the value; `transient-infix-set' -is used to actually store the new value in the object. - -For most infix classes this is done by reading a value from the -user using the reader specified by the `reader' slot (using the -`transient-infix' method described below). - -For some infix classes the value is changed without reading -anything in the minibuffer, i.e., the mere act of invoking the -infix command determines what the new value should be, based -on the previous value.") - -(cl-defmethod transient-infix-read :around ((obj transient-infix)) - "Refresh the transient buffer and call the next method. - -Also wrap `cl-call-next-method' with two macros: -- `transient--with-suspended-override' allows use of minibuffer. -- `transient--with-emergency-exit' arranges for the transient to - be exited in case of an error." - (transient--show) - (transient--with-emergency-exit :infix-read - (transient--with-suspended-override - (cl-call-next-method obj)))) - -(cl-defmethod transient-infix-read ((obj transient-infix)) - "Read a value while taking care of history. - -This method is suitable for a wide variety of infix commands, -including but not limited to inline arguments and variables. - -If you do not use this method for your own infix class, then -you should likely replicate a lot of the behavior of this -method. If you fail to do so, then users might not appreciate -the lack of history, for example. - -Only for very simple classes that toggle or cycle through a very -limited number of possible values should you replace this with a -simple method that does not handle history. (E.g., for a command -line switch the only possible values are \"use it\" and \"don't use -it\", in which case it is pointless to preserve history.)" - (with-slots (value multi-value always-read allow-empty choices) obj - (if (and value - (not multi-value) - (not always-read) - transient--prefix) - (oset obj value nil) - (let* ((enable-recursive-minibuffers t) - (reader (oref obj reader)) - (choices (if (functionp choices) (funcall choices) choices)) - (prompt (transient-prompt obj)) - (value (if multi-value (string-join value ",") value)) - (history-key (or (oref obj history-key) - (oref obj command))) - (transient--history (alist-get history-key transient-history)) - (transient--history (if (or (null value) - (eq value (car transient--history))) - transient--history - (cons value transient--history))) - (initial-input (and transient-read-with-initial-input - (car transient--history))) - (history (if initial-input - (cons 'transient--history 1) - 'transient--history)) - (value - (cond - (reader (funcall reader prompt initial-input history)) - (multi-value - (completing-read-multiple prompt choices nil nil - initial-input history)) - (choices - (completing-read prompt choices nil t initial-input history)) - ((read-string prompt initial-input history))))) - (cond ((and (equal value "") (not allow-empty)) - (setq value nil)) - ((and (equal value "\"\"") allow-empty) - (setq value ""))) - (when value - (when (and (bound-and-true-p ivy-mode) - (stringp (car transient--history))) - (set-text-properties 0 (length (car transient--history)) nil - (car transient--history))) - (setf (alist-get history-key transient-history) - (delete-dups transient--history))) - value)))) - -(cl-defmethod transient-infix-read ((obj transient-switch)) - "Toggle the switch on or off." - (if (oref obj value) nil (oref obj argument))) - -(cl-defmethod transient-infix-read ((obj transient-switches)) - "Cycle through the mutually exclusive switches. -The last value is \"don't use any of these switches\"." - (let ((choices (mapcar (apply-partially #'format (oref obj argument-format)) - (oref obj choices)))) - (if-let ((value (oref obj value))) - (cadr (member value choices)) - (car choices)))) - -(cl-defmethod transient-infix-read ((command symbol)) - "Elsewhere use the reader of the infix command COMMAND. -Use this if you want to share an infix's history with a regular -stand-alone command." - (if-let ((obj (transient--suffix-prototype command))) - (cl-letf (((symbol-function #'transient--show) #'ignore)) - (transient-infix-read obj)) - (error "Not a suffix command: `%s'" command))) - -;;;; Readers - -(defun transient-read-file (prompt _initial-input _history) - "Read a file." - (file-local-name (expand-file-name (read-file-name prompt)))) - -(defun transient-read-existing-file (prompt _initial-input _history) - "Read an existing file." - (file-local-name (expand-file-name (read-file-name prompt nil nil t)))) - -(defun transient-read-directory (prompt _initial-input _history) - "Read a directory." - (file-local-name (expand-file-name (read-directory-name prompt)))) - -(defun transient-read-existing-directory (prompt _initial-input _history) - "Read an existing directory." - (file-local-name (expand-file-name (read-directory-name prompt nil nil t)))) - -(defun transient-read-number-N0 (prompt initial-input history) - "Read a natural number (including zero) and return it as a string." - (transient--read-number-N prompt initial-input history t)) - -(defun transient-read-number-N+ (prompt initial-input history) - "Read a natural number (excluding zero) and return it as a string." - (transient--read-number-N prompt initial-input history nil)) - -(defun transient--read-number-N (prompt initial-input history include-zero) - (save-match-data - (cl-block nil - (while t - (let ((str (read-from-minibuffer prompt initial-input nil nil history))) - (when (or (string-equal str "") - (string-match-p (if include-zero - "\\`\\(0\\|[1-9][0-9]*\\)\\'" - "\\`[1-9][0-9]*\\'") - str)) - (cl-return str))) - (message "Please enter a natural number (%s zero)." - (if include-zero "including" "excluding")) - (sit-for 1))))) - -(defun transient-read-date (prompt default-time _history) - "Read a date using `org-read-date' (which see)." - (require 'org) - (when (fboundp 'org-read-date) - (org-read-date 'with-time nil nil prompt default-time))) - -;;;; Prompt - -(cl-defgeneric transient-prompt (obj) - "Return the prompt to be used to read infix object OBJ's value.") - -(cl-defmethod transient-prompt ((obj transient-infix)) - "Return the prompt to be used to read infix object OBJ's value. - -This implementation should be suitable for almost all infix -commands. - -If the value of OBJ's `prompt' slot is non-nil, then it must be -a string or a function. If it is a string, then use that. If -it is a function, then call that with OBJ as the only argument. -That function must return a string, which is then used as the -prompt. - -Otherwise, if the value of either the `argument' or `variable' -slot of OBJ is a string, then base the prompt on that (preferring -the former), appending either \"=\" (if it appears to be a -command-line option) or \": \". - -Finally fall through to using \"(BUG: no prompt): \" as the -prompt." - (if-let ((prompt (oref obj prompt))) - (let ((prompt (if (functionp prompt) - (funcall prompt obj) - prompt))) - (if (stringp prompt) - prompt - "(BUG: no prompt): ")) - (or (and-let* ((arg (and (slot-boundp obj 'argument) (oref obj argument)))) - (if (and (stringp arg) (string-suffix-p "=" arg)) - arg - (concat arg ": "))) - (and-let* ((var (and (slot-boundp obj 'variable) (oref obj variable)))) - (and (stringp var) - (concat var ": "))) - "(BUG: no prompt): "))) - -;;;; Set - -(cl-defgeneric transient-infix-set (obj value) - "Set the value of infix object OBJ to VALUE.") - -(cl-defmethod transient-infix-set ((obj transient-infix) value) - "Set the value of infix object OBJ to VALUE." - (oset obj value value)) - -(cl-defmethod transient-infix-set :after ((obj transient-argument) value) - "Unset incompatible infix arguments." - (when-let* ((value) - (val (transient-infix-value obj)) - (arg (if (slot-boundp obj 'argument) - (oref obj argument) - (oref obj argument-format))) - (spec (oref transient--prefix incompatible)) - (filter (lambda (x rule) - (and (member x rule) - (remove x rule)))) - (incomp (nconc - (cl-mapcan (apply-partially filter arg) spec) - (and (not (equal val arg)) - (cl-mapcan (apply-partially filter val) spec))))) - (dolist (obj transient--suffixes) - (when-let* (((cl-typep obj 'transient-argument)) - (val (transient-infix-value obj)) - (arg (if (slot-boundp obj 'argument) - (oref obj argument) - (oref obj argument-format))) - ((if (equal val arg) - (member arg incomp) - (or (member val incomp) - (member arg incomp))))) - (transient-infix-set obj nil))))) - -(defun transient-prefix-set (value) - "Set the value of the active transient prefix to VALUE. -Intended for use by transient suffix commands." - (oset transient--prefix value value) - (setq transient--refreshp 'updated-value)) - -(cl-defgeneric transient-set-value (obj) - "Persist the value of the transient prefix OBJ. -Only intended for use by `transient-set'. -Also see `transient-prefix-set'.") - -(cl-defmethod transient-set-value ((obj transient-prefix)) - (oset (oref obj prototype) value (transient-get-value)) - (transient--history-push obj)) - -;;;; Save - -(cl-defgeneric transient-save-value (obj) - "Save the value of the transient prefix OBJ.") - -(cl-defmethod transient-save-value ((obj transient-prefix)) - (let ((value (transient-get-value))) - (oset (oref obj prototype) value value) - (setf (alist-get (oref obj command) transient-values) value) - (transient-save-values)) - (transient--history-push obj)) - -;;;; Reset - -(cl-defgeneric transient-reset-value (obj) - "Clear the set and saved values of the transient prefix OBJ.") - -(cl-defmethod transient-reset-value ((obj transient-prefix)) - (let ((value (transient-default-value obj))) - (oset obj value value) - (oset (oref obj prototype) value value) - (setf (alist-get (oref obj command) transient-values nil 'remove) nil) - (transient-save-values)) - (transient--history-push obj) - (mapc #'transient-init-value transient--suffixes)) - -;;;; Get - -(defun transient-args (prefix) - "Return the value of the transient prefix command PREFIX. -If the current command was invoked from the transient prefix -command PREFIX, then return the active infix arguments. If -the current command was not invoked from PREFIX, then return -the set, saved or default value for PREFIX." - (cl-mapcan #'transient--get-wrapped-value (transient-suffixes prefix))) - -(defun transient-suffixes (prefix) - "Return the suffix objects of the transient prefix command PREFIX." - (if (eq transient-current-command prefix) - transient-current-suffixes - (let ((transient--prefix (transient--init-prefix prefix))) - (transient--flatten-suffixes - (transient--init-suffixes prefix))))) - -(defun transient-get-value () - (transient--with-emergency-exit :get-value - (cl-mapcan (lambda (obj) - (and (or (not (slot-exists-p obj 'unsavable)) - (not (oref obj unsavable))) - (transient--get-wrapped-value obj))) - (or transient--suffixes transient-current-suffixes)))) - -(defun transient--get-wrapped-value (obj) - (and-let* ((value (transient-infix-value obj))) - (pcase-exhaustive (and (slot-exists-p obj 'multi-value) - (oref obj multi-value)) - ('nil (list value)) - ((or 't 'rest) (list value)) - ('repeat value)))) - -(cl-defgeneric transient-infix-value (obj) - "Return the value of the suffix object OBJ. - -This function is called by `transient-args' (which see), meaning -this function is how the value of a transient is determined so -that the invoked suffix command can use it. - -Currently most values are strings, but that is not set in stone. -Nil is not a value, it means \"no value\". - -Usually only infixes have a value, but see the method for -`transient-suffix'.") - -(cl-defmethod transient-infix-value ((_ transient-suffix)) - "Return nil, which means \"no value\". - -Infix arguments contribute the transient's value while suffix -commands consume it. This function is called for suffixes anyway -because a command that both contributes to the transient's value -and also consumes it is not completely unconceivable. - -If you define such a command, then you must define a derived -class and implement this function because this default method -does nothing." nil) - -(cl-defmethod transient-infix-value ((obj transient-infix)) - "Return the value of OBJ's `value' slot." - (oref obj value)) - -(cl-defmethod transient-infix-value ((obj transient-option)) - "Return ARGUMENT and VALUE as a unit or nil if the latter is nil." - (and-let* ((value (oref obj value))) - (let ((arg (oref obj argument))) - (pcase-exhaustive (oref obj multi-value) - ('nil (concat arg value)) - ((or 't 'rest) (cons arg value)) - ('repeat (mapcar (lambda (v) (concat arg v)) value)))))) - -(cl-defmethod transient-infix-value ((_ transient-variable)) - "Return nil, which means \"no value\". - -Setting the value of a variable is done by, well, setting the -value of the variable. I.e., this is a side-effect and does -not contribute to the value of the transient." - nil) - -;;;; Utilities - -(defun transient-arg-value (arg args) - "Return the value of ARG as it appears in ARGS. - -For a switch return a boolean. For an option return the value as -a string, using the empty string for the empty value, or nil if -the option does not appear in ARGS." - (if (string-suffix-p "=" arg) - (save-match-data - (and-let* ((match (let ((case-fold-search nil) - (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" - (substring arg 0 -1)))) - (cl-find-if (lambda (a) - (and (stringp a) - (string-match re a))) - args)))) - (or (match-string 1 match) ""))) - (and (member arg args) t))) - -(defun transient-scope () - "Return the value of the `scope' slot of the current prefix." - (oref (transient-prefix-object) scope)) - -;;; History - -(cl-defgeneric transient--history-key (obj) - "Return OBJ's history key. -If the value of the `history-key' slot is non-nil, then return -that. Otherwise return the value of the `command' slot." - (or (oref obj history-key) - (oref obj command))) - -(cl-defgeneric transient--history-push (obj) - "Push the current value of OBJ to its entry in `transient-history'." - (let ((key (transient--history-key obj))) - (setf (alist-get key transient-history) - (let ((args (transient-get-value))) - (cons args (delete args (alist-get key transient-history))))))) - -(cl-defgeneric transient--history-init (obj) - "Initialize OBJ's `history' slot. -This is the transient-wide history; many individual infixes also -have a history of their own.") - -(cl-defmethod transient--history-init ((obj transient-prefix)) - "Initialize OBJ's `history' slot from the variable `transient-history'." - (let ((val (oref obj value))) - (oset obj history - (cons val (delete val (alist-get (transient--history-key obj) - transient-history)))))) - -;;; Draw - -(defun transient--show-brief () - (let ((message-log-max nil)) - (if (and transient-show-popup (<= transient-show-popup 0)) - (message "%s-" (key-description (this-command-keys))) - (message - "%s- [%s] %s" - (key-description (this-command-keys)) - (oref transient--prefix command) - (mapconcat - #'identity - (sort - (cl-mapcan - (lambda (suffix) - (let ((key (kbd (oref suffix key)))) - ;; Don't list any common commands. - (and (not (memq (oref suffix command) - `(,(lookup-key transient-map key) - ,(lookup-key transient-sticky-map key) - ;; From transient-common-commands: - transient-set - transient-save - transient-history-prev - transient-history-next - transient-quit-one - transient-toggle-common - transient-set-level))) - (list (propertize (oref suffix key) 'face 'transient-key))))) - transient--suffixes) - #'string<) - (propertize "|" 'face 'transient-delimiter)))))) - -(defun transient--show () - (transient--timer-cancel) - (setq transient--showp t) - (let ((transient--shadowed-buffer (current-buffer)) - (focus nil)) - (setq transient--buffer (get-buffer-create transient--buffer-name)) - (with-current-buffer transient--buffer - (when transient-enable-popup-navigation - (setq focus (or (button-get (point) 'command) - (and (not (bobp)) - (button-get (1- (point)) 'command)) - (transient--heading-at-point)))) - (erase-buffer) - (run-hooks 'transient-setup-buffer-hook) - (when transient-force-fixed-pitch - (transient--force-fixed-pitch)) - (setq window-size-fixed (if (window-full-height-p) 'width t)) - (when (bound-and-true-p tab-line-format) - (setq tab-line-format nil)) - (setq header-line-format nil) - (setq mode-line-format - (if (or (natnump transient-mode-line-format) - (eq transient-mode-line-format 'line)) - nil - transient-mode-line-format)) - (setq mode-line-buffer-identification - (symbol-name (oref transient--prefix command))) - (if transient-enable-popup-navigation - (setq-local cursor-in-non-selected-windows 'box) - (setq cursor-type nil)) - (setq display-line-numbers nil) - (setq show-trailing-whitespace nil) - (transient--insert-groups) - (when (or transient--helpp transient--editp) - (transient--insert-help)) - (when-let ((line (transient--separator-line))) - (insert line))) - (unless (window-live-p transient--window) - (setq transient--window - (display-buffer transient--buffer - transient-display-buffer-action))) - (when (window-live-p transient--window) - (with-selected-window transient--window - (set-window-parameter nil 'prev--no-other-window - (window-parameter nil 'no-other-window)) - (set-window-parameter nil 'no-other-window t) - (goto-char (point-min)) - (when transient-enable-popup-navigation - (transient--goto-button focus)) - (transient--fit-window-to-buffer transient--window))))) - -(defun transient--fit-window-to-buffer (window) - (let ((window-resize-pixelwise t) - (window-size-fixed nil)) - (if (eq (car (window-parameter window 'quit-restore)) 'other) - ;; Grow but never shrink window that previously displayed - ;; another buffer and is going to display that again. - (fit-window-to-buffer window nil (window-height window)) - (fit-window-to-buffer window nil 1)))) - -(defun transient--separator-line () - (and-let* ((height (cond ((not window-system) nil) - ((natnump transient-mode-line-format) - transient-mode-line-format) - ((eq transient-mode-line-format 'line) 1))) - (face `(,@(and (>= emacs-major-version 27) '(:extend t)) - :background - ,(or (face-foreground (transient--key-face nil 'non-suffix) - nil t) - "#gray60")))) - (concat (propertize "__" 'face face 'display `(space :height (,height))) - (propertize "\n" 'face face 'line-height t)))) - -(defmacro transient-with-shadowed-buffer (&rest body) - "While in the transient buffer, temporarily make the shadowed buffer current." - (declare (indent 0) (debug t)) - `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) - ,@body)) - -(defun transient--insert-groups () - (let ((groups (cl-mapcan (lambda (group) - (let ((hide (oref group hide))) - (and (not (and (functionp hide) - (transient-with-shadowed-buffer - (funcall hide)))) - (list group)))) - transient--layout))) - (while-let ((group (pop groups))) - (transient--insert-group group) - (when groups - (insert ?\n))))) - -(defvar transient--max-group-level 1) - -(cl-defgeneric transient--insert-group (group) - "Format GROUP and its elements and insert the result.") - -(cl-defmethod transient--insert-group :around ((group transient-group)) - "Insert GROUP's description, if any." - (when-let ((desc (transient-with-shadowed-buffer - (transient-format-description group)))) - (insert desc ?\n)) - (let ((transient--max-group-level - (max (oref group level) transient--max-group-level)) - (transient--pending-group group)) - (cl-call-next-method group))) - -(cl-defmethod transient--insert-group ((group transient-row)) - (transient--maybe-pad-keys group) - (dolist (suffix (oref group suffixes)) - (insert (transient-with-shadowed-buffer (transient-format suffix))) - (insert " ")) - (insert ?\n)) - -(cl-defmethod transient--insert-group ((group transient-column) - &optional skip-empty) - (transient--maybe-pad-keys group) - (dolist (suffix (oref group suffixes)) - (let ((str (transient-with-shadowed-buffer (transient-format suffix)))) - (unless (and (not skip-empty) (equal str "")) - (insert str) - (unless (string-match-p ".\n\\'" str) - (insert ?\n)))))) - -(cl-defmethod transient--insert-group ((group transient-columns)) - (if transient-force-single-column - (dolist (group (oref group suffixes)) - (transient--insert-group group t)) - (let* ((columns - (mapcar - (lambda (column) - (transient--maybe-pad-keys column group) - (transient-with-shadowed-buffer - `(,@(and-let* ((desc (transient-format-description column))) - (list desc)) - ,@(let ((transient--pending-group column)) - (mapcar #'transient-format (oref column suffixes)))))) - (oref group suffixes))) - (stops (transient--column-stops columns))) - (dolist (row (apply #'transient--mapn #'list columns)) - (let ((stops stops)) - (dolist (cell row) - (let ((stop (pop stops))) - (when cell - (transient--align-to stop) - (insert cell))))) - (insert ?\n))))) - -(cl-defmethod transient--insert-group ((group transient-subgroups)) - (let ((subgroups (oref group suffixes))) - (while-let ((subgroup (pop subgroups))) - (transient--maybe-pad-keys subgroup group) - (transient--insert-group subgroup) - (when subgroups - (insert ?\n))))) - -(cl-defgeneric transient-format (obj) - "Format and return OBJ for display. - -When this function is called, then the current buffer is some -temporary buffer. If you need the buffer from which the prefix -command was invoked to be current, then do so by temporarily -making `transient--original-buffer' current.") - -(cl-defmethod transient-format ((arg string)) - "Return the string ARG after applying the `transient-heading' face." - (propertize arg 'face 'transient-heading)) - -(cl-defmethod transient-format ((_ null)) - "Return a string containing just the newline character." - "\n") - -(cl-defmethod transient-format ((arg integer)) - "Return a string containing just the ARG character." - (char-to-string arg)) - -(cl-defmethod transient-format :around ((obj transient-suffix)) - "Add additional formatting if appropriate. -When reading user input for this infix, then highlight it. -When edit-mode is enabled, then prepend the level information. -When `transient-enable-popup-navigation' is non-nil then format -as a button." - (let ((str (cl-call-next-method obj))) - (when (and (cl-typep obj 'transient-infix) - (eq (oref obj command) this-original-command) - (active-minibuffer-window)) - (setq str (transient--add-face str 'transient-active-infix))) - (when transient--editp - (setq str (concat (let ((level (oref obj level))) - (propertize (format " %s " level) - 'face (if (transient--use-level-p level t) - 'transient-enabled-suffix - 'transient-disabled-suffix))) - str))) - (when (and transient-enable-popup-navigation - (slot-boundp obj 'command)) - (setq str (make-text-button str nil - 'type 'transient - 'suffix obj - 'command (oref obj command)))) - str)) - -(cl-defmethod transient-format ((obj transient-infix)) - "Return a string generated using OBJ's `format'. -%k is formatted using `transient-format-key'. -%d is formatted using `transient-format-description'. -%v is formatted using `transient-format-value'." - (format-spec (oref obj format) - `((?k . ,(transient-format-key obj)) - (?d . ,(transient-format-description obj)) - (?v . ,(transient-format-value obj))))) - -(cl-defmethod transient-format ((obj transient-suffix)) - "Return a string generated using OBJ's `format'. -%k is formatted using `transient-format-key'. -%d is formatted using `transient-format-description'." - (format-spec (oref obj format) - `((?k . ,(transient-format-key obj)) - (?d . ,(transient-format-description obj))))) - -(cl-defgeneric transient-format-key (obj) - "Format OBJ's `key' for display and return the result.") - -(cl-defmethod transient-format-key :around ((obj transient-suffix)) - "Add `transient-inapt-suffix' face if suffix is inapt." - (let ((str (cl-call-next-method))) - (if (oref obj inapt) - (transient--add-face str 'transient-inapt-suffix) - str))) - -(cl-defmethod transient-format-key ((obj transient-suffix)) - "Format OBJ's `key' for display and return the result." - (let ((key (if (slot-boundp obj 'key) (oref obj key) "")) - (cmd (and (slot-boundp obj 'command) (oref obj command)))) - (when-let ((width (oref transient--pending-group pad-keys))) - (setq key (truncate-string-to-width key width nil ?\s))) - (if transient--redisplay-key - (let ((len (length transient--redisplay-key)) - (seq (cl-coerce (edmacro-parse-keys key t) 'list))) - (cond - ((member (seq-take seq len) - (list transient--redisplay-key - (thread-last transient--redisplay-key - (cl-substitute ?- 'kp-subtract) - (cl-substitute ?= 'kp-equal) - (cl-substitute ?+ 'kp-add)))) - (let ((pre (key-description (vconcat (seq-take seq len)))) - (suf (key-description (vconcat (seq-drop seq len))))) - (setq pre (string-replace "RET" "C-m" pre)) - (setq pre (string-replace "TAB" "C-i" pre)) - (setq suf (string-replace "RET" "C-m" suf)) - (setq suf (string-replace "TAB" "C-i" suf)) - ;; We use e.g., "-k" instead of the more correct "- k", - ;; because the former is prettier. If we did that in - ;; the definition, then we want to drop the space that - ;; is reinserted above. False-positives are possible - ;; for silly bindings like "-C-c C-c". - (unless (string-search " " key) - (setq pre (string-replace " " "" pre)) - (setq suf (string-replace " " "" suf))) - (concat (propertize pre 'face 'transient-unreachable-key) - (and (string-prefix-p (concat pre " ") key) " ") - (propertize suf 'face (transient--key-face cmd)) - (save-excursion - (and (string-match " +\\'" key) - (propertize (match-string 0 key) - 'face 'fixed-pitch)))))) - ((transient--lookup-key transient-sticky-map (kbd key)) - (propertize key 'face (transient--key-face cmd))) - (t - (propertize key 'face 'transient-unreachable-key)))) - (propertize key 'face (transient--key-face cmd))))) - -(cl-defmethod transient-format-key :around ((obj transient-argument)) - "Handle `transient-highlight-mismatched-keys'." - (let ((key (cl-call-next-method obj))) - (cond - ((not transient-highlight-mismatched-keys) key) - ((not (slot-boundp obj 'shortarg)) - (transient--add-face key 'transient-nonstandard-key)) - ((not (string-equal key (oref obj shortarg))) - (transient--add-face key 'transient-mismatched-key)) - (key)))) - -(cl-defgeneric transient-format-description (obj) - "Format OBJ's `description' for display and return the result.") - -(cl-defmethod transient-format-description ((obj transient-suffix)) - "The `description' slot may be a function, in which case that is -called inside the correct buffer (see `transient--insert-group') -and its value is returned to the caller." - (transient--get-description obj)) - -(cl-defmethod transient-format-description ((obj transient-value-preset)) - (pcase-let* (((eieio description key set) obj) - ((eieio value) transient--prefix) - (active (seq-set-equal-p set value))) - (format - "%s %s" - (propertize (or description (format "Preset %s" key)) - 'face (and active 'transient-argument)) - (format (propertize "(%s)" 'face 'transient-delimiter) - (mapconcat (lambda (arg) - (propertize - arg 'face (cond (active 'transient-argument) - ((member arg value) - '((:weight demibold) - transient-inactive-argument)) - ('transient-inactive-argument)))) - set " "))))) - -(cl-defmethod transient-format-description ((obj transient-group)) - "Format the description by calling the next method. -If the result doesn't use the `face' property at all, then apply the -face `transient-heading' to the complete string." - (and-let* ((desc (transient--get-description obj))) - (cond ((oref obj inapt) - (propertize desc 'face 'transient-inapt-suffix)) - ((text-property-not-all 0 (length desc) 'face nil desc) - desc) - ((propertize desc 'face 'transient-heading))))) - -(cl-defmethod transient-format-description :around ((obj transient-suffix)) - "Format the description by calling the next method. -If the result is nil, then use \"(BUG: no description)\" as the -description. If the OBJ's `key' is currently unreachable, then -apply the face `transient-unreachable' to the complete string." - (let ((desc (or (cl-call-next-method obj) - (and (slot-boundp transient--prefix 'suffix-description) - (funcall (oref transient--prefix suffix-description) - obj))))) - (if desc - (when-let ((face (transient--get-face obj 'face))) - (setq desc (transient--add-face desc face t))) - (setq desc (propertize "(BUG: no description)" 'face 'error))) - (when (if transient--all-levels-p - (> (oref obj level) transient--default-prefix-level) - (and transient-highlight-higher-levels - (> (max (oref obj level) transient--max-group-level) - transient--default-prefix-level))) - (setq desc (transient--add-face desc 'transient-higher-level))) - (when-let ((inapt-face (and (oref obj inapt) - (transient--get-face obj 'inapt-face)))) - (setq desc (transient--add-face desc inapt-face))) - (when (and (slot-boundp obj 'key) - (transient--key-unreachable-p obj)) - (setq desc (transient--add-face desc 'transient-unreachable))) - desc)) - -(cl-defgeneric transient-format-value (obj) - "Format OBJ's value for display and return the result.") - -(cl-defmethod transient-format-value ((obj transient-suffix)) - (propertize (oref obj argument) - 'face (if (oref obj value) - 'transient-argument - 'transient-inactive-argument))) - -(cl-defmethod transient-format-value ((obj transient-option)) - (let ((argument (oref obj argument))) - (if-let ((value (oref obj value))) - (pcase-exhaustive (oref obj multi-value) - ('nil - (concat (propertize argument 'face 'transient-argument) - (propertize value 'face 'transient-value))) - ((or 't 'rest) - (concat (propertize (if (string-suffix-p " " argument) - argument - (concat argument " ")) - 'face 'transient-argument) - (propertize (mapconcat #'prin1-to-string value " ") - 'face 'transient-value))) - ('repeat - (mapconcat (lambda (value) - (concat (propertize argument 'face 'transient-argument) - (propertize value 'face 'transient-value))) - value " "))) - (propertize argument 'face 'transient-inactive-argument)))) - -(cl-defmethod transient-format-value ((obj transient-switches)) - (with-slots (value argument-format choices) obj - (format (propertize argument-format - 'face (if value - 'transient-argument - 'transient-inactive-argument)) - (format - (propertize "[%s]" 'face 'transient-delimiter) - (mapconcat - (lambda (choice) - (propertize choice 'face - (if (equal (format argument-format choice) value) - 'transient-value - 'transient-inactive-value))) - choices - (propertize "|" 'face 'transient-delimiter)))))) - -(cl-defmethod transient--get-description ((obj transient-child)) - (and-let* ((desc (oref obj description))) - (if (functionp desc) - (if (= (car (transient--func-arity desc)) 1) - (funcall desc obj) - (funcall desc)) - desc))) - -(cl-defmethod transient--get-face ((obj transient-suffix) slot) - (and-let* (((slot-boundp obj slot)) - (face (slot-value obj slot))) - (if (and (not (facep face)) - (functionp face)) - (let ((transient--pending-suffix obj)) - (if (= (car (transient--func-arity face)) 1) - (funcall face obj) - (funcall face))) - face))) - -(defun transient--add-face (string face &optional append beg end) - (let ((str (copy-sequence string))) - (add-face-text-property (or beg 0) (or end (length str)) face append str) - str)) - -(defun transient--key-face (&optional cmd enforce-type) - (or (and transient-semantic-coloring - (not transient--helpp) - (not transient--editp) - (or (and cmd (get cmd 'transient-face)) - (get (transient--get-pre-command cmd enforce-type) - 'transient-face))) - (if cmd 'transient-key 'transient-key-noop))) - -(defun transient--key-unreachable-p (obj) - (and transient--redisplay-key - (let ((key (oref obj key))) - (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list) - (length transient--redisplay-key)) - transient--redisplay-key) - (transient--lookup-key transient-sticky-map (kbd key))))))) - -(defun transient--lookup-key (keymap key) - (let ((val (lookup-key keymap key))) - (and val (not (integerp val)) val))) - -(defun transient--maybe-pad-keys (group &optional parent) - (when-let ((pad (or (oref group pad-keys) - (and parent (oref parent pad-keys))))) - (oset group pad-keys - (apply #'max - (if (integerp pad) pad 0) - (seq-keep (lambda (suffix) - (and (eieio-object-p suffix) - (slot-boundp suffix 'key) - (length (oref suffix key)))) - (oref group suffixes)))))) - -(defun transient--pixel-width (string) - (save-window-excursion - (with-temp-buffer - (insert string) - (set-window-dedicated-p nil nil) - (set-window-buffer nil (current-buffer)) - (car (window-text-pixel-size - nil (line-beginning-position) (point)))))) - -(defun transient--column-stops (columns) - (let* ((var-pitch (or transient-align-variable-pitch - (oref transient--prefix variable-pitch))) - (char-width (and var-pitch (transient--pixel-width " ")))) - (transient--seq-reductions-from - (apply-partially #'+ (* 2 (if var-pitch char-width 1))) - (transient--mapn - (lambda (cells min) - (apply #'max - (if min (if var-pitch (* min char-width) min) 0) - (mapcar (if var-pitch #'transient--pixel-width #'length) cells))) - columns - (oref transient--prefix column-widths)) - 0))) - -(defun transient--align-to (stop) - (unless (zerop stop) - (insert (if (or transient-align-variable-pitch - (oref transient--prefix variable-pitch)) - (propertize " " 'display `(space :align-to (,stop))) - (make-string (max 0 (- stop (current-column))) ?\s))))) - -(defun transient-command-summary-or-name (obj) - "Return the summary or name of the command represented by OBJ. - -If the command has a doc-string, then return the first line of -that, else its name. - -Intended to be temporarily used as the `:suffix-description' of -a prefix command, while porting a regular keymap to a transient." - (let ((command (oref obj command))) - (if-let ((doc (documentation command))) - (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face) - (propertize (symbol-name command) 'face 'font-lock-function-name-face)))) - -;;; Help - -(cl-defgeneric transient-show-help (obj) - "Show documentation for the command represented by OBJ.") - -(cl-defmethod transient-show-help ((obj transient-prefix)) - "Call `show-help' if non-nil, else show `info-manual', -if non-nil, else show the `man-page' if non-nil, else use -`describe-function'." - (with-slots (show-help info-manual man-page command) obj - (cond (show-help (funcall show-help obj)) - (info-manual (transient--show-manual info-manual)) - (man-page (transient--show-manpage man-page)) - ((transient--describe-function command))))) - -(cl-defmethod transient-show-help ((obj transient-suffix)) - "Call `show-help' if non-nil, else use `describe-function'. -Also used to dispatch showing documentation for the current -prefix. If the suffix is a sub-prefix, then also call the -prefix method." - (cond - ((eq this-command 'transient-help) - (transient-show-help transient--prefix)) - ((let ((prefix (get (oref obj command) - 'transient--prefix))) - (and prefix (not (eq (oref transient--prefix command) this-command)) - (prog1 t (transient-show-help prefix))))) - ((if-let ((show-help (oref obj show-help))) - (funcall show-help obj) - (transient--describe-function this-command))))) - -(cl-defmethod transient-show-help ((obj transient-infix)) - "Call `show-help' if non-nil, else show the `man-page' -if non-nil, else use `describe-function'. When showing the -manpage, then try to jump to the correct location." - (if-let ((show-help (oref obj show-help))) - (funcall show-help obj) - (if-let ((man-page (oref transient--prefix man-page)) - (argument (and (slot-boundp obj 'argument) - (oref obj argument)))) - (transient--show-manpage man-page argument) - (transient--describe-function this-command)))) - -;; `cl-generic-generalizers' doesn't support `command' et al. -(cl-defmethod transient-show-help (cmd) - "Show the command doc-string." - (transient--describe-function cmd)) - -(defmacro transient-with-help-window (&rest body) - "Evaluate BODY, send output to *Help* buffer, and display it in a window. -Select the help window, and make the help buffer current and return it." - (declare (indent 0)) - `(let ((buffer nil) - (help-window-select t)) - (with-help-window (help-buffer) - ,@body - (setq buffer (current-buffer))) - (set-buffer buffer))) - -(defun transient--describe-function (fn) - (let* ((buffer nil) - (help-window-select t) - (temp-buffer-window-setup-hook - (cons (lambda () (setq buffer (current-buffer))) - temp-buffer-window-setup-hook))) - (describe-function fn) - (set-buffer buffer))) - -(defun transient--show-manual (manual) - (info manual)) - -(defun transient--show-manpage (manpage &optional argument) - (require 'man) - (let* ((Man-notify-method 'meek) - (buf (Man-getpage-in-background manpage)) - (proc (get-buffer-process buf))) - (while (and proc (eq (process-status proc) 'run)) - (accept-process-output proc)) - (switch-to-buffer buf) - (when argument - (transient--goto-argument-description argument)))) - -(defun transient--goto-argument-description (arg) - (goto-char (point-min)) - (let ((case-fold-search nil) - ;; This matches preceding/proceeding options. Options - ;; such as "-a", "-S[<keyid>]", and "--grep=<pattern>" - ;; are matched by this regex without the shy group. - ;; The ". " in the shy group is for options such as - ;; "-m parent-number", and the "-[^[:space:]]+ " is - ;; for options such as "--mainline parent-number" - (others "-\\(?:. \\|-[^[:space:]]+ \\)?[^[:space:]]+")) - (when (re-search-forward - (if (equal arg "--") - ;; Special case. - "^[\t\s]+\\(--\\(?: \\|$\\)\\|\\[--\\]\\)" - ;; Should start with whitespace and may have - ;; any number of options before and/or after. - (format - "^[\t\s]+\\(?:%s, \\)*?\\(?1:%s\\)%s\\(?:, %s\\)*$" - others - ;; Options don't necessarily end in an "=" - ;; (e.g., "--gpg-sign[=<keyid>]") - (string-remove-suffix "=" arg) - ;; Simple options don't end in an "=". Splitting this - ;; into 2 cases should make getting false positives - ;; less likely. - (if (string-suffix-p "=" arg) - ;; "[^[:space:]]*[^.[:space:]]" matches the option - ;; value, which is usually after the option name - ;; and either '=' or '[='. The value can't end in - ;; a period, as that means it's being used at the - ;; end of a sentence. The space is for options - ;; such as '--mainline parent-number'. - "\\(?: \\|\\[?=\\)[^[:space:]]*[^.[:space:]]" - ;; Either this doesn't match anything (e.g., "-a"), - ;; or the option is followed by a value delimited - ;; by a "[", "<", or ":". A space might appear - ;; before this value, as in "-f <file>". The - ;; space alternative is for options such as - ;; "-m parent-number". - "\\(?:\\(?: \\| ?[\\[<:]\\)[^[:space:]]*[^.[:space:]]\\)?") - others)) - nil t) - (goto-char (match-beginning 1))))) - -(defun transient--insert-help () - (unless (looking-back "\n\n" 2) - (insert "\n")) - (when transient--helpp - (insert - (format (propertize "\ -Type a %s to show help for that suffix command, or %s to show manual. -Type %s to exit help.\n" - 'face 'transient-heading) - (propertize "<KEY>" 'face 'transient-key) - (propertize "?" 'face 'transient-key) - (propertize "C-g" 'face 'transient-key)))) - (when transient--editp - (unless transient--helpp - (insert - (format (propertize "\ -Type a %s to set level for that suffix command. -Type %s to set what levels are available for this prefix command.\n" - 'face 'transient-heading) - (propertize "<KEY>" 'face 'transient-key) - (propertize "C-x l" 'face 'transient-key)))) - (with-slots (level) transient--prefix - (insert - (format (propertize " -Suffixes on levels %s are available. -Suffixes on levels %s and %s are unavailable.\n" - 'face 'transient-heading) - (propertize (format "1-%s" level) - 'face 'transient-enabled-suffix) - (propertize " 0 " - 'face 'transient-disabled-suffix) - (propertize (format ">=%s" (1+ level)) - 'face 'transient-disabled-suffix)))))) - -(cl-defgeneric transient-show-summary (obj &optional return) - "Show brief summary about the command at point in the echo area. - -If OBJ's `summary' slot is a string, use that. If it is a function, -call that with OBJ as the only argument and use the returned string. -If `summary' is or returns something other than a string or nil, -show no summary. If `summary' is or returns nil, use the first line -of the documentation string, if any. - -If RETURN is non-nil, return the summary instead of showing it. -This is used when a tooltip is needed.") - -(cl-defmethod transient-show-summary ((obj transient-suffix) &optional return) - (with-slots (command summary) obj - (when-let* - ((doc (cond ((functionp summary) - (funcall summary obj)) - (summary) - ((car (split-string (documentation command) "\n"))))) - ((stringp doc)) - ((not (equal doc - (car (split-string (documentation - 'transient--default-infix-command) - "\n")))))) - (when (string-suffix-p "." doc) - (setq doc (substring doc 0 -1))) - (if return - doc - (let ((message-log-max nil)) - (message "%s" doc)))))) - -;;; Popup Navigation - -(defun transient-scroll-up (&optional arg) - "Scroll text of transient popup window upward ARG lines. -If ARG is nil scroll near full screen. This is a wrapper -around `scroll-up-command' (which see)." - (interactive "^P") - (with-selected-window transient--window - (scroll-up-command arg))) - -(defun transient-scroll-down (&optional arg) - "Scroll text of transient popup window down ARG lines. -If ARG is nil scroll near full screen. This is a wrapper -around `scroll-down-command' (which see)." - (interactive "^P") - (with-selected-window transient--window - (scroll-down-command arg))) - -(defun transient-backward-button (n) - "Move to the previous button in the transient popup buffer. -See `backward-button' for information about N." - (interactive "p") - (with-selected-window transient--window - (backward-button n t) - (when (eq transient-enable-popup-navigation 'verbose) - (transient-show-summary (get-text-property (point) 'suffix))))) - -(defun transient-forward-button (n) - "Move to the next button in the transient popup buffer. -See `forward-button' for information about N." - (interactive "p") - (with-selected-window transient--window - (forward-button n t) - (when (eq transient-enable-popup-navigation 'verbose) - (transient-show-summary (get-text-property (point) 'suffix))))) - -(define-button-type 'transient - 'face nil - 'keymap transient-button-map - 'help-echo (lambda (win buf pos) - (with-selected-window win - (with-current-buffer buf - (transient-show-summary - (get-text-property pos 'suffix) t))))) - -(defun transient--goto-button (command) - (cond - ((stringp command) - (when (re-search-forward (concat "^" (regexp-quote command)) nil t) - (goto-char (match-beginning 0)))) - (command - (cl-flet ((found () (eq (button-get (button-at (point)) 'command) command))) - (while (and (ignore-errors (forward-button 1)) - (not (found)))) - (unless (found) - (goto-char (point-min)) - (ignore-errors (forward-button 1)) - (unless (found) - (goto-char (point-min)))))))) - -(defun transient--heading-at-point () - (and (eq (get-text-property (point) 'face) 'transient-heading) - (let ((beg (line-beginning-position))) - (buffer-substring-no-properties - beg (next-single-property-change - beg 'face nil (line-end-position)))))) - -;;; Compatibility -;;;; Popup Isearch - -(defvar-keymap transient--isearch-mode-map - :parent isearch-mode-map - "<remap> <isearch-exit>" #'transient-isearch-exit - "<remap> <isearch-cancel>" #'transient-isearch-cancel - "<remap> <isearch-abort>" #'transient-isearch-abort) - -(defun transient-isearch-backward (&optional regexp-p) - "Do incremental search backward. -With a prefix argument, do an incremental regular expression -search instead." - (interactive "P") - (transient--isearch-setup) - (let ((isearch-mode-map transient--isearch-mode-map)) - (isearch-mode nil regexp-p))) - -(defun transient-isearch-forward (&optional regexp-p) - "Do incremental search forward. -With a prefix argument, do an incremental regular expression -search instead." - (interactive "P") - (transient--isearch-setup) - (let ((isearch-mode-map transient--isearch-mode-map)) - (isearch-mode t regexp-p))) - -(defun transient-isearch-exit () - "Like `isearch-exit' but adapted for `transient'." - (interactive) - (isearch-exit) - (transient--isearch-exit)) - -(defun transient-isearch-cancel () - "Like `isearch-cancel' but adapted for `transient'." - (interactive) - (condition-case nil (isearch-cancel) (quit)) - (transient--isearch-exit)) - -(defun transient-isearch-abort () - "Like `isearch-abort' but adapted for `transient'." - (interactive) - (let ((around (lambda (fn) - (condition-case nil (funcall fn) (quit)) - (transient--isearch-exit)))) - (advice-add 'isearch-cancel :around around) - (unwind-protect - (isearch-abort) - (advice-remove 'isearch-cancel around)))) - -(defun transient--isearch-setup () - (select-window transient--window) - (transient--suspend-override t)) - -(defun transient--isearch-exit () - (select-window transient--original-window) - (transient--resume-override)) - -;;;; Edebug - -(defun transient--edebug-command-p () - (and (bound-and-true-p edebug-active) - (or (memq this-command '(top-level abort-recursive-edit)) - (string-prefix-p "edebug" (symbol-name this-command))))) - -;;;; Miscellaneous - -(cl-pushnew (list nil (concat "^\\s-*(" - (eval-when-compile - (regexp-opt - '("transient-define-prefix" - "transient-define-suffix" - "transient-define-infix" - "transient-define-argument") - t)) - "\\s-+\\(" lisp-mode-symbol-regexp "\\)") - 2) - lisp-imenu-generic-expression :test #'equal) - -(declare-function which-key-mode "ext:which-key" (&optional arg)) - -(defun transient--suspend-which-key-mode () - (when (bound-and-true-p which-key-mode) - (which-key-mode -1) - (add-hook 'transient-exit-hook #'transient--resume-which-key-mode))) - -(defun transient--resume-which-key-mode () - (unless transient--prefix - (which-key-mode 1) - (remove-hook 'transient-exit-hook #'transient--resume-which-key-mode))) - -(defun transient-bind-q-to-quit () - "Modify some keymaps to bind \"q\" to the appropriate quit command. - -\"C-g\" is the default binding for such commands now, but Transient's -predecessor Magit-Popup used \"q\" instead. If you would like to get -that binding back, then call this function in your init file like so: - - (with-eval-after-load \\='transient - (transient-bind-q-to-quit)) - -Individual transients may already bind \"q\" to something else -and such a binding would shadow the quit binding. If that is the -case then \"Q\" is bound to whatever \"q\" would have been bound -to by setting `transient-substitute-key-function' to a function -that does that. Of course \"Q\" may already be bound to something -else, so that function binds \"M-q\" to that command instead. -Of course \"M-q\" may already be bound to something else, but -we stop there." - (keymap-set transient-base-map "q" #'transient-quit-one) - (keymap-set transient-sticky-map "q" #'transient-quit-seq) - (setq transient-substitute-key-function - #'transient-rebind-quit-commands)) - -(defun transient-rebind-quit-commands (obj) - "See `transient-bind-q-to-quit'." - (let ((key (oref obj key))) - (cond ((string-equal key "q") "Q") - ((string-equal key "Q") "M-q") - (key)))) - -(defun transient--force-fixed-pitch () - (require 'face-remap) - (face-remap-reset-base 'default) - (face-remap-add-relative 'default 'fixed-pitch)) - -(defun transient--func-arity (fn) - (func-arity (advice--cd*r (if (symbolp fn) (symbol-function fn) fn)))) - -(defun transient--seq-reductions-from (function sequence initial-value) - (let ((acc (list initial-value))) - (seq-doseq (elt sequence) - (push (funcall function (car acc) elt) acc)) - (nreverse acc))) - -(defun transient--mapn (function &rest lists) - "Apply FUNCTION to elements of LISTS. -Like `cl-mapcar' but while that stops when the shortest list -is exhausted, continue until the longest list is, using nil -as stand-in for elements of exhausted lists." - (let (result) - (while (catch 'more (mapc (lambda (l) (and l (throw 'more t))) lists) nil) - (push (apply function (mapcar #'car-safe lists)) result) - (setq lists (mapcar #'cdr lists))) - (nreverse result))) - -;;; Font-Lock - -(defconst transient-font-lock-keywords - (eval-when-compile - `((,(concat "(" - (regexp-opt (list "transient-define-prefix" - "transient-define-infix" - "transient-define-argument" - "transient-define-suffix") - t) - "\\_>[ \t'(]*" - "\\(\\(?:\\sw\\|\\s_\\)+\\)?") - (1 'font-lock-keyword-face) - (2 'font-lock-function-name-face nil t))))) - -(font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords) - -;;; Auxiliary Classes -;;;; `transient-lisp-variable' - -(defclass transient-lisp-variable (transient-variable) - ((reader :initform #'transient-lisp-variable--reader) - (always-read :initform t) - (set-value :initarg :set-value :initform #'set)) - "[Experimental] Class used for Lisp variables.") - -(cl-defmethod transient-init-value ((obj transient-lisp-variable)) - (oset obj value (symbol-value (oref obj variable)))) - -(cl-defmethod transient-infix-set ((obj transient-lisp-variable) value) - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value value))) - -(cl-defmethod transient-format-description ((obj transient-lisp-variable)) - (or (cl-call-next-method obj) - (symbol-name (oref obj variable)))) - -(cl-defmethod transient-format-value ((obj transient-lisp-variable)) - (propertize (prin1-to-string (oref obj value)) - 'face 'transient-value)) - -(cl-defmethod transient-prompt ((obj transient-lisp-variable)) - (if (and (slot-boundp obj 'prompt) - (oref obj prompt)) - (cl-call-next-method obj) - (format "Set %s: " (oref obj variable)))) - -(defun transient-lisp-variable--reader (prompt initial-input _history) - (read--expression prompt initial-input)) - -;;; _ -(provide 'transient) -;; Local Variables: -;; indent-tabs-mode: nil -;; checkdoc-symbol-words: ("command-line" "edit-mode" "help-mode") -;; End: -;;; transient.el ends here diff --git a/emacs/elpa/transient-20241111.1438/transient.elc b/emacs/elpa/transient-20241111.1438/transient.elc Binary files differ. diff --git a/emacs/elpa/transient-20241111.1438/transient.info b/emacs/elpa/transient-20241111.1438/transient.info @@ -1,3364 +0,0 @@ -This is transient.info, produced by makeinfo version 6.8 from -transient.texi. - - Copyright (C) 2018–2024 Free Software Foundation, Inc. - - You can redistribute this document 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 document 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. - -INFO-DIR-SECTION Emacs misc features -START-INFO-DIR-ENTRY -* Transient: (transient). Transient Commands. -END-INFO-DIR-ENTRY - - -File: transient.info, Node: Top, Next: Introduction, Up: (dir) - -Transient User and Developer Manual -*********************************** - -Transient is the library used to implement the keyboard-driven “menus” -in Magit. It is distributed as a separate package, so that it can be -used to implement similar menus in other packages. - - This manual can be bit hard to digest when getting started. A useful -resource to get over that hurdle is Psionic K’s interactive tutorial, -available at <https://github.com/positron-solutions/transient-showcase>. - -This manual is for Transient version 0.7.9. - - Copyright (C) 2018–2024 Free Software Foundation, Inc. - - You can redistribute this document 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 document 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. - -* Menu: - -* Introduction:: -* Usage:: -* Modifying Existing Transients:: -* Defining New Commands:: -* Classes and Methods:: -* FAQ:: -* Keystroke Index:: -* Command and Function Index:: -* Variable Index:: -* Concept Index:: -* GNU General Public License:: - -— The Detailed Node Listing — - -Usage - -* Invoking Transients:: -* Aborting and Resuming Transients:: -* Common Suffix Commands:: -* Saving Values:: -* Using History:: -* Getting Help for Suffix Commands:: -* Enabling and Disabling Suffixes:: -* Other Commands:: -* Configuration:: - -Defining New Commands - -* Technical Introduction:: -* Defining Transients:: -* Binding Suffix and Infix Commands:: -* Defining Suffix and Infix Commands:: -* Using Infix Arguments:: -* Transient State:: - -Binding Suffix and Infix Commands - -* Group Specifications:: -* Suffix Specifications:: - - -Classes and Methods - -* Group Classes:: -* Group Methods:: -* Prefix Classes:: -* Suffix Classes:: -* Suffix Methods:: -* Prefix Slots:: -* Suffix Slots:: -* Predicate Slots:: - -Suffix Methods - -* Suffix Value Methods:: -* Suffix Format Methods:: - - - - -File: transient.info, Node: Introduction, Next: Usage, Prev: Top, Up: Top - -1 Introduction -************** - -Transient is the library used to implement the keyboard-driven “menus” -in Magit. It is distributed as a separate package, so that it can be -used to implement similar menus in other packages. - - This manual can be bit hard to digest when getting started. A useful -resource to get over that hurdle is Psionic K’s interactive tutorial, -available at <https://github.com/positron-solutions/transient-showcase>. - -Some things that Transient can do -================================= - - • Display current state of arguments - • Display and manage lifecycle of modal bindings - • Contextual user interface - • Flow control for wizard-like composition of interactive forms - • History & persistence - • Rendering arguments for controlling CLI programs - -Complexity in CLI programs -========================== - -Complexity tends to grow with time. How do you manage the complexity of -commands? Consider the humble shell command ‘ls’. It now has over -_fifty_ command line options. Some of these are boolean flags (‘ls --l’). Some take arguments (‘ls --sort=s’). Some have no effect unless -paired with other flags (‘ls -lh’). Some are mutually exclusive. Some -shell commands even have so many options that they introduce -_subcommands_ (‘git branch’, ‘git commit’), each with their own rich set -of options (‘git branch -f’). - -Using Transient for composing interactive commands -================================================== - -What about Emacs commands used interactively? How do these handle -options? One solution is to make many versions of the same command, so -you don’t need to! Consider: ‘delete-other-windows’ vs. -‘delete-other-windows-vertically’ (among many similar examples). - - Some Emacs commands will simply prompt you for the next "argument" -(‘M-x switch-to-buffer’). Another common solution is to use prefix -arguments which usually start with ‘C-u’. Sometimes these are sensibly -numerical in nature (‘C-u 4 M-x forward-paragraph’ to move forward 4 -paragraphs). But sometimes they function instead as boolean "switches" -(‘C-u C-SPACE’ to jump to the last mark instead of just setting it, ‘C-u -C-u C-SPACE’ to unconditionally set the mark). Since there aren’t many -standards for the use of prefix options, you have to read the command’s -documentation to find out what the possibilities are. - - But when an Emacs command grows to have a truly large set of options -and arguments, with dependencies between them, lots of option values, -etc., these simple approaches just don’t scale. Transient is designed -to solve this issue. Think of it as the humble prefix argument ‘C-u’, -_raised to the power of 10_. Like ‘C-u’, it is key driven. Like the -shell, it supports boolean "flag" options, options that take arguments, -and even "sub-commands", with their own options. But instead of -searching through a man page or command documentation, well-designed -transients _guide_ their users to the relevant set of options (and even -their possible values!) directly, taking into account any important -pre-existing Emacs settings. And while for shell commands like ‘ls’, -there is only one way to "execute" (hit ‘Return’!), transients can -"execute" using multiple different keys tied to one of many -self-documenting _actions_ (imagine having 5 different colored return -keys on your keyboard!). Transients make navigating and setting large, -complex groups of command options and arguments easy. Fun even. Once -you’ve tried it, it’s hard to go back to the ‘C-u what can I do here -again?’ way. - - -File: transient.info, Node: Usage, Next: Modifying Existing Transients, Prev: Introduction, Up: Top - -2 Usage -******* - -* Menu: - -* Invoking Transients:: -* Aborting and Resuming Transients:: -* Common Suffix Commands:: -* Saving Values:: -* Using History:: -* Getting Help for Suffix Commands:: -* Enabling and Disabling Suffixes:: -* Other Commands:: -* Configuration:: - - -File: transient.info, Node: Invoking Transients, Next: Aborting and Resuming Transients, Up: Usage - -2.1 Invoking Transients -======================= - -A transient prefix command is invoked like any other command by pressing -the key that is bound to that command. The main difference to other -commands is that a transient prefix command activates a transient -keymap, which temporarily binds the transient’s infix and suffix -commands. Bindings from other keymaps may, or may not, be disabled -while the transient state is in effect. - - There are two kinds of commands that are available after invoking a -transient prefix command; infix and suffix commands. Infix commands set -some value (which is then shown in a popup buffer), without leaving the -transient. Suffix commands, on the other hand, usually quit the -transient and they may use the values set by the infix commands, i.e., -the infix *arguments*. - - Instead of setting arguments to be used by a suffix command, infix -commands may also set some value by side-effect, e.g., by setting the -value of some variable. - - -File: transient.info, Node: Aborting and Resuming Transients, Next: Common Suffix Commands, Prev: Invoking Transients, Up: Usage - -2.2 Aborting and Resuming Transients -==================================== - -To quit the transient without invoking a suffix command press ‘C-g’. - - Key bindings in transient keymaps may be longer than a single event. -After pressing a valid prefix key, all commands whose bindings do not -begin with that prefix key are temporarily unavailable and grayed out. -To abort the prefix key press ‘C-g’ (which in this case only quits the -prefix key, but not the complete transient). - - A transient prefix command can be bound as a suffix of another -transient. Invoking such a suffix replaces the current transient state -with a new transient state, i.e., the available bindings change and the -information displayed in the popup buffer is updated accordingly. -Pressing ‘C-g’ while a nested transient is active only quits the -innermost transient, causing a return to the previous transient. - - ‘C-q’ or ‘C-z’ on the other hand always exits all transients. If you -use the latter, then you can later resume the stack of transients using -‘M-x transient-resume’. - -‘C-g’ (‘transient-quit-seq’) -‘C-g’ (‘transient-quit-one’) - This key quits the currently active incomplete key sequence, if - any, or else the current transient. When quitting the current - transient, it returns to the previous transient, if any. - - Transient’s predecessor bound ‘q’ instead of ‘C-g’ to the quit -command. To learn how to get that binding back see -‘transient-bind-q-to-quit’’s documentation string. - -‘C-q’ (‘transient-quit-all’) - This command quits the currently active incomplete key sequence, if - any, and all transients, including the active transient and all - suspended transients, if any. - -‘C-z’ (‘transient-suspend’) - Like ‘transient-quit-all’, this command quits an incomplete key - sequence, if any, and all transients. Additionally, it saves the - stack of transients so that it can easily be resumed (which is - particularly useful if you quickly need to do “something else” and - the stack is deeper than a single transient, and/or you have - already changed the values of some infix arguments). - - Note that only a single stack of transients can be saved at a time. - If another stack is already saved, then saving a new stack discards - the previous stack. - -‘M-x transient-resume’ - This command resumes the previously suspended stack of transients, - if any. - - -File: transient.info, Node: Common Suffix Commands, Next: Saving Values, Prev: Aborting and Resuming Transients, Up: Usage - -2.3 Common Suffix Commands -========================== - -A few shared suffix commands are available in all transients. These -suffix commands are not shown in the popup buffer by default. - - This includes the aborting commands mentioned in the previous -section, as well as some other commands that are all bound to ‘C-x KEY’. -After ‘C-x’ is pressed, a section featuring all these common commands is -temporarily shown in the popup buffer. After invoking one of them, the -section disappears again. Note, however, that one of these commands is -described as “Show common permanently”; invoke that if you want the -common commands to always be shown for all transients. - -‘C-x t’ (‘transient-toggle-common’) - This command toggles whether the generic commands that are common - to all transients are always displayed or only after typing the - incomplete prefix key sequence ‘C-x’. This only affects the - current Emacs session. - - -- User Option: transient-show-common-commands - This option controls whether shared suffix commands are shown - alongside the transient-specific infix and suffix commands. By - default, the shared commands are not shown to avoid overwhelming - the user with too many options. - - While a transient is active, pressing ‘C-x’ always shows the common - commands. The value of this option can be changed for the current - Emacs session by typing ‘C-x t’ while a transient is active. - - The other common commands are described in either the previous or in -one of the following sections. - - Some of Transient’s key bindings differ from the respective bindings -of Magit-Popup; see *note FAQ:: for more information. - - -File: transient.info, Node: Saving Values, Next: Using History, Prev: Common Suffix Commands, Up: Usage - -2.4 Saving Values -================= - -After setting the infix arguments in a transient, the user can save -those arguments for future invocations. - - Most transients will start out with the saved arguments when they are -invoked. There are a few exceptions, though. Some transients are -designed so that the value that they use is stored externally as the -buffer-local value of some variable. Invoking such a transient again -uses the buffer-local value. (1) - - If the user does not save the value and just exits using a regular -suffix command, then the value is merely saved to the transient’s -history. That value won’t be used when the transient is next invoked, -but it is easily accessible (see *note Using History::). - -‘C-x s’ (‘transient-set’) - This command saves the value of the active transient for this Emacs - session. - -‘C-x C-s’ (‘transient-save’) - Save the value of the active transient persistently across Emacs - sessions. - -‘C-x C-k’ (‘transient-reset’) - Clear the set and saved values of the active transient. - - -- User Option: transient-values-file - This option names the file that is used to persist the values of - transients between Emacs sessions. - - ---------- Footnotes ---------- - - (1) ‘magit-diff’ and ‘magit-log’ are two prominent examples, and -their handling of buffer-local values is actually a bit more complicated -than outlined above and even customizable. - - -File: transient.info, Node: Using History, Next: Getting Help for Suffix Commands, Prev: Saving Values, Up: Usage - -2.5 Using History -================= - -Every time the user invokes a suffix command the transient’s current -value is saved to its history. These values can be cycled through the -same way one can cycle through the history of commands that read -user-input in the minibuffer. - -‘C-M-p’ (‘transient-history-prev’) -‘C-x p’ - This command switches to the previous value used for the active - transient. - -‘C-M-n’ (‘transient-history-next’) -‘C-x n’ - This command switches to the next value used for the active - transient. - - In addition to the transient-wide history, Transient of course -supports per-infix history. When an infix reads user-input using the -minibuffer, the user can use the regular minibuffer history commands to -cycle through previously used values. Usually the same keys as those -mentioned above are bound to those commands. - - Authors of transients should arrange for different infix commands -that read the same kind of value to also use the same history key (see -*note Suffix Slots::). - - Both kinds of history are saved to a file when Emacs is exited. - - -- User Option: transient-history-file - This option names the file that is used to persist the history of - transients and their infixes between Emacs sessions. - - -- User Option: transient-history-limit - This option controls how many history elements are kept at the time - the history is saved in ‘transient-history-file’. - - -File: transient.info, Node: Getting Help for Suffix Commands, Next: Enabling and Disabling Suffixes, Prev: Using History, Up: Usage - -2.6 Getting Help for Suffix Commands -==================================== - -Transients can have many suffixes and infixes that the user might not be -familiar with. To make it trivial to get help for these, Transient -provides access to the documentation directly from the active transient. - -‘C-h’ (‘transient-help’) - This command enters help mode. When help mode is active, typing a - key shows information about the suffix command that the key - normally is bound to (instead of invoking it). Pressing ‘C-h’ a - second time shows information about the _prefix_ command. - - After typing a key, the stack of transient states is suspended and - information about the suffix command is shown instead. Typing ‘q’ - in the help buffer buries that buffer and resumes the transient - state. - - What sort of documentation is shown depends on how the transient was -defined. For infix commands that represent command-line arguments this -ideally shows the appropriate manpage. ‘transient-help’ then tries to -jump to the correct location within that. Info manuals are also -supported. The fallback is to show the command’s documentation string, -for non-infix suffixes this is usually appropriate. - - -File: transient.info, Node: Enabling and Disabling Suffixes, Next: Other Commands, Prev: Getting Help for Suffix Commands, Up: Usage - -2.7 Enabling and Disabling Suffixes -=================================== - -The user base of a package that uses transients can be very diverse. -This is certainly the case for Magit; some users have been using it and -Git for a decade, while others are just getting started now. - - For that reason a mechanism is needed that authors can use to -classify a transient’s infixes and suffixes along the -essentials...everything spectrum. We use the term “levels” to describe -that mechanism. - - Each suffix command is placed on a level and each transient has a -level (called “transient-level”), which controls which suffix commands -are available. Integers between 1 and 7 (inclusive) are valid levels. -For suffixes, 0 is also valid; it means that the suffix is not displayed -at any level. - - The levels of individual transients and/or their individual suffixes -can be changed interactively, by invoking the transient and then -pressing ‘C-x l’ to enter the “edit” mode, see below. - - The default level for both transients and their suffixes is 4. The -‘transient-default-level’ option only controls the default for -transients. The default suffix level is always 4. The authors of -transients should place certain suffixes on a higher level, if they -expect that it won’t be of use to most users, and they should place very -important suffixes on a lower level, so that they remain available even -if the user lowers the transient level. - - -- User Option: transient-default-level - This option controls which suffix levels are made available by - default. It sets the transient-level for transients for which the - user has not set that individually. - - -- User Option: transient-levels-file - This option names the file that is used to persist the levels of - transients and their suffixes between Emacs sessions. - -‘C-x l’ (‘transient-set-level’) - This command enters edit mode. When edit mode is active, then all - infixes and suffixes that are currently usable are displayed along - with their levels. The colors of the levels indicate whether they - are enabled or not. The level of the transient is also displayed - along with some usage information. - - In edit mode, pressing the key that would usually invoke a certain - suffix instead prompts the user for the level that suffix should be - placed on. - - Help mode is available in edit mode. - - To change the transient level press ‘C-x l’ again. - - To exit edit mode press ‘C-g’. - - Note that edit mode does not display any suffixes that are not - currently usable. ‘magit-rebase’, for example, shows different - suffixes depending on whether a rebase is already in progress or - not. The predicates also apply in edit mode. - - Therefore, to control which suffixes are available given a certain - state, you have to make sure that that state is currently active. - -‘C-x a’ (‘transient-toggle-level-limit’) - This command toggle whether suffixes that are on levels higher than - the level specified by ‘transient-default-level’ are temporarily - available anyway. - - -File: transient.info, Node: Other Commands, Next: Configuration, Prev: Enabling and Disabling Suffixes, Up: Usage - -2.8 Other Commands -================== - -When invoking a transient in a small frame, the transient window may not -show the complete buffer, making it necessary to scroll, using the -following commands. These commands are never shown in the transient -window, and the key bindings are the same as for ‘scroll-up-command’ and -‘scroll-down-command’ in other buffers. - - -- Command: transient-scroll-up arg - This command scrolls text of transient popup window upward ARG - lines. If ARG is ‘nil’, then it scrolls near full screen. This is - a wrapper around ‘scroll-up-command’ (which see). - - -- Command: transient-scroll-down arg - This command scrolls text of transient popup window down ARG lines. - If ARG is ‘nil’, then it scrolls near full screen. This is a - wrapper around ‘scroll-down-command’ (which see). - - -File: transient.info, Node: Configuration, Prev: Other Commands, Up: Usage - -2.9 Configuration -================= - -More options are described in *note Common Suffix Commands::, in *note -Saving Values::, in *note Using History:: and in *note Enabling and -Disabling Suffixes::. - -Essential Options ------------------ - -Also see *note Common Suffix Commands::. - - -- User Option: transient-show-popup - This option controls whether the current transient’s infix and - suffix commands are shown in the popup buffer. - - • If ‘t’ (the default) then the popup buffer is shown as soon as - a transient prefix command is invoked. - - • If ‘nil’, then the popup buffer is not shown unless the user - explicitly requests it, by pressing an incomplete prefix key - sequence. - - • If a number, then the a brief one-line summary is shown - instead of the popup buffer. If zero or negative, then not - even that summary is shown; only the pressed key itself is - shown. - - The popup is shown when the user explicitly requests it by - pressing an incomplete prefix key sequence. Unless this is - zero, the popup is shown after that many seconds of inactivity - (using the absolute value). - - -- User Option: transient-enable-popup-navigation - This option controls whether navigation commands are enabled in the - transient popup buffer. If the value is ‘verbose’, additionally - show brief documentation about the command under point in the echo - area. - - While a transient is active the transient popup buffer is not the - current buffer, making it necessary to use dedicated commands to - act on that buffer itself. This is disabled by default. If this - option is non-‘nil’, then the following features are available: - - • ‘<UP>’ moves the cursor to the previous suffix. - • ‘<DOWN>’ moves the cursor to the next suffix. - • ‘M-<RET>’ invokes the suffix the cursor is on. - • ‘mouse-1’ invokes the clicked on suffix. - • ‘C-s’ and ‘C-r’ start isearch in the popup buffer. - - By default ‘M-<RET>’ is bound to ‘transient-push-button’, instead - of ‘<RET>’, because if a transient allows the invocation of - non-suffixes, then it is likely, that you would want ‘<RET>’ to do - what it would do if no transient were active." - - -- User Option: transient-display-buffer-action - This option specifies the action used to display the transient - popup buffer. The transient popup buffer is displayed in a window - using ‘(display-buffer BUFFER transient-display-buffer-action)’. - - The value of this option has the form ‘(FUNCTION . ALIST)’, where - FUNCTION is a function or a list of functions. Each such function - should accept two arguments: a buffer to display and an alist of - the same form as ALIST. See *note (elisp)Choosing Window::, for - details. - - The default is: - - (display-buffer-in-side-window - (side . bottom) - (inhibit-same-window . t) - (window-parameters (no-other-window . t))) - - This displays the window at the bottom of the selected frame. - Another useful FUNCTION is ‘display-buffer-below-selected’, which - is what ‘magit-popup’ used by default. For more alternatives see - *note (elisp)Buffer Display Action Functions::, and *note - (elisp)Buffer Display Action Alists::. - - Note that the buffer that was current before the transient buffer - is shown should remain the current buffer. Many suffix commands - act on the thing at point, if appropriate, and if the transient - buffer became the current buffer, then that would change what is at - point. To that effect ‘inhibit-same-window’ ensures that the - selected window is not used to show the transient buffer. - - It may be possible to display the window in another frame, but - whether that works in practice depends on the window-manager. If - the window manager selects the new window (Emacs frame), then that - unfortunately changes which buffer is current. - - If you change the value of this option, then you might also want to - change the value of ‘transient-mode-line-format’. - -Accessibility Options ---------------------- - - -- User Option: transient-force-single-column - This option controls whether the use of a single column to display - suffixes is enforced. This might be useful for users with low - vision who use large text and might otherwise have to scroll in two - dimensions. - -Auxiliary Options ------------------ - - -- User Option: transient-mode-line-format - This option controls whether the transient popup buffer has a - mode-line, separator line, or neither. - - If ‘nil’, then the buffer has no mode-line. If the buffer is not - displayed right above the echo area, then this probably is not a - good value. - - If ‘line’ (the default) or a natural number, then the buffer has no - mode-line, but a line is drawn in its place. If a number is used, - that specifies the thickness of the line. On termcap frames we - cannot draw lines, so there ‘line’ and numbers are synonyms for - ‘nil’. - - The color of the line is used to indicate if non-suffixes are - allowed and whether they exit the transient. The foreground color - of ‘transient-key-noop’ (if non-suffixes are disallowed), - ‘transient-key-stay’ (if allowed and transient stays active), or - ‘transient-key-exit’ (if allowed and they exit the transient) is - used to draw the line. - - Otherwise this can be any mode-line format. See *note (elisp)Mode - Line Format::, for details. - - -- User Option: transient-semantic-coloring - This option controls whether colors are used to indicate the - transient behavior of commands. - - If non-‘nil’, then the key binding of each suffix is colorized to - indicate whether it exits the transient state or not. The color of - the prefix is indicated using the line that is drawn when the value - of ‘transient-mode-line-format’ is ‘line’. - - -- User Option: transient-highlight-mismatched-keys - This option controls whether key bindings of infix commands that do - not match the respective command-line argument should be - highlighted. For other infix commands this option has no effect. - - When this option is non-‘nil’, the key binding for an infix - argument is highlighted when only a long argument (e.g., - ‘--verbose’) is specified but no shorthand (e.g., ‘-v’). In the - rare case that a shorthand is specified but the key binding does - not match, then it is highlighted differently. - - Highlighting mismatched key bindings is useful when learning the - arguments of the underlying command-line tool; you wouldn’t want to - learn any short-hands that do not actually exist. - - The highlighting is done using one of the faces - ‘transient-mismatched-key’ and ‘transient-nonstandard-key’. - - -- User Option: transient-substitute-key-function - This function is used to modify key bindings. If the value of this - option is ‘nil’ (the default), then no substitution is performed. - - This function is called with one argument, the prefix object, and - must return a key binding description, either the existing key - description it finds in the ‘key’ slot, or the key description that - replaces the prefix key. It could be used to make other - substitutions, but that is discouraged. - - For example, ‘=’ is hard to reach using my custom keyboard layout, - so I substitute ‘(’ for that, which is easy to reach using a layout - optimized for lisp. - - (setq transient-substitute-key-function - (lambda (obj) - (let ((key (oref obj key))) - (if (string-match "\\`\\(=\\)[a-zA-Z]" key) - (replace-match "(" t t key 1) - key)))) - - -- User Option: transient-read-with-initial-input - This option controls whether the last history element is used as - the initial minibuffer input when reading the value of an infix - argument from the user. If ‘nil’, there is no initial input and - the first element has to be accessed the same way as the older - elements. - - -- User Option: transient-hide-during-minibuffer-read - This option controls whether the transient buffer is hidden while - user input is being read in the minibuffer. - - -- User Option: transient-align-variable-pitch - This option controls whether columns are aligned pixel-wise in the - popup buffer. - - If this is non-‘nil’, then columns are aligned pixel-wise to - support variable-pitch fonts. Keys are not aligned, so you should - use a fixed-pitch font for the ‘transient-key’ face. Other key - faces inherit from that face unless a theme is used that breaks - that relationship. - - This option is intended for users who use a variable-pitch font for - the ‘default’ face. - - -- User Option: transient-force-fixed-pitch - This option controls whether to force the use of a monospaced font - in popup buffer. Even if you use a proportional font for the - ‘default’ face, you might still want to use a monospaced font in - transient’s popup buffer. Setting this option to ‘t’ causes - ‘default’ to be remapped to ‘fixed-pitch’ in that buffer. - -Developer Options ------------------ - -These options are mainly intended for developers. - - -- User Option: transient-detect-key-conflicts - This option controls whether key binding conflicts should be - detected at the time the transient is invoked. If so, this results - in an error, which prevents the transient from being used. Because - of that, conflicts are ignored by default. - - Conflicts cannot be determined earlier, i.e., when the transient is - being defined and when new suffixes are being added, because at - that time there can be false-positives. It is actually valid for - multiple suffixes to share a common key binding, provided the - predicates of those suffixes prevent that more than one of them is - enabled at a time. - - -- User Option: transient-highlight-higher-levels - This option controls whether suffixes that would not be available - by default are highlighted. - - When non-‘nil’ then the descriptions of suffixes are highlighted if - their level is above 4, the default of ‘transient-default-level’. - Assuming you have set that variable to 7, this highlights all - suffixes that won’t be available to users without them making the - same customization. - - -File: transient.info, Node: Modifying Existing Transients, Next: Defining New Commands, Prev: Usage, Up: Top - -3 Modifying Existing Transients -******************************* - -To an extent, transients can be customized interactively, see *note -Enabling and Disabling Suffixes::. This section explains how existing -transients can be further modified non-interactively. Let’s begin with -an example: - - (transient-append-suffix 'magit-patch-apply "-3" - '("-R" "Apply in reverse" "--reverse")) - - This inserts a new infix argument to toggle the ‘--reverse’ argument -after the infix argument that toggles ‘-3’ in ‘magit-patch-apply’. - - The following functions share a few arguments: - - • PREFIX is a transient prefix command, a symbol. - - • SUFFIX is a transient infix or suffix specification in the same - form as expected by ‘transient-define-prefix’. Note that an infix - is a special kind of suffix. Depending on context “suffixes” means - “suffixes (including infixes)” or “non-infix suffixes”. Here it - means the former. See *note Suffix Specifications::. - - SUFFIX may also be a group in the same form as expected by - ‘transient-define-prefix’. See *note Group Specifications::. - - • LOC is a command, a key vector, a key description (a string as - returned by ‘key-description’), or a list specifying coordinates - (the last element may also be a command or key). For example ‘(1 0 - -1)’ identifies the last suffix (‘-1’) of the first subgroup (‘0’) - of the second group (‘1’). - - If LOC is a list of coordinates, then it can be used to identify a - group, not just an individual suffix command. - - The function ‘transient-get-suffix’ can be useful to determine - whether a certain coordination list identifies the suffix or group - that you expect it to identify. In hairy cases it may be necessary - to look at the definition of the transient prefix command. - - These functions operate on the information stored in the -‘transient--layout’ property of the PREFIX symbol. Suffix entries in -that tree are not objects but have the form ‘(LEVEL CLASS PLIST)’, where -PLIST should set at least ‘:key’, ‘:description’ and ‘:command’. - - -- Function: transient-insert-suffix prefix loc suffix &optional - keep-other - -- Function: transient-append-suffix prefix loc suffix &optional - keep-other - These functions insert the suffix or group SUFFIX into PREFIX - before or after LOC. - - Conceptually adding a binding to a transient prefix is similar to - adding a binding to a keymap, but this is complicated by the fact - that multiple suffix commands can be bound to the same key, - provided they are never active at the same time, see *note - Predicate Slots::. - - Unfortunately both false-positives and false-negatives are - possible. To deal with the former use non-‘nil’ KEEP-OTHER. To - deal with the latter remove the conflicting binding explicitly. - - -- Function: transient-replace-suffix prefix loc suffix - This function replaces the suffix or group at LOC in PREFIX with - suffix or group SUFFIX. - - -- Function: transient-remove-suffix prefix loc - This function removes the suffix or group at LOC in PREFIX. - - -- Function: transient-get-suffix prefix loc - This function returns the suffix or group at LOC in PREFIX. The - returned value has the form mentioned above. - - -- Function: transient-suffix-put prefix loc prop value - This function edits the suffix or group at LOC in PREFIX, by - setting the PROP of its plist to VALUE. - - Most of these functions do not signal an error if they cannot perform -the requested modification. The functions that insert new suffixes show -a warning if LOC cannot be found in PREFIX without signaling an error. -The reason for doing it like this is that establishing a key binding -(and that is what we essentially are trying to do here) should not -prevent the rest of the configuration from loading. Among these -functions only ‘transient-get-suffix’ and ‘transient-suffix-put’ may -signal an error. - - -File: transient.info, Node: Defining New Commands, Next: Classes and Methods, Prev: Modifying Existing Transients, Up: Top - -4 Defining New Commands -*********************** - -* Menu: - -* Technical Introduction:: -* Defining Transients:: -* Binding Suffix and Infix Commands:: -* Defining Suffix and Infix Commands:: -* Using Infix Arguments:: -* Transient State:: - - -File: transient.info, Node: Technical Introduction, Next: Defining Transients, Up: Defining New Commands - -4.1 Technical Introduction -========================== - -Taking inspiration from prefix keys and prefix arguments, Transient -implements a similar abstraction involving a prefix command, infix -arguments and suffix commands. - - When the user calls a transient prefix command, a transient -(temporary) keymap is activated, which binds the transient’s infix and -suffix commands, and functions that control the transient state are -added to ‘pre-command-hook’ and ‘post-command-hook’. The available -suffix and infix commands and their state are shown in a popup buffer -until the transient state is exited by invoking a suffix command. - - Calling an infix command causes its value to be changed. How that is -done depends on the type of the infix command. The simplest case is an -infix command that represents a command-line argument that does not take -a value. Invoking such an infix command causes the switch to be toggled -on or off. More complex infix commands may read a value from the user, -using the minibuffer. - - Calling a suffix command usually causes the transient to be exited; -the transient keymaps and hook functions are removed, the popup buffer -no longer shows information about the (no longer bound) suffix commands, -the values of some public global variables are set, while some internal -global variables are unset, and finally the command is actually called. -Suffix commands can also be configured to not exit the transient. - - A suffix command can, but does not have to, use the infix arguments -in much the same way any command can choose to use or ignore the prefix -arguments. For a suffix command that was invoked from a transient, the -variable ‘transient-current-suffixes’ and the function ‘transient-args’ -serve about the same purpose as the variables ‘prefix-arg’ and -‘current-prefix-arg’ do for any command that was called after the prefix -arguments have been set using a command such as ‘universal-argument’. - - Transient can be used to implement simple “command dispatchers”. The -main benefit then is that the user can see all the available commands in -a popup buffer, which can be thought of as a “menus”. That is useful by -itself because it frees the user from having to remember all the keys -that are valid after a certain prefix key or command. Magit’s -‘magit-dispatch’ (on ‘C-x M-g’) command is an example of using Transient -to merely implement a command dispatcher. - - In addition to that, Transient also allows users to interactively -pass arguments to commands. These arguments can be much more complex -than what is reasonable when using prefix arguments. There is a limit -to how many aspects of a command can be controlled using prefix -arguments. Furthermore, what a certain prefix argument means for -different commands can be completely different, and users have to read -documentation to learn and then commit to memory what a certain prefix -argument means to a certain command. - - Transient suffix commands, on the other hand, can accept dozens of -different arguments without the user having to remember anything. When -using Transient, one can call a command with arguments that are just as -complex as when calling the same function non-interactively from Lisp. - - Invoking a transient suffix command with arguments is similar to -invoking a command in a shell with command-line completion and history -enabled. One benefit of the Transient interface is that it remembers -history not only on a global level (“this command was invoked using -these arguments, and previously it was invoked using those other -arguments”), but also remembers the values of individual arguments -independently. See *note Using History::. - - After a transient prefix command is invoked, ‘C-h KEY’ can be used to -show the documentation for the infix or suffix command that ‘KEY’ is -bound to (see *note Getting Help for Suffix Commands::), and infixes and -suffixes can be removed from the transient using ‘C-x l KEY’. Infixes -and suffixes that are disabled by default can be enabled the same way. -See *note Enabling and Disabling Suffixes::. - - Transient ships with support for a few different types of specialized -infix commands. A command that sets a command line option, for example, -has different needs than a command that merely toggles a boolean flag. -Additionally, Transient provides abstractions for defining new types, -which the author of Transient did not anticipate (or didn’t get around -to implementing yet). - - Note that suffix commands also support regular prefix arguments. A -suffix command may even be called with both infix and prefix arguments -at the same time. If you invoke a command as a suffix of a transient -prefix command, but also want to pass prefix arguments to it, then first -invoke the prefix command, and only after doing that invoke the prefix -arguments, before finally invoking the suffix command. If you instead -began by providing the prefix arguments, then those would apply to the -prefix command, not the suffix command. Likewise, if you want to change -infix arguments before invoking a suffix command with prefix arguments, -then change the infix arguments before invoking the prefix arguments. -In other words, regular prefix arguments always apply to the next -command, and since transient prefix, infix and suffix commands are just -regular commands, the same applies to them. (Regular prefix keys behave -differently because they are not commands at all, instead they are just -incomplete key sequences, and those cannot be interrupted with prefix -commands.) - - -File: transient.info, Node: Defining Transients, Next: Binding Suffix and Infix Commands, Prev: Technical Introduction, Up: Defining New Commands - -4.2 Defining Transients -======================= - -A transient consists of a prefix command and at least one suffix -command, though usually a transient has several infix and suffix -commands. The below macro defines the transient prefix command *and* -binds the transient’s infix and suffix commands. In other words, it -defines the complete transient, not just the transient prefix command -that is used to invoke that transient. - - -- Macro: transient-define-prefix name arglist [docstring] [keyword - value]... group... [body...] - This macro defines NAME as a transient prefix command and binds the - transient’s infix and suffix commands. - - ARGLIST are the arguments that the prefix command takes. DOCSTRING - is the documentation string and is optional. - - These arguments can optionally be followed by keyword-value pairs. - Each key has to be a keyword symbol, either ‘:class’ or a keyword - argument supported by the constructor of that class. The - ‘transient-prefix’ class is used if the class is not specified - explicitly. - - GROUPs add key bindings for infix and suffix commands and specify - how these bindings are presented in the popup buffer. At least one - GROUP has to be specified. See *note Binding Suffix and Infix - Commands::. - - The BODY is optional. If it is omitted, then ARGLIST is ignored - and the function definition becomes: - - (lambda () - (interactive) - (transient-setup 'NAME)) - - If BODY is specified, then it must begin with an ‘interactive’ form - that matches ARGLIST, and it must call ‘transient-setup’. It may, - however, call that function only when some condition is satisfied. - - All transients have a (possibly ‘nil’) value, which is exported - when suffix commands are called, so that they can consume that - value. For some transients it might be necessary to have a sort of - secondary value, called a “scope”. Such a scope would usually be - set in the command’s ‘interactive’ form and has to be passed to the - setup function: - - (transient-setup 'NAME nil nil :scope SCOPE) - - For example, the scope of the ‘magit-branch-configure’ transient is - the branch whose variables are being configured. - - -File: transient.info, Node: Binding Suffix and Infix Commands, Next: Defining Suffix and Infix Commands, Prev: Defining Transients, Up: Defining New Commands - -4.3 Binding Suffix and Infix Commands -===================================== - -The macro ‘transient-define-prefix’ is used to define a transient. This -defines the actual transient prefix command (see *note Defining -Transients::) and adds the transient’s infix and suffix bindings, as -described below. - - Users and third-party packages can add additional bindings using -functions such as ‘transient-insert-suffix’ (see *note Modifying -Existing Transients::). These functions take a “suffix specification” -as one of their arguments, which has the same form as the specifications -used in ‘transient-define-prefix’. - -* Menu: - -* Group Specifications:: -* Suffix Specifications:: - - -File: transient.info, Node: Group Specifications, Next: Suffix Specifications, Up: Binding Suffix and Infix Commands - -4.3.1 Group Specifications --------------------------- - -The suffix and infix commands of a transient are organized in groups. -The grouping controls how the descriptions of the suffixes are outlined -visually but also makes it possible to set certain properties for a set -of suffixes. - - Several group classes exist, some of which organize suffixes in -subgroups. In most cases the class does not have to be specified -explicitly, but see *note Group Classes::. - - Groups are specified in the call to ‘transient-define-prefix’, using -vectors. Because groups are represented using vectors, we cannot use -square brackets to indicate an optional element and instead use curly -brackets to do the latter. - - Group specifications then have this form: - - [{LEVEL} {DESCRIPTION} {KEYWORD VALUE}... ELEMENT...] - - The LEVEL is optional and defaults to 4. See *note Enabling and -Disabling Suffixes::. - - The DESCRIPTION is optional. If present, it is used as the heading -of the group. - - The KEYWORD-VALUE pairs are optional. Each keyword has to be a -keyword symbol, either ‘:class’ or a keyword argument supported by the -constructor of that class. - - • One of these keywords, ‘:description’, is equivalent to specifying - DESCRIPTION at the very beginning of the vector. The - recommendation is to use ‘:description’ if some other keyword is - also used, for consistency, or DESCRIPTION otherwise, because it - looks better. - - • Likewise ‘:level’ is equivalent to LEVEL. - - • Other important keywords include the ‘:if...’ keywords. These - keywords control whether the group is available in a certain - situation. - - For example, one group of the ‘magit-rebase’ transient uses ‘:if - magit-rebase-in-progress-p’, which contains the suffixes that are - useful while rebase is already in progress; and another that uses - ‘:if-not magit-rebase-in-progress-p’, which contains the suffixes - that initiate a rebase. - - These predicates can also be used on individual suffixes and are - only documented once, see *note Predicate Slots::. - - • The value of ‘:hide’, if non-‘nil’, is a predicate that controls - whether the group is hidden by default. The key bindings for - suffixes of a hidden group should all use the same prefix key. - Pressing that prefix key should temporarily show the group and its - suffixes, which assumes that a predicate like this is used: - - (lambda () - (eq (car transient--redisplay-key) - ?\C-c)) ; the prefix key shared by all bindings - - • The value of ‘:setup-children’, if non-‘nil’, is a function that - takes one argument, a potentially list of children, and must return - a list of children or an empty list. This can either be used to - somehow transform the group’s children that were defined the normal - way, or to dynamically create the children from scratch. - - The returned children must have the same form as stored in the - prefix’s ‘transient--layout’ property, but it is often more - convenient to use the same form as understood by - ‘transient-define-prefix’, described below. If you use the latter - approach, you can use the ‘transient-parse-suffixes’ and - ‘transient-parse-suffix’ functions to transform them from the - convenient to the expected form. Depending on the used group - class, ‘transient-parse-suffixes’’s SUFFIXES must be a list of - group vectors (for ‘transient-columns’) or a list of suffix lists - (for all other group classes). - - If you explicitly specify children and then transform them using - ‘:setup-children’, then the class of the group is determined as - usual, based on explicitly specified children. - - If you do not explicitly specify children and thus rely solely on - ‘:setup-children’, then you must specify the class using ‘:class’. - For backward compatibility, if you fail to do so, - ‘transient-column’ is used and a warning is displayed. This - warning will eventually be replaced with an error. - - (transient-define-prefix my-finder-by-keyword () - "Select a keyword and list matching packages." - ;; The real `finder-by-keyword' is more convenient - ;; of course, but that is not the point here. - [:class transient-columns - :setup-children - (lambda (_) - (transient-parse-suffixes - 'my-finder-by-keyword - (let ((char (1- ?A))) - (mapcar ; a list ... - (lambda (partition) - (vconcat ; of group vectors ... - (mapcar (lambda (elt) - (let ((keyword (symbol-name (car elt)))) - ; ... where each suffix is a list - (list (format "%c" (cl-incf char)) - keyword - (lambda () - (interactive) - (finder-list-matches keyword))))) - partition))) - (seq-partition finder-known-keywords 7)))))]) - - • The boolean ‘:pad-keys’ argument controls whether keys of all - suffixes contained in a group are right padded, effectively - aligning the descriptions. - - The ELEMENTs are either all subgroups, or all suffixes and strings. -(At least currently no group type exists that would allow mixing -subgroups with commands at the same level, though in principle there is -nothing that prevents that.) - - If the ELEMENTs are not subgroups, then they can be a mixture of -lists, which specify commands, and strings. Strings are inserted -verbatim into the buffer. The empty string can be used to insert gaps -between suffixes, which is particularly useful if the suffixes are -outlined as a table. - - Inside group specifications, including inside contained suffix -specifications, nothing has to be quoted and quoting anyway is invalid. -The value following a keyword, can be explicitly unquoted using ‘,’. -This feature is experimental and should be avoided. - - The form of suffix specifications is documented in the next node. - - -File: transient.info, Node: Suffix Specifications, Prev: Group Specifications, Up: Binding Suffix and Infix Commands - -4.3.2 Suffix Specifications ---------------------------- - -A transient’s suffix and infix commands are bound when the transient -prefix command is defined using ‘transient-define-prefix’, see *note -Defining Transients::. The commands are organized into groups, see -*note Group Specifications::. Here we describe the form used to bind an -individual suffix command. - - The same form is also used when later binding additional commands -using functions such as ‘transient-insert-suffix’, see *note Modifying -Existing Transients::. - - Note that an infix is a special kind of suffix. Depending on context -“suffixes” means “suffixes (including infixes)” or “non-infix suffixes”. -Here it means the former. - - Suffix specifications have this form: - - ([LEVEL] [KEY [DESCRIPTION]] COMMAND|ARGUMENT [KEYWORD VALUE]...) - - LEVEL, KEY and DESCRIPTION can also be specified using the KEYWORDs -‘:level’, ‘:key’ and ‘:description’. If the object that is associated -with COMMAND sets these properties, then they do not have to be -specified here. You can however specify them here anyway, possibly -overriding the object’s values just for the binding inside this -transient. - - • LEVEL is the suffix level, an integer between 1 and 7. See *note - Enabling and Disabling Suffixes::. - - • KEY is the key binding, either a vector or key description string. - - • DESCRIPTION is the description, either a string or a function that - takes zero or one arguments (the suffix object) and returns a - string. The function should be a lambda expression to avoid - ambiguity. In some cases a symbol that is bound as a function - would also work but to be safe you should use ‘:description’ in - that case. - - The next element is either a command or an argument. This is the -only argument that is mandatory in all cases. - - • COMMAND should be a symbol that is bound as a function, which has - to be defined or at least autoloaded as a command by the time the - containing prefix command is invoked. - - Any command will do; it does not need to have an object associated - with it (as would be the case if ‘transient-define-suffix’ or - ‘transient-define-infix’ were used to define it). - - COMMAND can also be a ‘lambda’ expression. - - As mentioned above, the object that is associated with a command - can be used to set the default for certain values that otherwise - have to be set in the suffix specification. Therefore if there is - no object, then you have to make sure to specify the KEY and the - DESCRIPTION. - - As a special case, if you want to add a command that might be - neither defined nor autoloaded, you can use a workaround like: - - (transient-insert-suffix 'some-prefix "k" - '("!" "Ceci n'est pas une commande" no-command - :if (lambda () (featurep 'no-library)))) - - Instead of ‘featurep’ you could also use ‘require’ with a non-‘nil’ - value for NOERROR. - - • The mandatory argument can also be a command-line argument, a - string. In that case an anonymous command is defined and bound. - - Instead of a string, this can also be a list of two strings, in - which case the first string is used as the short argument (which - can also be specified using ‘:shortarg’) and the second as the long - argument (which can also be specified using ‘:argument’). - - Only the long argument is displayed in the popup buffer. See - ‘transient-detect-key-conflicts’ for how the short argument may be - used. - - Unless the class is specified explicitly, the appropriate class is - guessed based on the long argument. If the argument ends with ‘=’ - (e.g., ‘--format=’) then ‘transient-option’ is used, otherwise - ‘transient-switch’. - - Finally, details can be specified using optional KEYWORD-VALUE pairs. -Each keyword has to be a keyword symbol, either ‘:class’ or a keyword -argument supported by the constructor of that class. See *note Suffix -Slots::. - - -File: transient.info, Node: Defining Suffix and Infix Commands, Next: Using Infix Arguments, Prev: Binding Suffix and Infix Commands, Up: Defining New Commands - -4.4 Defining Suffix and Infix Commands -====================================== - -Note that an infix is a special kind of suffix. Depending on context -“suffixes” means “suffixes (including infixes)” or “non-infix suffixes”. - - -- Macro: transient-define-suffix name arglist [docstring] [keyword - value]... body... - This macro defines NAME as a transient suffix command. - - ARGLIST are the arguments that the command takes. DOCSTRING is the - documentation string and is optional. - - These arguments can optionally be followed by keyword-value pairs. - Each keyword has to be a keyword symbol, either ‘:class’ or a - keyword argument supported by the constructor of that class. The - ‘transient-suffix’ class is used if the class is not specified - explicitly. - - The BODY must begin with an ‘interactive’ form that matches - ARGLIST. The infix arguments are usually accessed by using - ‘transient-args’ inside ‘interactive’. - - -- Macro: transient-define-infix name arglist [docstring] [keyword - value]... - This macro defines NAME as a transient infix command. - - ARGLIST is always ignored (but mandatory never-the-less) and - reserved for future use. DOCSTRING is the documentation string and - is optional. - - At least one key-value pair is required. All transient infix - commands are ‘equal’ to each other (but not ‘eq’). It is - meaningless to define an infix command, without providing at least - one keyword argument (usually ‘:argument’ or ‘:variable’, depending - on the class). The suffix class defaults to ‘transient-switch’ and - can be set using the ‘:class’ keyword. - - The function definition is always: - - (lambda () - (interactive) - (let ((obj (transient-suffix-object))) - (transient-infix-set obj (transient-infix-read obj))) - (transient--show)) - - ‘transient-infix-read’ and ‘transient-infix-set’ are generic - functions. Different infix commands behave differently because the - concrete methods are different for different infix command classes. - In rare cases the above command function might not be suitable, - even if you define your own infix command class. In that case you - have to use ‘transient-define-suffix’ to define the infix command - and use ‘t’ as the value of the ‘:transient’ keyword. - - -- Macro: transient-define-argument name arglist [docstring] [keyword - value]... - This macro defines NAME as a transient infix command. - - This is an alias for ‘transient-define-infix’. Only use this alias - to define an infix command that actually sets an infix argument. - To define an infix command that, for example, sets a variable, use - ‘transient-define-infix’ instead. - - -File: transient.info, Node: Using Infix Arguments, Next: Transient State, Prev: Defining Suffix and Infix Commands, Up: Defining New Commands - -4.5 Using Infix Arguments -========================= - -The functions and the variables described below allow suffix commands to -access the value of the transient from which they were invoked; which is -the value of its infix arguments. These variables are set when the user -invokes a suffix command that exits the transient, but before actually -calling the command. - - When returning to the command-loop after calling the suffix command, -the arguments are reset to ‘nil’ (which causes the function to return -‘nil’ too). - - Like for Emacs’s prefix arguments, it is advisable, but not -mandatory, to access the infix arguments inside the command’s -‘interactive’ form. The preferred way of doing that is to call the -‘transient-args’ function, which for infix arguments serves about the -same purpose as ‘prefix-arg’ serves for prefix arguments. - - -- Function: transient-args prefix - This function returns the value of the transient prefix command - PREFIX. - - If the current command was invoked from the transient prefix - command PREFIX, then it returns the active infix arguments. If the - current command was not invoked from PREFIX, then it returns the - set, saved or default value for PREFIX. - - -- Function: transient-arg-value arg args - This function return the value of ARG as it appears in ARGS. - - For a switch a boolean is returned. For an option the value is - returned as a string, using the empty string for the empty value, - or ‘nil’ if the option does not appear in ARGS. - - -- Function: transient-suffixes prefix - This function returns the suffixes of the transient prefix command - PREFIX. This is a list of objects. This function should only be - used if you need the objects (as opposed to just their values) and - if the current command is not being invoked from PREFIX. - - -- Variable: transient-current-suffixes - The suffixes of the transient from which this suffix command was - invoked. This is a list of objects. Usually it is sufficient to - instead use the function ‘transient-args’, which returns a list of - values. In complex cases it might be necessary to use this - variable instead, i.e., if you need access to information beside - the value. - - -- Variable: transient-current-command - The transient from which this suffix command was invoked. The - returned value is a symbol, the transient prefix command. - - -- Variable: transient-current-prefix - The transient from which this suffix command was invoked. The - returned value is a ‘transient-prefix’ object, which holds - information associated with the transient prefix command. - - -- Function: transient-active-prefix - This function returns the active transient object. Return ‘nil’ if - there is no active transient, if the transient buffer isn’t shown, - and while the active transient is suspended (e.g., while the - minibuffer is in use). - - Unlike ‘transient-current-prefix’, which is only ever non-‘nil’ in - code that is run directly by a command that is invoked while a - transient is current, this function is also suitable for use in - asynchronous code, such as timers and callbacks (this function’s - main use-case). - - If optional PREFIXES is non-‘nil’, it must be a prefix command - symbol or a list of symbols, in which case the active transient - object is only returned if it matches one of the PREFIXES. - - -File: transient.info, Node: Transient State, Prev: Using Infix Arguments, Up: Defining New Commands - -4.6 Transient State -=================== - -Invoking a transient prefix command “activates” the respective -transient, i.e., it puts a transient keymap into effect, which binds the -transient’s infix and suffix commands. - - The default behavior while a transient is active is as follows: - - • Invoking an infix command does not affect the transient state; the - transient remains active. - - • Invoking a (non-infix) suffix command “deactivates” the transient - state by removing the transient keymap and performing some - additional cleanup. - - • Invoking a command that is bound in a keymap other than the - transient keymap is disallowed and trying to do so results in a - warning. This does not “deactivate” the transient. - - The behavior can be changed for all suffixes of a particular prefix -and/or for individual suffixes. The values should nearly always be -booleans, but certain functions, called “pre-commands”, can also be -used. These functions are named ‘transient--do-VERB’, and the symbol -‘VERB’ can be used as a shorthand. - - A boolean is interpreted as answering the question "does the -transient stay active, when this command is invoked?" ‘t’ means that -the transient stays active, while ‘nil’ means that invoking the command -exits the transient. - - Note that when the suffix is a “sub-prefix”, invoking that command -always activates that sub-prefix, causing the outer prefix to no longer -be active and displayed. Here ‘t’ means that when you exit the inner -prefix, then the outer prefix becomes active again, while ‘nil’ means -that all outer prefixes are exited at once. - - • The behavior for non-suffixes can be set for a particular prefix, - by the prefix’s ‘transient-non-suffix’ slot to a boolean, a - suitable pre-command function, or a shorthand for such a function. - See *note Pre-commands for Non-Suffixes::. - - • The common behavior for the suffixes of a particular prefix can be - set using the prefix’s ‘transient-suffixes’ slot. - - The value specified in this slot does *not* affect infixes. - Because it affects both regular suffixes as well as sub-prefixes, - which have different needs, it is best to avoid explicitly - specifying a function. - - • The behavior of an individual suffix can be changed using its - ‘transient’ slot. While it is usually best to use a boolean, for - this slot it can occasionally make sense to specify a function - explicitly. - - Note that this slot can be set when defining a suffix command using - ‘transient-define-suffix’ and/or in the definition of the prefix. - If set in both places, then the latter takes precedence, as usual. - - The available pre-command functions are documented in the following -sub-sections. They are called by ‘transient--pre-command’, a function -on ‘pre-command-hook’, and the value that they return determines whether -the transient is exited. To do so the value of one of the constants -‘transient--exit’ or ‘transient--stay’ is used (that way we don’t have -to remember if ‘t’ means “exit” or “stay”). - - Additionally, these functions may change the value of ‘this-command’ -(which explains why they have to be called using ‘pre-command-hook’), -call ‘transient-export’, ‘transient--stack-zap’ or -‘transient--stack-push’; and set the values of ‘transient--exitp’, -‘transient--helpp’ or ‘transient--editp’. - - For completeness sake, some notes about complications: - - • The transient-ness of certain built-in suffix commands is specified - using ‘transient-predicate-map’. This is a special keymap, which - binds commands to pre-commands (as opposed to keys to commands) and - takes precedence over the prefix’s ‘transient-suffix’ slot, but not - the suffix’s ‘transient’ slot. - - • While a sub-prefix is active we nearly always want ‘C-g’ to take - the user back to the “super-prefix”, even when the other suffixes - don’t do that. However, in rare cases this may not be desirable, - and that makes the following complication necessary: - - For ‘transient-suffix’ objects the ‘transient’ slot is unbound. We - can ignore that for the most part because ‘nil’ and the slot being - unbound are treated as equivalent, and mean “do exit”. That isn’t - actually true for suffixes that are sub-prefixes though. For such - suffixes unbound means “do exit but allow going back”, which is the - default, while ‘nil’ means “do exit permanently”, which requires - that slot to be explicitly set to that value. - -Pre-commands for Infixes ------------------------- - -The default for infixes is ‘transient--do-stay’. This is also the only -function that makes sense for infixes, which is why this predicate is -used even if the value of the prefix’s ‘transient-suffix’ slot is ‘t’. -In extremely rare cases, one might want to use something else, which can -be done by setting the infix’s ‘transient’ slot directly. - - -- Function: transient--do-stay - Call the command without exporting variables and stay transient. - -Pre-commands for Suffixes -------------------------- - -By default, invoking a suffix causes the transient to be exited. - - The behavior for an individual suffix command can be changed by -setting its ‘transient’ slot to a boolean (which is highly recommended), -or to one of the following pre-commands. - - -- Function: transient--do-exit - Call the command after exporting variables and exit the transient. - - -- Function: transient--do-return - Call the command after exporting variables and return to the parent - prefix. If there is no parent prefix, then call - ‘transient--do-exit’. - - -- Function: transient--do-call - Call the command after exporting variables and stay transient. - - The following pre-commands are only suitable for sub-prefixes. It is -not necessary to explicitly use these predicates because the correct -predicate is automatically picked based on the value of the ‘transient’ -slot for the sub-prefix itself. - - -- Function: transient--do-recurse - Call the transient prefix command, preparing for return to active - transient. - - Whether we actually return to the parent transient is ultimately - under the control of each invoked suffix. The difference between - this pre-command and ‘transient--do-stack’ is that it changes the - value of the ‘transient-suffix’ slot to ‘t’. - - If there is no parent transient, then only call this command and - skip the second step. - - -- Function: transient--do-stack - Call the transient prefix command, stacking the active transient. - Push the active transient to the transient stack. - - Unless ‘transient--do-recurse’ is explicitly used, this pre-command - is automatically used for suffixes that are prefixes themselves, - i.e., for sub-prefixes. - - -- Function: transient--do-replace - Call the transient prefix command, replacing the active transient. - Do not push the active transient to the transient stack. - - Unless ‘transient--do-recurse’ is explicitly used, this pre-command - is automatically used for suffixes that are prefixes themselves, - i.e., for sub-prefixes. - - -- Function: transient--do-suspend - Suspend the active transient, saving the transient stack. - - This is used by the command ‘transient-suspend’ and optionally also - by “external events” such as ‘handle-switch-frame’. Such bindings - should be added to ‘transient-predicate-map’. - -Pre-commands for Non-Suffixes ------------------------------ - -By default, non-suffixes (commands that are bound in other keymaps -beside the transient keymap) cannot be invoked. Trying to invoke such a -command results in a warning and the transient stays active. - - If you want a different behavior, then set the ‘transient-non-suffix’ -slot of the transient prefix command. The value should be a boolean, -answering the question, "is it allowed to invoke non-suffix commands?, a -pre-command function, or a shorthand for such a function. - - If the value is ‘t’, then non-suffixes can be invoked, when it is -‘nil’ (the default) then they cannot be invoked. - - The only other recommended value is ‘leave’. If that is used, then -non-suffixes can be invoked, but if one is invoked, then that exits the -transient. - - -- Function: transient--do-warn - Call ‘transient-undefined’ and stay transient. - - -- Function: transient--do-stay - Call the command without exporting variables and stay transient. - - -- Function: transient--do-leave - Call the command without exporting variables and exit the - transient. - -Special Pre-Commands --------------------- - - -- Function: transient--do-quit-one - If active, quit help or edit mode, else exit the active transient. - - This is used when the user pressed ‘C-g’. - - -- Function: transient--do-quit-all - Exit all transients without saving the transient stack. - - This is used when the user pressed ‘C-q’. - - -- Function: transient--do-suspend - Suspend the active transient, saving the transient stack. - - This is used when the user pressed ‘C-z’. - - -File: transient.info, Node: Classes and Methods, Next: FAQ, Prev: Defining New Commands, Up: Top - -5 Classes and Methods -********************* - -Transient uses classes and generic functions to make it possible to -define new types of suffix commands that are similar to existing types, -but behave differently in some aspects. It does the same for groups and -prefix commands, though at least for prefix commands that *currently* -appears to be less important. - - Every prefix, infix and suffix command is associated with an object, -which holds information that controls certain aspects of its behavior. -This happens in two ways. - - • Associating a command with a certain class gives the command a - type. This makes it possible to use generic functions to do - certain things that have to be done differently depending on what - type of command it acts on. - - That in turn makes it possible for third-parties to add new types - without having to convince the maintainer of Transient that that - new type is important enough to justify adding a special case to a - dozen or so functions. - - • Associating a command with an object makes it possible to easily - store information that is specific to that particular command. - - Two commands may have the same type, but obviously their key - bindings and descriptions still have to be different, for example. - - The values of some slots are functions. The ‘reader’ slot for - example holds a function that is used to read a new value for an - infix command. The values of such slots are regular functions. - - Generic functions are used when a function should do something - different based on the type of the command, i.e., when all commands - of a certain type should behave the same way but different from the - behavior for other types. Object slots that hold a regular - function as value are used when the task that they perform is - likely to differ even between different commands of the same type. - -* Menu: - -* Group Classes:: -* Group Methods:: -* Prefix Classes:: -* Suffix Classes:: -* Suffix Methods:: -* Prefix Slots:: -* Suffix Slots:: -* Predicate Slots:: - - -File: transient.info, Node: Group Classes, Next: Group Methods, Up: Classes and Methods - -5.1 Group Classes -================= - -The type of a group can be specified using the ‘:class’ property at the -beginning of the class specification, e.g., ‘[:class transient-columns -...]’ in a call to ‘transient-define-prefix’. - - • The abstract ‘transient-child’ class is the base class of both - ‘transient-group’ (and therefore all groups) as well as of - ‘transient-suffix’ (and therefore all suffix and infix commands). - - This class exists because the elements (or “children”) of certain - groups can be other groups instead of suffix and infix commands. - - • The abstract ‘transient-group’ class is the superclass of all other - group classes. - - • The ‘transient-column’ class is the simplest group. - - This is the default “flat” group. If the class is not specified - explicitly and the first element is not a vector (i.e., not a - group), then this class is used. - - This class displays each element on a separate line. - - • The ‘transient-row’ class displays all elements on a single line. - - • The ‘transient-columns’ class displays commands organized in - columns. - - Direct elements have to be groups whose elements have to be - commands or strings. Each subgroup represents a column. This - class takes care of inserting the subgroups’ elements. - - This is the default “nested” group. If the class is not specified - explicitly and the first element is a vector (i.e., a group), then - this class is used. - - • The ‘transient-subgroups’ class wraps other groups. - - Direct elements have to be groups whose elements have to be - commands or strings. This group inserts an empty line between - subgroups. The subgroups themselves are responsible for displaying - their elements. - - -File: transient.info, Node: Group Methods, Next: Prefix Classes, Prev: Group Classes, Up: Classes and Methods - -5.2 Group Methods -================= - - -- Function: transient-setup-children group children - This generic function can be used to setup the children or a group. - - The default implementation usually just returns the children - unchanged, but if the ‘setup-children’ slot of GROUP is non-‘nil’, - then it calls that function with CHILDREN as the only argument and - returns the value. - - The children are given as a (potentially empty) list consisting of - either group or suffix specifications. These functions can make - arbitrary changes to the children including constructing new - children from scratch. - - -- Function: transient--insert-group group - This generic function formats the group and its elements and - inserts the result into the current buffer, which is a temporary - buffer. The contents of that buffer are later inserted into the - popup buffer. - - Functions that are called by this function may need to operate in - the buffer from which the transient was called. To do so they can - temporarily make the ‘transient--source-buffer’ the current buffer. - - -File: transient.info, Node: Prefix Classes, Next: Suffix Classes, Prev: Group Methods, Up: Classes and Methods - -5.3 Prefix Classes -================== - -Currently the ‘transient-prefix’ class is being used for all prefix -commands and there is only a single generic function that can be -specialized based on the class of a prefix command. - - -- Function: transient--history-init obj - This generic function is called while setting up the transient and - is responsible for initializing the ‘history’ slot. This is the - transient-wide history; many individual infixes also have a history - of their own. - - The default (and currently only) method extracts the value from the - global variable ‘transient-history’. - - A transient prefix command’s object is stored in the -‘transient--prefix’ property of the command symbol. While a transient -is active, a clone of that object is stored in the variable -‘transient--prefix’. A clone is used because some changes that are made -to the active transient’s object should not affect later invocations. - - -File: transient.info, Node: Suffix Classes, Next: Suffix Methods, Prev: Prefix Classes, Up: Classes and Methods - -5.4 Suffix Classes -================== - - • All suffix and infix classes derive from ‘transient-suffix’, which - in turn derives from ‘transient-child’, from which - ‘transient-group’ also derives (see *note Group Classes::). - - • All infix classes derive from the abstract ‘transient-infix’ class, - which in turn derives from the ‘transient-suffix’ class. - - Infixes are a special type of suffixes. The primary difference is - that infixes always use the ‘transient--do-stay’ pre-command, while - non-infix suffixes use a variety of pre-commands (see *note - Transient State::). Doing that is most easily achieved by using - this class, though theoretically it would be possible to define an - infix class that does not do so. If you do that then you get to - implement many methods. - - Also, infixes and non-infix suffixes are usually defined using - different macros (see *note Defining Suffix and Infix Commands::). - - • Classes used for infix commands that represent arguments should be - derived from the abstract ‘transient-argument’ class. - - • The ‘transient-switch’ class (or a derived class) is used for infix - arguments that represent command-line switches (arguments that do - not take a value). - - • The ‘transient-option’ class (or a derived class) is used for infix - arguments that represent command-line options (arguments that do - take a value). - - • The ‘transient-switches’ class can be used for a set of mutually - exclusive command-line switches. - - • The ‘transient-files’ class can be used for a ‘--’ argument that - indicates that all remaining arguments are files. - - • Classes used for infix commands that represent variables should - derived from the abstract ‘transient-variable’ class. - - • The ‘transient-information’ class is special in that suffixes that - use this class are not associated with a command and thus also not - with any key binding. Such suffixes are only used to display - arbitrary information, and that anywhere a suffix can appear. - Display-only suffix specifications take this form: - - ([LEVEL] :info DESCRIPTION [KEYWORD VALUE]...) - - The ‘:info’ keyword argument replaces the ‘:description’ keyword - used for other suffix classes. Other keyword arguments that you - might want to set, include ‘:face’, predicate keywords (such as - ‘:if’), and ‘:format’. By default the value of ‘:format’ includes - ‘%k’, which for this class is replaced with the empty string or - spaces, if keys are being padded in the containing group. - - Magit defines additional classes, which can serve as examples for the -fancy things you can do without modifying Transient. Some of these -classes will likely get generalized and added to Transient. For now -they are very much subject to change and not documented. - - -File: transient.info, Node: Suffix Methods, Next: Prefix Slots, Prev: Suffix Classes, Up: Classes and Methods - -5.5 Suffix Methods -================== - -To get information about the methods implementing these generic -functions use ‘describe-function’. - -* Menu: - -* Suffix Value Methods:: -* Suffix Format Methods:: - - -File: transient.info, Node: Suffix Value Methods, Next: Suffix Format Methods, Up: Suffix Methods - -5.5.1 Suffix Value Methods --------------------------- - - -- Function: transient-init-value obj - This generic function sets the initial value of the object OBJ. - - This function is called for all suffix commands, but unless a - concrete method is implemented this falls through to the default - implementation, which is a noop. In other words this usually only - does something for infix commands, but note that this is not - implemented for the abstract class ‘transient-infix’, so if your - class derives from that directly, then you must implement a method. - - -- Function: transient-infix-read obj - This generic function determines the new value of the infix object - OBJ. - - This function merely determines the value; ‘transient-infix-set’ is - used to actually store the new value in the object. - - For most infix classes this is done by reading a value from the - user using the reader specified by the ‘reader’ slot (using the - ‘transient-infix-value’ method described below). - - For some infix classes the value is changed without reading - anything in the minibuffer, i.e., the mere act of invoking the - infix command determines what the new value should be, based on the - previous value. - - -- Function: transient-prompt obj - This generic function returns the prompt to be used to read infix - object OBJ’s value. - - -- Function: transient-infix-set obj value - This generic function sets the value of infix object OBJ to VALUE. - - -- Function: transient-infix-value obj - This generic function returns the value of the suffix object OBJ. - - This function is called by ‘transient-args’ (which see), meaning - this function is how the value of a transient is determined so that - the invoked suffix command can use it. - - Currently most values are strings, but that is not set in stone. - ‘nil’ is not a value, it means “no value”. - - Usually only infixes have a value, but see the method for - ‘transient-suffix’. - - -- Function: transient-init-scope obj - This generic function sets the scope of the suffix object OBJ. - - The scope is actually a property of the transient prefix, not of - individual suffixes. However it is possible to invoke a suffix - command directly instead of from a transient. In that case, if the - suffix expects a scope, then it has to determine that itself and - store it in its ‘scope’ slot. - - This function is called for all suffix commands, but unless a - concrete method is implemented this falls through to the default - implementation, which is a noop. - - -File: transient.info, Node: Suffix Format Methods, Prev: Suffix Value Methods, Up: Suffix Methods - -5.5.2 Suffix Format Methods ---------------------------- - - -- Function: transient-format obj - This generic function formats and returns OBJ for display. - - When this function is called, then the current buffer is some - temporary buffer. If you need the buffer from which the prefix - command was invoked to be current, then do so by temporarily making - ‘transient--source-buffer’ current. - - -- Function: transient-format-key obj - This generic function formats OBJ’s ‘key’ for display and returns - the result. - - -- Function: transient-format-description obj - This generic function formats OBJ’s ‘description’ for display and - returns the result. - - -- Function: transient-format-value obj - This generic function formats OBJ’s value for display and returns - the result. - - -- Function: transient-show-help obj - Show help for the prefix, infix or suffix command represented by - OBJ. - - Regardless of OBJ’s type, if its ‘show-help’ slot is non-nil, that - must be a function, which takes OBJ is its only argument. It must - prepare, display and return a buffer, and select the window used to - display it. The ‘transient-show-help-window’ macro is intended for - use in such functions. - - For prefixes, show the info manual, if that is specified using the - ‘info-manual’ slot. Otherwise, show the manpage if that is - specified using the ‘man-page’ slot. Otherwise, show the command’s - documentation string. - - For suffixes, show the command’s documentation string. - - For infixes, show the manpage if that is specified. Otherwise show - the command’s documentation string. - - -- Macro: transient-with-help-window &rest body - Evaluate BODY, send output to ‘*Help*’ buffer, and display it in a - window. Select the help window, and make the help buffer current - and return it. - - -- Function: transient-show-summary obj &optional return - This generic function shows or, if optional RETURN is non-‘nil’, - returns a brief summary about the command at point or hovered with - the mouse. - - This function is called when the mouse is moved over a command and - (if the value of ‘transient-enable-popup-navigation’ is ‘verbose’) - when the user navigates to a command using the keyboard. - - If OBJ’s ‘summary’ slot is a string, that is used. If ‘summary’ is - a function, that is called with OBJ as the only argument and the - returned string is used. If ‘summary’ is or returns something - other than a string or nil, no summary is shown. If ‘summary’ is - or returns ‘nil’, the first line of the documentation string is - used, if any. - - If RETURN is non-‘nil’, this function returns the summary instead - of showing it. This is used when a tooltip is needed. - - -File: transient.info, Node: Prefix Slots, Next: Suffix Slots, Prev: Suffix Methods, Up: Classes and Methods - -5.6 Prefix Slots -================ - - • ‘show-help’, ‘man-page’ or ‘info-manual’ can be used to specify the - documentation for the prefix and its suffixes. The command - ‘transient-help’ uses the function ‘transient-show-help’ (which - see) to lookup and use these values. - - • ‘history-key’ If multiple prefix commands should share a single - value, then this slot has to be set to the same value for all of - them. You probably don’t want that. - - • ‘transient-suffix’ and ‘transient-non-suffix’ play a part when - determining whether the currently active transient prefix command - remains active/transient when a suffix or arbitrary non-suffix - command is invoked. See *note Transient State::. - - • ‘refresh-suffixes’ Normally suffix objects and keymaps are only - setup once, when the prefix is invoked. Setting this to ‘t’, - causes them to be recreated after every command. This is useful - when using ‘:if...’ predicates, and those need to be rerun for some - reason. Doing this is somewhat costly, and there is a risk of - losing state, so this is disabled by default and still considered - experimental. - - • ‘incompatible’ A list of lists. Each sub-list specifies a set of - mutually exclusive arguments. Enabling one of these arguments - causes the others to be disabled. An argument may appear in - multiple sub-lists. Arguments must me given in the same form as - used in the ‘argument’ or ‘argument-format’ slot of the respective - suffix objects, usually something like ‘--switch’ or ‘--option=%s’. - For options and ‘transient-switches’ suffixes it is also possible - to match against a specific value, as returned by - ‘transient-infix-value’, for example, ‘--option=one’. - - • ‘scope’ For some transients it might be necessary to have a sort of - secondary value, called a “scope”. See ‘transient-define-prefix’. - -Internal Prefix Slots ---------------------- - -These slots are mostly intended for internal use. They should not be -set in calls to ‘transient-define-prefix’. - - • ‘prototype’ When a transient prefix command is invoked, then a - clone of that object is stored in the global variable - ‘transient--prefix’ and the prototype is stored in the clone’s - ‘prototype’ slot. - - • ‘command’ The command, a symbol. Each transient prefix command - consists of a command, which is stored in a symbol’s function slot - and an object, which is stored in the ‘transient--prefix’ property - of the same symbol. - - • ‘level’ The level of the prefix commands. The suffix commands - whose layer is equal or lower are displayed. See *note Enabling - and Disabling Suffixes::. - - • ‘value’ The likely outdated value of the prefix. Instead of - accessing this slot directly you should use the function - ‘transient-get-value’, which is guaranteed to return the up-to-date - value. - - • ‘history’ and ‘history-pos’ are used to keep track of historic - values. Unless you implement your own ‘transient-infix-read’ - method you should not have to deal with these slots. - - -File: transient.info, Node: Suffix Slots, Next: Predicate Slots, Prev: Prefix Slots, Up: Classes and Methods - -5.7 Suffix Slots -================ - -Here we document most of the slots that are only available for suffix -objects. Some slots are shared by suffix and group objects, they are -documented in *note Predicate Slots::. - - Also see *note Suffix Classes::. - -Slots of ‘transient-suffix’ ---------------------------- - - • ‘key’ The key, a key vector or a key description string. - - • ‘command’ The command, a symbol. - - • ‘transient’ Whether to stay transient. See *note Transient - State::. - - • ‘format’ The format used to display the suffix in the popup buffer. - It must contain the following %-placeholders: - - • ‘%k’ For the key. - • ‘%d’ For the description. - • ‘%v’ For the infix value. Non-infix suffixes don’t have a - value. - - • ‘description’ The description, either a string or a function, which - is called with zero or one argument (the suffix object), and - returns a string. - - • ‘face’ Face used for the description. In simple cases it is easier - to use this instead of using a function as ‘description’ and adding - the styling there. ‘face’ is appended using - ‘add-face-text-property’. - - • ‘show-help’ A function used to display help for the suffix. If - unspecified, the prefix controls how help is displayed for its - suffixes. See also function ‘transient-show-help’. - - • ‘summary’ The summary displayed in the echo area, or as a tooltip. - If this is ‘nil’, which it usually should be, the first line of the - documentation string is used instead. See ‘transient-show-summary’ - for details. - -Slots of ‘transient-infix’ --------------------------- - -Some of these slots are only meaningful for some of the subclasses. -They are defined here anyway to allow sharing certain methods. - - • ‘argument’ The long argument, e.g., ‘--verbose’. - - • ‘shortarg’ The short argument, e.g., ‘-v’. - - • ‘value’ The value. Should not be accessed directly. - - • ‘init-value’ Function that is responsible for setting the object’s - value. If bound, then this is called with the object as the only - argument. Usually this is not bound, in which case the object’s - primary ‘transient-init-value’ method is called instead. - - • ‘unsavable’ Whether the value of the suffix is not saved as part of - the prefixes. - - • ‘multi-value’ For options, whether the option can have multiple - values. If this is non-‘nil’, then the values are read using - ‘completing-read-multiple’ by default and if you specify your own - reader, then it should read the values using that function or - similar. - - Supported non-‘nil’ values are: - - • Use ‘rest’ for an option that can have multiple values. This - is useful e.g., for an ‘--’ argument that indicates that all - remaining arguments are files (such as ‘git log -- file1 - file2’). - - In the list returned by ‘transient-args’ such an option and - its values are represented by a single list of the form - ‘(ARGUMENT . VALUES)’. - - • Use ‘repeat’ for an option that can be specified multiple - times. - - In the list returned by ‘transient-args’ each instance of the - option and its value appears separately in the usual from, for - example: ‘("--another-argument" "--option=first" - "--option=second")’. - - In both cases the option’s values have to be specified in the - default value of a prefix using the same format as returned by - ‘transient-args’, e.g., ‘("--other" "--o=1" "--o=2" ("--" "f1" - "f2"))’. - - • ‘always-read’ For options, whether to read a value on every - invocation. If this is ‘nil’, then options that have a value are - simply unset and have to be invoked a second time to set a new - value. - - • ‘allow-empty’ For options, whether the empty string is a valid - value. - - • ‘history-key’ The key used to store the history. This defaults to - the command name. This is useful when multiple infixes should - share the same history because their values are of the same kind. - - • ‘reader’ The function used to read the value of an infix. Not used - for switches. The function takes three arguments, PROMPT, - INITIAL-INPUT and HISTORY, and must return a string. - - • ‘prompt’ The prompt used when reading the value, either a string or - a function that takes the object as the only argument and which - returns a prompt string. - - • ‘choices’ A list of valid values, or a function that returns such a - list. The latter is not implemented for ‘transient-switches’, - because I couldn’t think of a use-case. How exactly the choices - are used varies depending on the class of the suffix. - -Slots of ‘transient-variable’ ------------------------------ - - • ‘variable’ The variable. - -Slots of ‘transient-switches’ ------------------------------ - - • ‘argument-format’ The display format. Must contain ‘%s’, one of - the ‘choices’ is substituted for that. E.g., ‘--%s-order’. - - • ‘argument-regexp’ The regexp used to match any one of the switches. - E.g., ‘\\(--\\(topo\\|author-date\\|date\\)-order\\)’. - - -File: transient.info, Node: Predicate Slots, Prev: Suffix Slots, Up: Classes and Methods - -5.8 Predicate Slots -=================== - -Suffix and group objects share some predicate slots that control whether -a group or suffix should be available depending on some state. Only one -of these slots can be used at the same time. It is undefined what -happens if you use more than one. - - • ‘if’ Enable if predicate returns non-‘nil’. - • ‘if-not’ Enable if predicate returns ‘nil’. - • ‘if-non-nil’ Enable if variable’s value is non-‘nil’. - • ‘if-nil’ Enable if variable’s value is ‘nil’. - • ‘if-mode’ Enable if major-mode matches value. - • ‘if-not-mode’ Enable if major-mode does not match value. - • ‘if-derived’ Enable if major-mode derives from value. - • ‘if-not-derived’ Enable if major-mode does not derive from value. - - By default these predicates run when the prefix command is invoked, -but this can be changes, using the ‘refresh-suffixes’ prefix slot. See -*note Prefix Slots::. - - One more slot is shared between group and suffix classes, ‘level’. -Like the slots documented above, it is a predicate, but it is used for a -different purpose. The value has to be an integer between 1 and 7. -‘level’ controls whether a suffix or a group should be available -depending on user preference. See *note Enabling and Disabling -Suffixes::. - - -File: transient.info, Node: FAQ, Next: Keystroke Index, Prev: Classes and Methods, Up: Top - -Appendix A FAQ -************** - -A.1 Can I control how the popup buffer is displayed? -==================================================== - -Yes, see ‘transient-display-buffer-action’ in *note Configuration::. - -A.2 How can I copy text from the popup buffer? -============================================== - -To be able to mark text in Transient’s popup buffer using the mouse, you -have to add the below binding. Note that for technical reasons, the -region won’t be visualized, while doing so. After you have quit the -transient popup, you will be able to yank it in another buffer. - - (keymap-set transient-predicate-map - "<mouse-set-region>" - #'transient--do-stay) - -A.3 How can I autoload prefix and suffix commands? -================================================== - -If your package only supports Emacs 30, just prefix the definition with -‘;;;###autoload’. If your package supports released versions of Emacs, -you unfortunately have to use a long form autoload comment as described -in *note (elisp)Autoload::. - - ;;;###autoload (autoload 'magit-dispatch "magit" nil t) - (transient-define-prefix magit-dispatch () - ...) - -A.4 How does Transient compare to prefix keys and universal arguments? -====================================================================== - -See -<https://github.com/magit/transient/wiki/Comparison-with-prefix-keys-and-universal-arguments>. - -A.5 How does Transient compare to Magit-Popup and Hydra? -======================================================== - -See -<https://github.com/magit/transient/wiki/Comparison-with-other-packages>. - -A.6 Why did some of the key bindings change? -============================================ - -You may have noticed that the bindings for some of the common commands -do *not* have the prefix ‘C-x’ and that furthermore some of these -commands are grayed out while others are not. That unfortunately is a -bit confusing if the section of common commands is not shown -permanently, making the following explanation necessary. - - The purpose of usually hiding that section but showing it after the -user pressed the respective prefix key is to conserve space and not -overwhelm users with too much noise, while allowing the user to quickly -list common bindings on demand. - - That however should not keep us from using the best possible key -bindings. The bindings that do use a prefix do so to avoid wasting too -many non-prefix bindings, keeping them available for use in individual -transients. The bindings that do not use a prefix and that are *not* -grayed out are very important bindings that are *always* available, even -when invoking the “common command key prefix” or *any other* -transient-specific prefix. The non-prefix keys that *are* grayed out -however, are not available when any incomplete prefix key sequence is -active. They do not use the “common command key prefix” because it is -likely that users want to invoke them several times in a row and e.g., -‘M-p M-p M-p’ is much more convenient than ‘C-x M-p C-x M-p C-x M-p’. - - You may also have noticed that the “Set” command is bound to ‘C-x s’, -while Magit-Popup used to bind ‘C-c C-c’ instead. I have seen several -users praise the latter binding (sic), so I did not change it -willy-nilly. The reason that I changed it is that using different -prefix keys for different common commands, would have made the temporary -display of the common commands even more confusing, i.e., after pressing -‘C-c’ all the bindings that begin with the ‘C-x’ prefix would be grayed -out. - - Using a single prefix for common commands key means that all other -potential prefix keys can be used for transient-specific commands -*without* the section of common commands also popping up. ‘C-c’ in -particular is a prefix that I want to (and already do) use for Magit, -and also using that for a common command would prevent me from doing so. - - (Also see the next question.) - -A.7 Why does ‘q’ not quit popups anymore? -========================================= - -I agree that ‘q’ is a good binding for commands that quit something. -This includes quitting whatever transient is currently active, but it -also includes quitting whatever it is that some specific transient is -controlling. The transient ‘magit-blame’ for example binds ‘q’ to the -command that turns ‘magit-blame-mode’ off. - - So I had to decide if ‘q’ should quit the active transient (like -Magit-Popup used to) or whether ‘C-g’ should do that instead, so that -‘q’ could be bound in individual transient to whatever commands make -sense for them. Because all other letters are already reserved for use -by individual transients, I have decided to no longer make an exception -for ‘q’. - - If you want to get ‘q’’s old binding back then you can do so. Doing -that is a bit more complicated than changing a single key binding, so I -have implemented a function, ‘transient-bind-q-to-quit’ that makes the -necessary changes. See its documentation string for more information. - - -File: transient.info, Node: Keystroke Index, Next: Command and Function Index, Prev: FAQ, Up: Top - -Appendix B Keystroke Index -************************** - - -* Menu: - -* C-g: Aborting and Resuming Transients. - (line 27) -* C-g <1>: Aborting and Resuming Transients. - (line 27) -* C-h: Getting Help for Suffix Commands. - (line 11) -* C-M-n: Using History. (line 18) -* C-M-p: Using History. (line 13) -* C-q: Aborting and Resuming Transients. - (line 36) -* C-x a: Enabling and Disabling Suffixes. - (line 68) -* C-x C-k: Saving Values. (line 29) -* C-x C-s: Saving Values. (line 25) -* C-x l: Enabling and Disabling Suffixes. - (line 43) -* C-x n: Using History. (line 18) -* C-x p: Using History. (line 13) -* C-x s: Saving Values. (line 21) -* C-x t: Common Suffix Commands. - (line 18) -* C-z: Aborting and Resuming Transients. - (line 41) - - -File: transient.info, Node: Command and Function Index, Next: Variable Index, Prev: Keystroke Index, Up: Top - -Appendix C Command and Function Index -************************************* - - -* Menu: - -* transient--do-call: Transient State. (line 125) -* transient--do-exit: Transient State. (line 117) -* transient--do-leave: Transient State. (line 193) -* transient--do-quit-all: Transient State. (line 205) -* transient--do-quit-one: Transient State. (line 200) -* transient--do-recurse: Transient State. (line 133) -* transient--do-replace: Transient State. (line 153) -* transient--do-return: Transient State. (line 120) -* transient--do-stack: Transient State. (line 145) -* transient--do-stay: Transient State. (line 105) -* transient--do-stay <1>: Transient State. (line 190) -* transient--do-suspend: Transient State. (line 161) -* transient--do-suspend <1>: Transient State. (line 210) -* transient--do-warn: Transient State. (line 187) -* transient--history-init: Prefix Classes. (line 10) -* transient--insert-group: Group Methods. (line 19) -* transient-active-prefix: Using Infix Arguments. - (line 61) -* transient-append-suffix: Modifying Existing Transients. - (line 51) -* transient-arg-value: Using Infix Arguments. - (line 31) -* transient-args: Using Infix Arguments. - (line 22) -* transient-define-argument: Defining Suffix and Infix Commands. - (line 57) -* transient-define-infix: Defining Suffix and Infix Commands. - (line 26) -* transient-define-prefix: Defining Transients. (line 13) -* transient-define-suffix: Defining Suffix and Infix Commands. - (line 9) -* transient-format: Suffix Format Methods. - (line 6) -* transient-format-description: Suffix Format Methods. - (line 18) -* transient-format-key: Suffix Format Methods. - (line 14) -* transient-format-value: Suffix Format Methods. - (line 22) -* transient-get-suffix: Modifying Existing Transients. - (line 73) -* transient-help: Getting Help for Suffix Commands. - (line 11) -* transient-history-next: Using History. (line 18) -* transient-history-prev: Using History. (line 13) -* transient-infix-read: Suffix Value Methods. - (line 16) -* transient-infix-set: Suffix Value Methods. - (line 36) -* transient-infix-value: Suffix Value Methods. - (line 39) -* transient-init-scope: Suffix Value Methods. - (line 52) -* transient-init-value: Suffix Value Methods. - (line 6) -* transient-insert-suffix: Modifying Existing Transients. - (line 49) -* transient-prompt: Suffix Value Methods. - (line 32) -* transient-quit-all: Aborting and Resuming Transients. - (line 36) -* transient-quit-one: Aborting and Resuming Transients. - (line 27) -* transient-quit-seq: Aborting and Resuming Transients. - (line 27) -* transient-remove-suffix: Modifying Existing Transients. - (line 70) -* transient-replace-suffix: Modifying Existing Transients. - (line 66) -* transient-reset: Saving Values. (line 29) -* transient-resume: Aborting and Resuming Transients. - (line 53) -* transient-save: Saving Values. (line 25) -* transient-scroll-down: Other Commands. (line 17) -* transient-scroll-up: Other Commands. (line 12) -* transient-set: Saving Values. (line 21) -* transient-set-level: Enabling and Disabling Suffixes. - (line 43) -* transient-setup-children: Group Methods. (line 6) -* transient-show-help: Suffix Format Methods. - (line 26) -* transient-show-summary: Suffix Format Methods. - (line 51) -* transient-suffix-put: Modifying Existing Transients. - (line 77) -* transient-suffixes: Using Infix Arguments. - (line 38) -* transient-suspend: Aborting and Resuming Transients. - (line 41) -* transient-toggle-common: Common Suffix Commands. - (line 18) -* transient-toggle-level-limit: Enabling and Disabling Suffixes. - (line 68) -* transient-with-help-window: Suffix Format Methods. - (line 46) - - -File: transient.info, Node: Variable Index, Next: Concept Index, Prev: Command and Function Index, Up: Top - -Appendix D Variable Index -************************* - - -* Menu: - -* transient-align-variable-pitch: Configuration. (line 192) -* transient-current-command: Using Infix Arguments. - (line 52) -* transient-current-prefix: Using Infix Arguments. - (line 56) -* transient-current-suffixes: Using Infix Arguments. - (line 44) -* transient-default-level: Enabling and Disabling Suffixes. - (line 33) -* transient-detect-key-conflicts: Configuration. (line 217) -* transient-display-buffer-action: Configuration. (line 58) -* transient-enable-popup-navigation: Configuration. (line 36) -* transient-force-fixed-pitch: Configuration. (line 205) -* transient-force-single-column: Configuration. (line 100) -* transient-hide-during-minibuffer-read: Configuration. (line 188) -* transient-highlight-higher-levels: Configuration. (line 230) -* transient-highlight-mismatched-keys: Configuration. (line 142) -* transient-history-file: Using History. (line 33) -* transient-history-limit: Using History. (line 37) -* transient-levels-file: Enabling and Disabling Suffixes. - (line 38) -* transient-mode-line-format: Configuration. (line 109) -* transient-read-with-initial-input: Configuration. (line 181) -* transient-semantic-coloring: Configuration. (line 133) -* transient-show-common-commands: Common Suffix Commands. - (line 23) -* transient-show-popup: Configuration. (line 15) -* transient-substitute-key-function: Configuration. (line 160) -* transient-values-file: Saving Values. (line 31) - - -File: transient.info, Node: Concept Index, Next: GNU General Public License, Prev: Variable Index, Up: Top - -Appendix E Concept Index -************************ - - -* Menu: - -* aborting transients: Aborting and Resuming Transients. - (line 6) -* classes and methods: Classes and Methods. (line 6) -* command dispatchers: Technical Introduction. - (line 39) -* common suffix commands: Common Suffix Commands. - (line 6) -* defining infix commands: Defining Suffix and Infix Commands. - (line 6) -* defining suffix commands: Defining Suffix and Infix Commands. - (line 6) -* disabling suffixes: Enabling and Disabling Suffixes. - (line 6) -* enabling suffixes: Enabling and Disabling Suffixes. - (line 6) -* getting help: Getting Help for Suffix Commands. - (line 6) -* group specifications: Group Specifications. (line 6) -* invoking transients: Invoking Transients. (line 6) -* levels: Enabling and Disabling Suffixes. - (line 10) -* modifying existing transients: Modifying Existing Transients. - (line 6) -* quit transient: Aborting and Resuming Transients. - (line 6) -* resuming transients: Aborting and Resuming Transients. - (line 6) -* saving values of arguments: Saving Values. (line 6) -* scope of a transient: Defining Transients. (line 43) -* suffix specifications: Suffix Specifications. - (line 6) -* transient state: Transient State. (line 6) -* transient-level: Enabling and Disabling Suffixes. - (line 15) -* value history: Using History. (line 6) - - -File: transient.info, Node: GNU General Public License, Prev: Concept Index, Up: Top - -Appendix F GNU General Public License -************************************* - - Version 3, 29 June 2007 - - Copyright © 2007 Free Software Foundation, Inc. <https://fsf.org/> - - Everyone is permitted to copy and distribute verbatim copies of this - license document, but changing it is not allowed. - -Preamble -======== - -The GNU General Public License is a free, copyleft license for software -and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program—to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers’ and authors’ protection, the GPL clearly explains -that there is no warranty for this free software. For both users’ and -authors’ sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users’ freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - -TERMS AND CONDITIONS -==================== - - 0. Definitions. - - “This License” refers to version 3 of the GNU General Public - License. - - “Copyright” also means copyright-like laws that apply to other - kinds of works, such as semiconductor masks. - - “The Program” refers to any copyrightable work licensed under this - License. Each licensee is addressed as “you”. “Licensees” and - “recipients” may be individuals or organizations. - - To “modify” a work means to copy from or adapt all or part of the - work in a fashion requiring copyright permission, other than the - making of an exact copy. The resulting work is called a “modified - version” of the earlier work or a work “based on” the earlier work. - - A “covered work” means either the unmodified Program or a work - based on the Program. - - To “propagate” a work means to do anything with it that, without - permission, would make you directly or secondarily liable for - infringement under applicable copyright law, except executing it on - a computer or modifying a private copy. Propagation includes - copying, distribution (with or without modification), making - available to the public, and in some countries other activities as - well. - - To “convey” a work means any kind of propagation that enables other - parties to make or receive copies. Mere interaction with a user - through a computer network, with no transfer of a copy, is not - conveying. - - An interactive user interface displays “Appropriate Legal Notices” - to the extent that it includes a convenient and prominently visible - feature that (1) displays an appropriate copyright notice, and (2) - tells the user that there is no warranty for the work (except to - the extent that warranties are provided), that licensees may convey - the work under this License, and how to view a copy of this - License. If the interface presents a list of user commands or - options, such as a menu, a prominent item in the list meets this - criterion. - - 1. Source Code. - - The “source code” for a work means the preferred form of the work - for making modifications to it. “Object code” means any non-source - form of a work. - - A “Standard Interface” means an interface that either is an - official standard defined by a recognized standards body, or, in - the case of interfaces specified for a particular programming - language, one that is widely used among developers working in that - language. - - The “System Libraries” of an executable work include anything, - other than the work as a whole, that (a) is included in the normal - form of packaging a Major Component, but which is not part of that - Major Component, and (b) serves only to enable use of the work with - that Major Component, or to implement a Standard Interface for - which an implementation is available to the public in source code - form. A “Major Component”, in this context, means a major - essential component (kernel, window system, and so on) of the - specific operating system (if any) on which the executable work - runs, or a compiler used to produce the work, or an object code - interpreter used to run it. - - The “Corresponding Source” for a work in object code form means all - the source code needed to generate, install, and (for an executable - work) run the object code and to modify the work, including scripts - to control those activities. However, it does not include the - work’s System Libraries, or general-purpose tools or generally - available free programs which are used unmodified in performing - those activities but which are not part of the work. For example, - Corresponding Source includes interface definition files associated - with source files for the work, and the source code for shared - libraries and dynamically linked subprograms that the work is - specifically designed to require, such as by intimate data - communication or control flow between those subprograms and other - parts of the work. - - The Corresponding Source need not include anything that users can - regenerate automatically from other parts of the Corresponding - Source. - - The Corresponding Source for a work in source code form is that - same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of - copyright on the Program, and are irrevocable provided the stated - conditions are met. This License explicitly affirms your unlimited - permission to run the unmodified Program. The output from running - a covered work is covered by this License only if the output, given - its content, constitutes a covered work. This License acknowledges - your rights of fair use or other equivalent, as provided by - copyright law. - - You may make, run and propagate covered works that you do not - convey, without conditions so long as your license otherwise - remains in force. You may convey covered works to others for the - sole purpose of having them make modifications exclusively for you, - or provide you with facilities for running those works, provided - that you comply with the terms of this License in conveying all - material for which you do not control copyright. Those thus making - or running the covered works for you must do so exclusively on your - behalf, under your direction and control, on terms that prohibit - them from making any copies of your copyrighted material outside - their relationship with you. - - Conveying under any other circumstances is permitted solely under - the conditions stated below. Sublicensing is not allowed; section - 10 makes it unnecessary. - - 3. Protecting Users’ Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological - measure under any applicable law fulfilling obligations under - article 11 of the WIPO copyright treaty adopted on 20 December - 1996, or similar laws prohibiting or restricting circumvention of - such measures. - - When you convey a covered work, you waive any legal power to forbid - circumvention of technological measures to the extent such - circumvention is effected by exercising rights under this License - with respect to the covered work, and you disclaim any intention to - limit operation or modification of the work as a means of - enforcing, against the work’s users, your or third parties’ legal - rights to forbid circumvention of technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program’s source code as you - receive it, in any medium, provided that you conspicuously and - appropriately publish on each copy an appropriate copyright notice; - keep intact all notices stating that this License and any - non-permissive terms added in accord with section 7 apply to the - code; keep intact all notices of the absence of any warranty; and - give all recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, - and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to - produce it from the Program, in the form of source code under the - terms of section 4, provided that you also meet all of these - conditions: - - a. The work must carry prominent notices stating that you - modified it, and giving a relevant date. - - b. The work must carry prominent notices stating that it is - released under this License and any conditions added under - section 7. This requirement modifies the requirement in - section 4 to “keep intact all notices”. - - c. You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable - section 7 additional terms, to the whole of the work, and all - its parts, regardless of how they are packaged. This License - gives no permission to license the work in any other way, but - it does not invalidate such permission if you have separately - received it. - - d. If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has - interactive interfaces that do not display Appropriate Legal - Notices, your work need not make them do so. - - A compilation of a covered work with other separate and independent - works, which are not by their nature extensions of the covered - work, and which are not combined with it such as to form a larger - program, in or on a volume of a storage or distribution medium, is - called an “aggregate” if the compilation and its resulting - copyright are not used to limit the access or legal rights of the - compilation’s users beyond what the individual works permit. - Inclusion of a covered work in an aggregate does not cause this - License to apply to the other parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms - of sections 4 and 5, provided that you also convey the - machine-readable Corresponding Source under the terms of this - License, in one of these ways: - - a. Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b. Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that - product model, to give anyone who possesses the object code - either (1) a copy of the Corresponding Source for all the - software in the product that is covered by this License, on a - durable physical medium customarily used for software - interchange, for a price no more than your reasonable cost of - physically performing this conveying of source, or (2) access - to copy the Corresponding Source from a network server at no - charge. - - c. Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, - and only if you received the object code with such an offer, - in accord with subsection 6b. - - d. Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to - the Corresponding Source in the same way through the same - place at no further charge. You need not require recipients - to copy the Corresponding Source along with the object code. - If the place to copy the object code is a network server, the - Corresponding Source may be on a different server (operated by - you or a third party) that supports equivalent copying - facilities, provided you maintain clear directions next to the - object code saying where to find the Corresponding Source. - Regardless of what server hosts the Corresponding Source, you - remain obligated to ensure that it is available for as long as - needed to satisfy these requirements. - - e. Convey the object code using peer-to-peer transmission, - provided you inform other peers where the object code and - Corresponding Source of the work are being offered to the - general public at no charge under subsection 6d. - - A separable portion of the object code, whose source code is - excluded from the Corresponding Source as a System Library, need - not be included in conveying the object code work. - - A “User Product” is either (1) a “consumer product”, which means - any tangible personal property which is normally used for personal, - family, or household purposes, or (2) anything designed or sold for - incorporation into a dwelling. In determining whether a product is - a consumer product, doubtful cases shall be resolved in favor of - coverage. For a particular product received by a particular user, - “normally used” refers to a typical or common use of that class of - product, regardless of the status of the particular user or of the - way in which the particular user actually uses, or expects or is - expected to use, the product. A product is a consumer product - regardless of whether the product has substantial commercial, - industrial or non-consumer uses, unless such uses represent the - only significant mode of use of the product. - - “Installation Information” for a User Product means any methods, - procedures, authorization keys, or other information required to - install and execute modified versions of a covered work in that - User Product from a modified version of its Corresponding Source. - The information must suffice to ensure that the continued - functioning of the modified object code is in no case prevented or - interfered with solely because modification has been made. - - If you convey an object code work under this section in, or with, - or specifically for use in, a User Product, and the conveying - occurs as part of a transaction in which the right of possession - and use of the User Product is transferred to the recipient in - perpetuity or for a fixed term (regardless of how the transaction - is characterized), the Corresponding Source conveyed under this - section must be accompanied by the Installation Information. But - this requirement does not apply if neither you nor any third party - retains the ability to install modified object code on the User - Product (for example, the work has been installed in ROM). - - The requirement to provide Installation Information does not - include a requirement to continue to provide support service, - warranty, or updates for a work that has been modified or installed - by the recipient, or for the User Product in which it has been - modified or installed. Access to a network may be denied when the - modification itself materially and adversely affects the operation - of the network or violates the rules and protocols for - communication across the network. - - Corresponding Source conveyed, and Installation Information - provided, in accord with this section must be in a format that is - publicly documented (and with an implementation available to the - public in source code form), and must require no special password - or key for unpacking, reading or copying. - - 7. Additional Terms. - - “Additional permissions” are terms that supplement the terms of - this License by making exceptions from one or more of its - conditions. Additional permissions that are applicable to the - entire Program shall be treated as though they were included in - this License, to the extent that they are valid under applicable - law. If additional permissions apply only to part of the Program, - that part may be used separately under those permissions, but the - entire Program remains governed by this License without regard to - the additional permissions. - - When you convey a copy of a covered work, you may at your option - remove any additional permissions from that copy, or from any part - of it. (Additional permissions may be written to require their own - removal in certain cases when you modify the work.) You may place - additional permissions on material, added by you to a covered work, - for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material - you add to a covered work, you may (if authorized by the copyright - holders of that material) supplement the terms of this License with - terms: - - a. Disclaiming warranty or limiting liability differently from - the terms of sections 15 and 16 of this License; or - - b. Requiring preservation of specified reasonable legal notices - or author attributions in that material or in the Appropriate - Legal Notices displayed by works containing it; or - - c. Prohibiting misrepresentation of the origin of that material, - or requiring that modified versions of such material be marked - in reasonable ways as different from the original version; or - - d. Limiting the use for publicity purposes of names of licensors - or authors of the material; or - - e. Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f. Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified - versions of it) with contractual assumptions of liability to - the recipient, for any liability that these contractual - assumptions directly impose on those licensors and authors. - - All other non-permissive additional terms are considered “further - restrictions” within the meaning of section 10. If the Program as - you received it, or any part of it, contains a notice stating that - it is governed by this License along with a term that is a further - restriction, you may remove that term. If a license document - contains a further restriction but permits relicensing or conveying - under this License, you may add to a covered work material governed - by the terms of that license document, provided that the further - restriction does not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you - must place, in the relevant source files, a statement of the - additional terms that apply to those files, or a notice indicating - where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in - the form of a separately written license, or stated as exceptions; - the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly - provided under this License. Any attempt otherwise to propagate or - modify it is void, and will automatically terminate your rights - under this License (including any patent licenses granted under the - third paragraph of section 11). - - However, if you cease all violation of this License, then your - license from a particular copyright holder is reinstated (a) - provisionally, unless and until the copyright holder explicitly and - finally terminates your license, and (b) permanently, if the - copyright holder fails to notify you of the violation by some - reasonable means prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is - reinstated permanently if the copyright holder notifies you of the - violation by some reasonable means, this is the first time you have - received notice of violation of this License (for any work) from - that copyright holder, and you cure the violation prior to 30 days - after your receipt of the notice. - - Termination of your rights under this section does not terminate - the licenses of parties who have received copies or rights from you - under this License. If your rights have been terminated and not - permanently reinstated, you do not qualify to receive new licenses - for the same material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or - run a copy of the Program. Ancillary propagation of a covered work - occurring solely as a consequence of using peer-to-peer - transmission to receive a copy likewise does not require - acceptance. However, nothing other than this License grants you - permission to propagate or modify any covered work. These actions - infringe copyright if you do not accept this License. Therefore, - by modifying or propagating a covered work, you indicate your - acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically - receives a license from the original licensors, to run, modify and - propagate that work, subject to this License. You are not - responsible for enforcing compliance by third parties with this - License. - - An “entity transaction” is a transaction transferring control of an - organization, or substantially all assets of one, or subdividing an - organization, or merging organizations. If propagation of a - covered work results from an entity transaction, each party to that - transaction who receives a copy of the work also receives whatever - licenses to the work the party’s predecessor in interest had or - could give under the previous paragraph, plus a right to possession - of the Corresponding Source of the work from the predecessor in - interest, if the predecessor has it or can get it with reasonable - efforts. - - You may not impose any further restrictions on the exercise of the - rights granted or affirmed under this License. For example, you - may not impose a license fee, royalty, or other charge for exercise - of rights granted under this License, and you may not initiate - litigation (including a cross-claim or counterclaim in a lawsuit) - alleging that any patent claim is infringed by making, using, - selling, offering for sale, or importing the Program or any portion - of it. - - 11. Patents. - - A “contributor” is a copyright holder who authorizes use under this - License of the Program or a work on which the Program is based. - The work thus licensed is called the contributor’s “contributor - version”. - - A contributor’s “essential patent claims” are all patent claims - owned or controlled by the contributor, whether already acquired or - hereafter acquired, that would be infringed by some manner, - permitted by this License, of making, using, or selling its - contributor version, but do not include claims that would be - infringed only as a consequence of further modification of the - contributor version. For purposes of this definition, “control” - includes the right to grant patent sublicenses in a manner - consistent with the requirements of this License. - - Each contributor grants you a non-exclusive, worldwide, - royalty-free patent license under the contributor’s essential - patent claims, to make, use, sell, offer for sale, import and - otherwise run, modify and propagate the contents of its contributor - version. - - In the following three paragraphs, a “patent license” is any - express agreement or commitment, however denominated, not to - enforce a patent (such as an express permission to practice a - patent or covenant not to sue for patent infringement). To “grant” - such a patent license to a party means to make such an agreement or - commitment not to enforce a patent against the party. - - If you convey a covered work, knowingly relying on a patent - license, and the Corresponding Source of the work is not available - for anyone to copy, free of charge and under the terms of this - License, through a publicly available network server or other - readily accessible means, then you must either (1) cause the - Corresponding Source to be so available, or (2) arrange to deprive - yourself of the benefit of the patent license for this particular - work, or (3) arrange, in a manner consistent with the requirements - of this License, to extend the patent license to downstream - recipients. “Knowingly relying” means you have actual knowledge - that, but for the patent license, your conveying the covered work - in a country, or your recipient’s use of the covered work in a - country, would infringe one or more identifiable patents in that - country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or - arrangement, you convey, or propagate by procuring conveyance of, a - covered work, and grant a patent license to some of the parties - receiving the covered work authorizing them to use, propagate, - modify or convey a specific copy of the covered work, then the - patent license you grant is automatically extended to all - recipients of the covered work and works based on it. - - A patent license is “discriminatory” if it does not include within - the scope of its coverage, prohibits the exercise of, or is - conditioned on the non-exercise of one or more of the rights that - are specifically granted under this License. You may not convey a - covered work if you are a party to an arrangement with a third - party that is in the business of distributing software, under which - you make payment to the third party based on the extent of your - activity of conveying the work, and under which the third party - grants, to any of the parties who would receive the covered work - from you, a discriminatory patent license (a) in connection with - copies of the covered work conveyed by you (or copies made from - those copies), or (b) primarily for and in connection with specific - products or compilations that contain the covered work, unless you - entered into that arrangement, or that patent license was granted, - prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting - any implied license or other defenses to infringement that may - otherwise be available to you under applicable patent law. - - 12. No Surrender of Others’ Freedom. - - If conditions are imposed on you (whether by court order, agreement - or otherwise) that contradict the conditions of this License, they - do not excuse you from the conditions of this License. If you - cannot convey a covered work so as to satisfy simultaneously your - obligations under this License and any other pertinent obligations, - then as a consequence you may not convey it at all. For example, - if you agree to terms that obligate you to collect a royalty for - further conveying from those to whom you convey the Program, the - only way you could satisfy both those terms and this License would - be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have - permission to link or combine any covered work with a work licensed - under version 3 of the GNU Affero General Public License into a - single combined work, and to convey the resulting work. The terms - of this License will continue to apply to the part which is the - covered work, but the special requirements of the GNU Affero - General Public License, section 13, concerning interaction through - a network will apply to the combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new - versions of the GNU General Public License from time to time. Such - new versions will be similar in spirit to the present version, but - may differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the - Program specifies that a certain numbered version of the GNU - General Public License “or any later version” applies to it, you - have the option of following the terms and conditions either of - that numbered version or of any later version published by the Free - Software Foundation. If the Program does not specify a version - number of the GNU General Public License, you may choose any - version ever published by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future - versions of the GNU General Public License can be used, that - proxy’s public statement of acceptance of a version permanently - authorizes you to choose that version for the Program. - - Later license versions may give you additional or different - permissions. However, no additional obligations are imposed on any - author or copyright holder as a result of your choosing to follow a - later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY - APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE - COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM “AS IS” - WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE - RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. - SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL - NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN - WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES - AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR - DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR - CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE - THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA - BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD - PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER - PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF - THE POSSIBILITY OF SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided - above cannot be given local legal effect according to their terms, - reviewing courts shall apply local law that most closely - approximates an absolute waiver of all civil liability in - connection with the Program, unless a warranty or assumption of - liability accompanies a copy of the Program in return for a fee. - -END OF TERMS AND CONDITIONS -=========================== - -How to Apply These Terms to Your New Programs -============================================= - -If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these -terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least the -“copyright” line and a pointer to where the full notice is found. - - ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES. - Copyright (C) YEAR NAME OF AUTHOR - - 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/>. - - Also add information on how to contact you by electronic and paper -mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - PROGRAM Copyright (C) YEAR NAME OF AUTHOR - This program comes with ABSOLUTELY NO WARRANTY; for details type ‘show w’. - This is free software, and you are welcome to redistribute it - under certain conditions; type ‘show c’ for details. - - The hypothetical commands ‘show w’ and ‘show c’ should show the -appropriate parts of the General Public License. Of course, your -program’s commands might be different; for a GUI interface, you would -use an “about box”. - - You should also get your employer (if you work as a programmer) or -school, if any, to sign a “copyright disclaimer” for the program, if -necessary. For more information on this, and how to apply and follow -the GNU GPL, see <https://www.gnu.org/licenses/>. - - The GNU General Public License does not permit incorporating your -program into proprietary programs. If your program is a subroutine -library, you may consider it more useful to permit linking proprietary -applications with the library. If this is what you want to do, use the -GNU Lesser General Public License instead of this License. But first, -please read <https://www.gnu.org/licenses/why-not-lgpl.html>. - - - -Tag Table: -Node: Top763 -Node: Introduction2976 -Ref: Some things that Transient can do3504 -Ref: Complexity in CLI programs3857 -Ref: Using Transient for composing interactive commands4458 -Node: Usage6700 -Node: Invoking Transients7068 -Node: Aborting and Resuming Transients8147 -Node: Common Suffix Commands10768 -Node: Saving Values12604 -Ref: Saving Values-Footnote-113975 -Node: Using History14168 -Node: Getting Help for Suffix Commands15742 -Node: Enabling and Disabling Suffixes17120 -Node: Other Commands20408 -Node: Configuration21384 -Ref: Essential Options21664 -Ref: Accessibility Options25732 -Ref: Auxiliary Options26055 -Ref: Developer Options31011 -Node: Modifying Existing Transients32259 -Node: Defining New Commands36451 -Node: Technical Introduction36814 -Node: Defining Transients42515 -Node: Binding Suffix and Infix Commands44982 -Node: Group Specifications45840 -Node: Suffix Specifications52368 -Node: Defining Suffix and Infix Commands56581 -Node: Using Infix Arguments59629 -Node: Transient State63266 -Ref: Pre-commands for Infixes68081 -Ref: Pre-commands for Suffixes68601 -Ref: Pre-commands for Non-Suffixes71055 -Ref: Special Pre-Commands72191 -Node: Classes and Methods72699 -Node: Group Classes74883 -Node: Group Methods76810 -Node: Prefix Classes78063 -Node: Suffix Classes79154 -Node: Suffix Methods82241 -Node: Suffix Value Methods82562 -Node: Suffix Format Methods85320 -Node: Prefix Slots88310 -Ref: Internal Prefix Slots90447 -Node: Suffix Slots91704 -Ref: Slots of transient-suffix92072 -Ref: Slots of transient-infix93506 -Ref: Slots of transient-variable96802 -Ref: Slots of transient-switches96904 -Node: Predicate Slots97267 -Node: FAQ98702 -Ref: Can I control how the popup buffer is displayed?98831 -Ref: How can I copy text from the popup buffer?99012 -Ref: How can I autoload prefix and suffix commands?99506 -Ref: How does Transient compare to prefix keys and universal arguments?99980 -Ref: How does Transient compare to Magit-Popup and Hydra?100223 -Ref: Why did some of the key bindings change?100417 -Ref: Why does q not quit popups anymore?102770 -Node: Keystroke Index103873 -Node: Command and Function Index105738 -Node: Variable Index112741 -Node: Concept Index115014 -Node: GNU General Public License117750 - -End Tag Table - - -Local Variables: -coding: utf-8 -End: diff --git a/emacs/elpa/transient-20241111.1438/dir b/emacs/elpa/transient-20241115.2034/dir diff --git a/emacs/elpa/transient-20241111.1438/gpl.info b/emacs/elpa/transient-20241115.2034/gpl.info diff --git a/emacs/elpa/transient-20241111.1438/transient-autoloads.el b/emacs/elpa/transient-20241115.2034/transient-autoloads.el diff --git a/emacs/elpa/transient-20241115.2034/transient-pkg.el b/emacs/elpa/transient-20241115.2034/transient-pkg.el @@ -0,0 +1,12 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "transient" "20241115.2034" + "Transient commands." + '((emacs "26.1") + (compat "30.0.0.0") + (seq "2.24")) + :url "https://github.com/magit/transient" + :commit "291b86e66de3d7b73384f8751050acbdd2187ddb" + :revdesc "291b86e66de3" + :keywords '("extensions") + :authors '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")) + :maintainers '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev"))) diff --git a/emacs/elpa/transient-20241115.2034/transient.el b/emacs/elpa/transient-20241115.2034/transient.el @@ -0,0 +1,4682 @@ +;;; transient.el --- Transient commands -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2024 Free Software Foundation, Inc. + +;; Author: Jonas Bernoulli <emacs.transient@jonas.bernoulli.dev> +;; Homepage: https://github.com/magit/transient +;; Keywords: extensions + +;; Package-Version: 20241115.2034 +;; Package-Revision: 291b86e66de3 +;; Package-Requires: ((emacs "26.1") (compat "30.0.0.0") (seq "2.24")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Transient is the library used to implement the keyboard-driven menus +;; in Magit. It is distributed as a separate package, so that it can be +;; used to implement similar menus in other packages. + +;;; Code: + +(require 'cl-lib) +(require 'compat) +(require 'eieio) +(require 'edmacro) +(require 'format-spec) +(require 'pcase) + +(eval-and-compile + (when (and (featurep 'seq) + (not (fboundp 'seq-keep))) + (unload-feature 'seq 'force))) +(require 'seq) +(unless (fboundp 'seq-keep) + (display-warning 'transient (substitute-command-keys "\ +Transient requires `seq' >= 2.24, +but due to bad defaults, Emacs's package manager, refuses to +upgrade this and other built-in packages to higher releases +from GNU Elpa, when a package specifies that this is needed. + +To fix this, you have to add this to your init file: + + (setq package-install-upgrade-built-in t) + +Then evaluate that expression by placing the cursor after it +and typing \\[eval-last-sexp]. + +Once you have done that, you have to explicitly upgrade `seq': + + \\[package-upgrade] seq \\`RET' + +Then you also must make sure the updated version is loaded, +by evaluating this form: + + (progn (unload-feature 'seq t) (require 'seq)) + +Until you do this, you will get random errors about `seq-keep' +being undefined while using Transient. + +If you don't use the `package' package manager but still get +this warning, then your chosen package manager likely has a +similar defect.") :emergency)) + +(eval-when-compile (require 'subr-x)) + +(declare-function info "info" (&optional file-or-node buffer)) +(declare-function Man-find-section "man" (section)) +(declare-function Man-next-section "man" (n)) +(declare-function Man-getpage-in-background "man" (topic)) + +(defvar Man-notify-method) +(defvar pp-default-function) ; since Emacs 29.1 + +(eval-and-compile + (when (< emacs-major-version 28) + (pcase-defmacro cl-type (type) + "Pcase pattern that matches objects of TYPE. +TYPE is a type descriptor as accepted by `cl-typep', which see." + (static-if (< emacs-major-version 30) + `(pred (pcase--flip cl-typep ',type)) + `(pred (cl-typep _ ',type)))))) + +(defmacro transient--with-emergency-exit (id &rest body) + (declare (indent defun)) + (unless (keywordp id) + (setq body (cons id body)) + (setq id nil)) + `(condition-case err + (let ((debugger #'transient--exit-and-debug)) + ,(macroexp-progn body)) + ((debug error) + (transient--emergency-exit ,id) + (signal (car err) (cdr err))))) + +(defun transient--exit-and-debug (&rest args) + (transient--emergency-exit :debugger) + (apply #'debug args)) + +;;; Options + +(defgroup transient nil + "Transient commands." + :group 'extensions) + +(defcustom transient-show-popup t + "Whether to show the current transient in a popup buffer. +\\<transient-map> +- If t, then show the popup as soon as a transient prefix command + is invoked. + +- If nil, then do not show the popup unless the user explicitly + requests it, by pressing \\[transient-show] or a prefix key. + +- If a number, then delay displaying the popup and instead show + a brief one-line summary. If zero or negative, then suppress + even showing that summary and display the pressed key only. + + Show the popup when the user explicitly requests it by pressing + \\[transient-show] or a prefix key. Unless zero, then also show the popup + after that many seconds of inactivity (using the absolute value)." + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "instantly" t) + (const :tag "on demand" nil) + (const :tag "on demand (no summary)" 0) + (number :tag "after delay" 1))) + +(defcustom transient-enable-popup-navigation 'verbose + "Whether navigation commands are enabled in the transient popup. + +If the value is `verbose', additionally show brief documentation +about the command under point in the echo area. + +While a transient is active the transient popup buffer is not the +current buffer, making it necessary to use dedicated commands to +act on that buffer itself. If this is non-nil, then the following +bindings are available: + +\\<transient-popup-navigation-map>\ +- \\[transient-backward-button] moves the cursor to the previous suffix. +- \\[transient-forward-button] moves the cursor to the next suffix. +- \\[transient-push-button] invokes the suffix the cursor is on. +\\<transient-button-map>\ +- \\`<mouse-1>' and \\`<mouse-2>' invoke the clicked on suffix. +\\<transient-popup-navigation-map>\ +- \\[transient-isearch-backward]\ + and \\[transient-isearch-forward] start isearch in the popup buffer. + +\\`<mouse-1>' and \\`<mouse-2>' are bound in `transient-push-button'. +All other bindings are in `transient-popup-navigation-map'. + +By default \\`M-RET' is bound to `transient-push-button', instead of +\\`RET', because if a transient allows the invocation of non-suffixes, +then it is likely, that you would want \\`RET' to do what it would do +if no transient were active." + :package-version '(transient . "0.7.8") + :group 'transient + :type '(choice (const :tag "enable navigation and echo summary" verbose) + (const :tag "enable navigation commands" t) + (const :tag "disable navigation commands" nil))) + +(defcustom transient-display-buffer-action + '(display-buffer-in-side-window + (side . bottom) + (dedicated . t) + (inhibit-same-window . t)) + "The action used to display the transient popup buffer. + +The transient popup buffer is displayed in a window using + + (display-buffer BUFFER transient-display-buffer-action) + +The value of this option has the form (FUNCTION . ALIST), +where FUNCTION is a function or a list of functions. Each such +function should accept two arguments: a buffer to display and an +alist of the same form as ALIST. See info node `(elisp)Choosing +Window' for details. + +The default is: + + (display-buffer-in-side-window + (side . bottom) + (dedicated . t) + (inhibit-same-window . t)) + +This displays the window at the bottom of the selected frame. +Another useful FUNCTION is `display-buffer-below-selected', which +is what `magit-popup' used by default. For more alternatives see +info node `(elisp)Display Action Functions' and info node +`(elisp)Buffer Display Action Alists'. + +Note that the buffer that was current before the transient buffer +is shown should remain the current buffer. Many suffix commands +act on the thing at point, if appropriate, and if the transient +buffer became the current buffer, then that would change what is +at point. To that effect `inhibit-same-window' ensures that the +selected window is not used to show the transient buffer. + +It may be possible to display the window in another frame, but +whether that works in practice depends on the window-manager. +If the window manager selects the new window (Emacs frame), +then that unfortunately changes which buffer is current. + +If you change the value of this option, then you might also +want to change the value of `transient-mode-line-format'." + :package-version '(transient . "0.7.5") + :group 'transient + :type '(cons (choice function (repeat :tag "Functions" function)) + alist)) + +(defcustom transient-mode-line-format 'line + "The mode-line format for the transient popup buffer. + +If nil, then the buffer has no mode-line. If the buffer is not +displayed right above the echo area, then this probably is not +a good value. + +If `line' (the default) or a natural number, then the buffer has no +mode-line, but a line is drawn in its place. If a number is used, +that specifies the thickness of the line. On termcap frames we +cannot draw lines, so there `line' and numbers are synonyms for nil. + +The color of the line is used to indicate if non-suffixes are +allowed and whether they exit the transient. The foreground +color of `transient-key-noop' (if non-suffixes are disallowed), +`transient-key-stay' (if allowed and transient stays active), or +`transient-key-exit' (if allowed and they exit the transient) is +used to draw the line. + +Otherwise this can be any mode-line format. +See `mode-line-format' for details." + :package-version '(transient . "0.2.0") + :group 'transient + :type '(choice (const :tag "hide mode-line" nil) + (const :tag "substitute thin line" line) + (number :tag "substitute line with thickness") + (const :tag "name of prefix command" + ("%e" mode-line-front-space + mode-line-buffer-identification)) + (sexp :tag "custom mode-line format"))) + +(defcustom transient-show-common-commands nil + "Whether to show common transient suffixes in the popup buffer. + +These commands are always shown after typing the prefix key +\"C-x\" when a transient command is active. To toggle the value +of this variable use \"C-x t\" when a transient is active." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-read-with-initial-input nil + "Whether to use the last history element as initial minibuffer input." + :package-version '(transient . "0.2.0") + :group 'transient + :type 'boolean) + +(defcustom transient-highlight-mismatched-keys nil + "Whether to highlight keys that do not match their argument. + +This only affects infix arguments that represent command-line +arguments. When this option is non-nil, then the key binding +for infix argument are highlighted when only a long argument +\(e.g., \"--verbose\") is specified but no shorthand (e.g., \"-v\"). +In the rare case that a short-hand is specified but does not +match the key binding, then it is highlighted differently. + +The highlighting is done using `transient-mismatched-key' +and `transient-nonstandard-key'." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-highlight-higher-levels nil + "Whether to highlight suffixes on higher levels. + +This is primarily intended for package authors. + +When non-nil then highlight the description of suffixes whose +level is above 4, the default of `transient-default-level'. +Assuming you have set that variable to 7, this highlights all +suffixes that won't be available to users without them making +the same customization." + :package-version '(transient . "0.3.6") + :group 'transient + :type 'boolean) + +(defcustom transient-substitute-key-function nil + "Function used to modify key bindings. + +This function is called with one argument, the prefix object, +and must return a key binding description, either the existing +key description it finds in the `key' slot, or a substitution. + +This is intended to let users replace certain prefix keys. It +could also be used to make other substitutions, but that is +discouraged. + +For example, \"=\" is hard to reach using my custom keyboard +layout, so I substitute \"(\" for that, which is easy to reach +using a layout optimized for Lisp. + + (setq transient-substitute-key-function + (lambda (obj) + (let ((key (oref obj key))) + (if (string-match \"\\\\`\\\\(=\\\\)[a-zA-Z]\" key) + (replace-match \"(\" t t key 1) + key)))))" + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "Transform no keys (nil)" nil) function)) + +(defcustom transient-semantic-coloring t + "Whether to use colors to indicate transient behavior. + +If non-nil, then the key binding of each suffix is colorized to +indicate whether it exits the transient state or not, and the +line that is drawn below the transient popup buffer is used to +indicate the behavior of non-suffix commands." + :package-version '(transient . "0.5.0") + :group 'transient + :type 'boolean) + +(defcustom transient-detect-key-conflicts nil + "Whether to detect key binding conflicts. + +Conflicts are detected when a transient prefix command is invoked +and results in an error, which prevents the transient from being +used." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +(defcustom transient-align-variable-pitch nil + "Whether to align columns pixel-wise in the popup buffer. + +If this is non-nil, then columns are aligned pixel-wise to +support variable-pitch fonts. Keys are not aligned, so you +should use a fixed-pitch font for the `transient-key' face. +Other key faces inherit from that face unless a theme is +used that breaks that relationship. + +This option is intended for users who use a variable-pitch +font for the `default' face. + +Also see `transient-force-fixed-pitch'." + :package-version '(transient . "0.4.0") + :group 'transient + :type 'boolean) + +(defcustom transient-force-fixed-pitch nil + "Whether to force use of monospaced font in the popup buffer. + +Even if you use a proportional font for the `default' face, +you might still want to use a monospaced font in transient's +popup buffer. Setting this option to t causes `default' to +be remapped to `fixed-pitch' in that buffer. + +Also see `transient-align-variable-pitch'." + :package-version '(transient . "0.2.0") + :group 'transient + :type 'boolean) + +(defcustom transient-force-single-column nil + "Whether to force use of a single column to display suffixes. + +This might be useful for users with low vision who use large +text and might otherwise have to scroll in two dimensions." + :package-version '(transient . "0.3.6") + :group 'transient + :type 'boolean) + +(defcustom transient-hide-during-minibuffer-read nil + "Whether to hide the transient buffer while reading in the minibuffer." + :package-version '(transient . "0.4.0") + :group 'transient + :type 'boolean) + +(defconst transient--max-level 7) +(defconst transient--default-child-level 1) +(defconst transient--default-prefix-level 4) + +(defcustom transient-default-level transient--default-prefix-level + "Control what suffix levels are made available by default. + +Each suffix command is placed on a level and each prefix command +has a level, which controls which suffix commands are available. +Integers between 1 and 7 (inclusive) are valid levels. + +The levels of individual transients and/or their individual +suffixes can be changed individually, by invoking the prefix and +then pressing \"C-x l\". + +The default level for both transients and their suffixes is 4. +This option only controls the default for transients. The default +suffix level is always 4. The author of a transient should place +certain suffixes on a higher level if they expect that it won't be +of use to most users, and they should place very important suffixes +on a lower level so that they remain available even if the user +lowers the transient level. + +\(Magit currently places nearly all suffixes on level 4 and lower +levels are not used at all yet. So for the time being you should +not set a lower level here and using a higher level might not +give you as many additional suffixes as you hoped.)" + :package-version '(transient . "0.1.0") + :group 'transient + :type '(choice (const :tag "1 - fewest suffixes" 1) + (const 2) + (const 3) + (const :tag "4 - default" 4) + (const 5) + (const 6) + (const :tag "7 - most suffixes" 7))) + +(defcustom transient-levels-file + (locate-user-emacs-file "transient/levels.el") + "File used to save levels of transients and their suffixes." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-values-file + (locate-user-emacs-file "transient/values.el") + "File used to save values of transients." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-history-file + (locate-user-emacs-file "transient/history.el") + "File used to save history of transients and their infixes." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'file) + +(defcustom transient-history-limit 10 + "Number of history elements to keep when saving to file." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'integer) + +(defcustom transient-save-history t + "Whether to save history of transient commands when exiting Emacs." + :package-version '(transient . "0.1.0") + :group 'transient + :type 'boolean) + +;;; Faces + +(defgroup transient-faces nil + "Faces used by Transient." + :group 'transient) + +(defface transient-heading '((t :inherit font-lock-keyword-face)) + "Face used for headings." + :group 'transient-faces) + +(defface transient-argument '((t :inherit font-lock-string-face :weight bold)) + "Face used for enabled arguments." + :group 'transient-faces) + +(defface transient-inactive-argument '((t :inherit shadow)) + "Face used for inactive arguments." + :group 'transient-faces) + +(defface transient-value '((t :inherit font-lock-string-face :weight bold)) + "Face used for values." + :group 'transient-faces) + +(defface transient-inactive-value '((t :inherit shadow)) + "Face used for inactive values." + :group 'transient-faces) + +(defface transient-unreachable '((t :inherit shadow)) + "Face used for suffixes unreachable from the current prefix sequence." + :group 'transient-faces) + +(defface transient-inapt-suffix '((t :inherit shadow :italic t)) + "Face used for suffixes that are inapt at this time." + :group 'transient-faces) + +(defface transient-active-infix '((t :inherit highlight)) + "Face used for the infix for which the value is being read." + :group 'transient-faces) + +(defface transient-enabled-suffix + '((t :background "green" :foreground "black" :weight bold)) + "Face used for enabled levels while editing suffix levels. +See info node `(transient)Enabling and Disabling Suffixes'." + :group 'transient-faces) + +(defface transient-disabled-suffix + '((t :background "red" :foreground "black" :weight bold)) + "Face used for disabled levels while editing suffix levels. +See info node `(transient)Enabling and Disabling Suffixes'." + :group 'transient-faces) + +(defface transient-higher-level + `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) + :color ,(let ((color (face-attribute 'shadow :foreground nil t))) + (or (and (not (eq color 'unspecified)) color) + "grey60"))))) + "Face optionally used to highlight suffixes on higher levels. +Also see option `transient-highlight-higher-levels'." + :group 'transient-faces) + +(defface transient-delimiter '((t :inherit shadow)) + "Face used for delimiters and separators. +This includes the parentheses around values and the pipe +character used to separate possible values from each other." + :group 'transient-faces) + +(defface transient-key '((t :inherit font-lock-builtin-face)) + "Face used for keys." + :group 'transient-faces) + +(defface transient-key-stay + `((((class color) (background light)) + :inherit transient-key + :foreground "#22aa22") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ddffdd")) + "Face used for keys of suffixes that don't exit transient state." + :group 'transient-faces) + +(defface transient-key-noop + `((((class color) (background light)) + :inherit transient-key + :foreground "grey80") + (((class color) (background dark)) + :inherit transient-key + :foreground "grey30")) + "Face used for keys of suffixes that currently cannot be invoked." + :group 'transient-faces) + +(defface transient-key-return + `((((class color) (background light)) + :inherit transient-key + :foreground "#aaaa11") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ffffcc")) + "Face used for keys of suffixes that return to the parent transient." + :group 'transient-faces) + +(defface transient-key-exit + `((((class color) (background light)) + :inherit transient-key + :foreground "#aa2222") + (((class color) (background dark)) + :inherit transient-key + :foreground "#ffdddd")) + "Face used for keys of suffixes that exit transient state." + :group 'transient-faces) + +(defface transient-unreachable-key + '((t :inherit (shadow transient-key) :weight normal)) + "Face used for keys unreachable from the current prefix sequence." + :group 'transient-faces) + +(defface transient-nonstandard-key + `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) + :color "cyan"))) + "Face optionally used to highlight keys conflicting with short-argument. +Also see option `transient-highlight-mismatched-keys'." + :group 'transient-faces) + +(defface transient-mismatched-key + `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) + :color "magenta"))) + "Face optionally used to highlight keys without a short-argument. +Also see option `transient-highlight-mismatched-keys'." + :group 'transient-faces) + +;;; Persistence + +(defun transient--read-file-contents (file) + (with-demoted-errors "Transient error: %S" + (and (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (read (current-buffer)))))) + +(defun transient--pp-to-file (list file) + (make-directory (file-name-directory file) t) + (setq list (cl-sort (copy-sequence list) #'string< :key #'car)) + (with-temp-file file + (let ((print-level nil) + (print-length nil) + (pp-default-function 'pp-28) + (fill-column 999)) + (pp list (current-buffer))))) + +(defvar transient-values + (transient--read-file-contents transient-values-file) + "Values of transient commands. +The value of this variable persists between Emacs sessions +and you usually should not change it manually.") + +(defun transient-save-values () + (transient--pp-to-file transient-values transient-values-file)) + +(defvar transient-levels + (transient--read-file-contents transient-levels-file) + "Levels of transient commands. +The value of this variable persists between Emacs sessions +and you usually should not change it manually.") + +(defun transient-save-levels () + (transient--pp-to-file transient-levels transient-levels-file)) + +(defvar transient-history + (transient--read-file-contents transient-history-file) + "History of transient commands and infix arguments. +The value of this variable persists between Emacs sessions +\(unless `transient-save-history' is nil) and you usually +should not change it manually.") + +(defun transient-save-history () + (setq transient-history + (cl-sort (mapcar (pcase-lambda (`(,key . ,val)) + (cons key (seq-take (delete-dups val) + transient-history-limit))) + transient-history) + #'string< :key #'car)) + (transient--pp-to-file transient-history transient-history-file)) + +(defun transient-maybe-save-history () + "Save the value of `transient-history'. +If `transient-save-history' is nil, then do nothing." + (when transient-save-history + (transient-save-history))) + +(unless noninteractive + (add-hook 'kill-emacs-hook #'transient-maybe-save-history)) + +;;; Classes +;;;; Prefix + +(defclass transient-prefix () + ((prototype :initarg :prototype) + (command :initarg :command) + (level :initarg :level) + (variable :initarg :variable :initform nil) + (init-value :initarg :init-value) + (value) (default-value :initarg :value) + (scope :initarg :scope :initform nil) + (history :initarg :history :initform nil) + (history-pos :initarg :history-pos :initform 0) + (history-key :initarg :history-key :initform nil) + (show-help :initarg :show-help :initform nil) + (info-manual :initarg :info-manual :initform nil) + (man-page :initarg :man-page :initform nil) + (transient-suffix :initarg :transient-suffix :initform nil) + (transient-non-suffix :initarg :transient-non-suffix :initform nil) + (transient-switch-frame :initarg :transient-switch-frame) + (refresh-suffixes :initarg :refresh-suffixes :initform nil) + (environment :initarg :environment :initform nil) + (incompatible :initarg :incompatible :initform nil) + (suffix-description :initarg :suffix-description) + (variable-pitch :initarg :variable-pitch :initform nil) + (column-widths :initarg :column-widths :initform nil) + (unwind-suffix :documentation "Internal use." :initform nil)) + "Transient prefix command. + +Each transient prefix command consists of a command, which is +stored in a symbol's function slot and an object, which is +stored in the `transient--prefix' property of the same symbol. + +When a transient prefix command is invoked, then a clone of that +object is stored in the global variable `transient--prefix' and +the prototype is stored in the clone's `prototype' slot.") + +;;;; Suffix + +(defclass transient-child () + ((level + :initarg :level + :initform (symbol-value 'transient--default-child-level) + :documentation "Enable if level of prefix is equal or greater.") + (if + :initarg :if + :initform nil + :documentation "Enable if predicate returns non-nil.") + (if-not + :initarg :if-not + :initform nil + :documentation "Enable if predicate returns nil.") + (if-non-nil + :initarg :if-non-nil + :initform nil + :documentation "Enable if variable's value is non-nil.") + (if-nil + :initarg :if-nil + :initform nil + :documentation "Enable if variable's value is nil.") + (if-mode + :initarg :if-mode + :initform nil + :documentation "Enable if major-mode matches value.") + (if-not-mode + :initarg :if-not-mode + :initform nil + :documentation "Enable if major-mode does not match value.") + (if-derived + :initarg :if-derived + :initform nil + :documentation "Enable if major-mode derives from value.") + (if-not-derived + :initarg :if-not-derived + :initform nil + :documentation "Enable if major-mode does not derive from value.") + (inapt + :initform nil) + (inapt-face + :initarg :inapt-face + :initform 'transient-inapt-suffix) + (inapt-if + :initarg :inapt-if + :initform nil + :documentation "Inapt if predicate returns non-nil.") + (inapt-if-not + :initarg :inapt-if-not + :initform nil + :documentation "Inapt if predicate returns nil.") + (inapt-if-non-nil + :initarg :inapt-if-non-nil + :initform nil + :documentation "Inapt if variable's value is non-nil.") + (inapt-if-nil + :initarg :inapt-if-nil + :initform nil + :documentation "Inapt if variable's value is nil.") + (inapt-if-mode + :initarg :inapt-if-mode + :initform nil + :documentation "Inapt if major-mode matches value.") + (inapt-if-not-mode + :initarg :inapt-if-not-mode + :initform nil + :documentation "Inapt if major-mode does not match value.") + (inapt-if-derived + :initarg :inapt-if-derived + :initform nil + :documentation "Inapt if major-mode derives from value.") + (inapt-if-not-derived + :initarg :inapt-if-not-derived + :initform nil + :documentation "Inapt if major-mode does not derive from value.")) + "Abstract superclass for group and suffix classes. + +It is undefined which predicates are used if more than one `if*' +predicate slots or more than one `inapt-if*' slots are non-nil." + :abstract t) + +(defclass transient-suffix (transient-child) + ((definition :allocation :class :initform nil) + (key :initarg :key) + (command :initarg :command) + (transient :initarg :transient) + (format :initarg :format :initform " %k %d") + (description :initarg :description :initform nil) + (face :initarg :face :initform nil) + (show-help :initarg :show-help :initform nil) + (summary :initarg :summary :initform nil)) + "Superclass for suffix command.") + +(defclass transient-information (transient-suffix) + ((format :initform " %k %d") + (key :initform " ")) + "Display-only information, aligned with suffix keys. +Technically a suffix object with no associated command.") + +(defclass transient-information* (transient-information) + ((format :initform " %d")) + "Display-only information, aligned with suffix descriptions. +Technically a suffix object with no associated command.") + +(defclass transient-infix (transient-suffix) + ((transient :initform t) + (argument :initarg :argument) + (shortarg :initarg :shortarg) + (value :initform nil) + (init-value :initarg :init-value) + (unsavable :initarg :unsavable :initform nil) + (multi-value :initarg :multi-value :initform nil) + (always-read :initarg :always-read :initform nil) + (allow-empty :initarg :allow-empty :initform nil) + (history-key :initarg :history-key :initform nil) + (reader :initarg :reader :initform nil) + (prompt :initarg :prompt :initform nil) + (choices :initarg :choices :initform nil) + (format :initform " %k %d (%v)")) + "Transient infix command." + :abstract t) + +(defclass transient-argument (transient-infix) () + "Abstract superclass for infix arguments." + :abstract t) + +(defclass transient-switch (transient-argument) () + "Class used for command-line argument that can be turned on and off.") + +(defclass transient-option (transient-argument) () + "Class used for command-line argument that can take a value.") + +(defclass transient-variable (transient-infix) + ((variable :initarg :variable) + (format :initform " %k %d %v")) + "Abstract superclass for infix commands that set a variable." + :abstract t) + +(defclass transient-switches (transient-argument) + ((argument-format :initarg :argument-format) + (argument-regexp :initarg :argument-regexp)) + "Class used for sets of mutually exclusive command-line switches.") + +(defclass transient-files (transient-option) () + ((key :initform "--") + (argument :initform "--") + (multi-value :initform rest) + (reader :initform transient-read-files)) + "Class used for the \"--\" argument or similar. +All remaining arguments are treated as files. +They become the value of this argument.") + +(defclass transient-value-preset (transient-suffix) + ((transient :initform t) + (set :initarg := :initform nil)) + "Class used by the `transient-preset' suffix command.") + +;;;; Group + +(defclass transient-group (transient-child) + ((suffixes :initarg :suffixes :initform nil) + (hide :initarg :hide :initform nil) + (description :initarg :description :initform nil) + (pad-keys :initarg :pad-keys :initform nil) + (info-format :initarg :info-format :initform nil) + (setup-children :initarg :setup-children)) + "Abstract superclass of all group classes." + :abstract t) + +(defclass transient-column (transient-group) () + "Group class that displays each element on a separate line.") + +(defclass transient-row (transient-group) () + "Group class that displays all elements on a single line.") + +(defclass transient-columns (transient-group) () + "Group class that displays elements organized in columns. +Direct elements have to be groups whose elements have to be +commands or strings. Each subgroup represents a column. +This class takes care of inserting the subgroups' elements.") + +(defclass transient-subgroups (transient-group) () + "Group class that wraps other groups. + +Direct elements have to be groups whose elements have to be +commands or strings. This group inserts an empty line between +subgroups. The subgroups are responsible for displaying their +elements themselves.") + +;;; Define + +(defmacro transient-define-prefix (name arglist &rest args) + "Define NAME as a transient prefix command. + +ARGLIST are the arguments that command takes. +DOCSTRING is the documentation string and is optional. + +These arguments can optionally be followed by key-value pairs. +Each key has to be a keyword symbol, either `:class' or a keyword +argument supported by the constructor of that class. The +`transient-prefix' class is used if the class is not specified +explicitly. + +GROUPs add key bindings for infix and suffix commands and specify +how these bindings are presented in the popup buffer. At least +one GROUP has to be specified. See info node `(transient)Binding +Suffix and Infix Commands'. + +The BODY is optional. If it is omitted, then ARGLIST is also +ignored and the function definition becomes: + + (lambda () + (interactive) + (transient-setup \\='NAME)) + +If BODY is specified, then it must begin with an `interactive' +form that matches ARGLIST, and it must call `transient-setup'. +It may however call that function only when some condition is +satisfied; that is one of the reason why you might want to use +an explicit BODY. + +All transients have a (possibly nil) value, which is exported +when suffix commands are called, so that they can consume that +value. For some transients it might be necessary to have a sort +of secondary value, called a scope. Such a scope would usually +be set in the commands `interactive' form and has to be passed +to the setup function: + + (transient-setup \\='NAME nil nil :scope SCOPE) + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + [&rest vectorp] + [&optional ("interactive" interactive) def-body])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,suffixes ,docstr ,body ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-prefix))) + `(progn + (defalias ',name + ,(if body + `(lambda ,arglist ,@body) + `(lambda () + (interactive) + (transient-setup ',name)))) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--prefix + (,(or class 'transient-prefix) :command ',name ,@slots)) + (put ',name 'transient--layout + (list ,@(cl-mapcan (lambda (s) (transient--parse-child name s)) + suffixes)))))) + +(defmacro transient-define-suffix (name arglist &rest args) + "Define NAME as a transient suffix command. + +ARGLIST are the arguments that the command takes. +DOCSTRING is the documentation string and is optional. + +These arguments can optionally be followed by key-value pairs. +Each key has to be a keyword symbol, either `:class' or a +keyword argument supported by the constructor of that class. +The `transient-suffix' class is used if the class is not +specified explicitly. + +The BODY must begin with an `interactive' form that matches +ARGLIST. The infix arguments are usually accessed by using +`transient-args' inside `interactive'. + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... [BODY...])" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + [&optional ("interactive" interactive) def-body])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,_ ,docstr ,body ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-suffix))) + `(progn + (defalias ',name + ,(if (and (not body) class (oref-default class definition)) + `(oref-default ',class definition) + `(lambda ,arglist ,@body))) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--suffix + (,(or class 'transient-suffix) :command ',name ,@slots))))) + +(defmacro transient-augment-suffix (name &rest args) + "Augment existing command NAME with a new transient suffix object. +Similar to `transient-define-suffix' but define a suffix object only. +\n\(fn NAME [KEYWORD VALUE]...)" + (declare (debug (&define name [&rest keywordp sexp])) + (indent defun)) + (pcase-let + ((`(,class ,slots) + (transient--expand-define-args args nil 'transient-augment-suffix t))) + `(put ',name 'transient--suffix + (,(or class 'transient-suffix) :command ',name ,@slots)))) + +(defmacro transient-define-infix (name arglist &rest args) + "Define NAME as a transient infix command. + +ARGLIST is always ignored and reserved for future use. +DOCSTRING is the documentation string and is optional. + +At least one key-value pair is required. All transient infix +commands are equal to each other (but not eq). It is meaning- +less to define an infix command, without providing at least one +keyword argument (usually `:argument' or `:variable', depending +on the class). The suffix class defaults to `transient-switch' +and can be set using the `:class' keyword. + +The function definitions is always: + + (lambda () + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) + +`transient-infix-read' and `transient-infix-set' are generic +functions. Different infix commands behave differently because +the concrete methods are different for different infix command +classes. In rare case the above command function might not be +suitable, even if you define your own infix command class. In +that case you have to use `transient-define-suffix' to define +the infix command and use t as the value of the `:transient' +keyword. + +\(fn NAME ARGLIST [DOCSTRING] KEYWORD VALUE [KEYWORD VALUE]...)" + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + keywordp sexp + [&rest keywordp sexp])) + (indent defun) + (doc-string 3)) + (pcase-let + ((`(,class ,slots ,_ ,docstr ,_ ,interactive-only) + (transient--expand-define-args args arglist 'transient-define-infix t))) + `(progn + (defalias ',name #'transient--default-infix-command) + (put ',name 'interactive-only ,interactive-only) + (put ',name 'completion-predicate #'transient--suffix-only) + (put ',name 'function-documentation ,docstr) + (put ',name 'transient--suffix + (,(or class 'transient-switch) :command ',name ,@slots))))) + +(defalias 'transient-define-argument #'transient-define-infix + "Define NAME as a transient infix command. + +Only use this alias to define an infix command that actually +sets an infix argument. To define a infix command that, for +example, sets a variable, use `transient-define-infix' instead. + +\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)") + +(defun transient--default-infix-command () + ;; Most infix commands are but an alias for this command. + "Cannot show any documentation for this transient infix command. + +When you request help for an infix command using `transient-help', that +usually shows the respective man-page and tries to jump to the location +where the respective argument is being described. + +If no man-page is specified for the containing transient menu, then the +docstring is displayed instead, if any. + +If the infix command doesn't have a docstring, as is the case here, then +this docstring is displayed instead, because technically infix commands +are aliases for `transient--default-infix-command'. + +`describe-function' also shows the docstring of the infix command, +falling back to that of the same aliased command." + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) +(put 'transient--default-infix-command 'interactive-only t) +(put 'transient--default-infix-command 'completion-predicate + #'transient--suffix-only) + +(define-advice find-function-advised-original + (:around (fn func) transient-default-infix) + "Return nil instead of `transient--default-infix-command'. +When using `find-function' to jump to the definition of a transient +infix command/argument, then we want to actually jump to that, not to +the definition of `transient--default-infix-command', which all infix +commands are aliases for." + (let ((val (funcall fn func))) + (and val (not (eq val 'transient--default-infix-command)) val))) + +(eval-and-compile ;transient--expand-define-args + (defun transient--expand-define-args (args &optional arglist form nobody) + ;; ARGLIST and FORM are only optional for backward compatibility. + ;; This is necessary because "emoji.el" from Emacs 29 calls this + ;; function directly, with just one argument. + (unless (listp arglist) + (error "Mandatory ARGLIST is missing")) + (let (class keys suffixes docstr declare (interactive-only t)) + (when (stringp (car args)) + (setq docstr (pop args))) + (while (keywordp (car args)) + (let ((k (pop args)) + (v (pop args))) + (if (eq k :class) + (setq class v) + (push k keys) + (push v keys)))) + (while (let ((arg (car args))) + (or (vectorp arg) + (and arg (symbolp arg)))) + (push (pop args) suffixes)) + (when (eq (car-safe (car args)) 'declare) + (setq declare (car args)) + (setq args (cdr args)) + (when-let ((int (assq 'interactive-only declare))) + (setq interactive-only (cadr int)) + (delq int declare)) + (unless (cdr declare) + (setq declare nil))) + (cond + ((not args)) + (nobody + (error "%s: No function body allowed" form)) + ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive)) + (error "%s: Interactive form missing" form))) + (list (if (eq (car-safe class) 'quote) + (cadr class) + class) + (nreverse keys) + (nreverse suffixes) + docstr + (if declare (cons declare args) args) + interactive-only)))) + +(defun transient--parse-child (prefix spec) + (cl-typecase spec + (null (error "Invalid transient--parse-child spec: %s" spec)) + (symbol (let ((value (symbol-value spec))) + (if (and (listp value) + (or (listp (car value)) + (vectorp (car value)))) + (cl-mapcan (lambda (s) (transient--parse-child prefix s)) value) + (transient--parse-child prefix value)))) + (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) + (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) + (string (list spec)) + (t (error "Invalid transient--parse-child spec: %s" spec)))) + +(defun transient--parse-group (prefix spec) + (let ((spec (append spec nil)) + level class args) + (when (integerp (car spec)) + (setq level (pop spec))) + (when (stringp (car spec)) + (setq args (plist-put args :description (pop spec)))) + (while (keywordp (car spec)) + (let* ((key (pop spec)) + (val (if spec (pop spec) (error "No value for `%s'" key)))) + (cond ((eq key :class) + (setq class val)) + ((or (symbolp val) + (and (listp val) (not (eq (car val) 'lambda)))) + (setq args (plist-put args key (macroexp-quote val)))) + ((setq args (plist-put args key val)))))) + (unless (or spec class (not (plist-get args :setup-children))) + (message "WARNING: %s: When %s is used, %s must also be specified" + 'transient-define-prefix :setup-children :class)) + (list 'vector + (or level transient--default-child-level) + (list 'quote + (cond (class) + ((cl-typep (car spec) + '(or vector (and symbol (not null)))) + 'transient-columns) + ('transient-column))) + (and args (cons 'list args)) + (cons 'list + (cl-mapcan (lambda (s) (transient--parse-child prefix s)) + spec))))) + +(defun transient--parse-suffix (prefix spec) + (let (level class args) + (cl-flet ((use (prop value) + (setq args (plist-put args prop value)))) + (pcase (car spec) + ((cl-type integer) + (setq level (pop spec)))) + (pcase (car spec) + ((cl-type (or string vector)) + (use :key (pop spec)))) + (pcase (car spec) + ((guard (or (stringp (car spec)) + (and (eq (car-safe (car spec)) 'lambda) + (not (commandp (car spec)))))) + (use :description (pop spec))) + ((and (cl-type (and symbol (not keyword) (not command))) + (guard (commandp (cadr spec)))) + (use :description (macroexp-quote (pop spec))))) + (pcase (car spec) + ((or :info :info*)) + ((and (cl-type keyword) invalid) + (error "Need command, argument, `:info' or `:info*'; got `%s'" invalid)) + ((cl-type symbol) + (use :command (macroexp-quote (pop spec)))) + ;; During macro-expansion this is expected to be a `lambda' + ;; expression (i.e., source code). When this is called from a + ;; `:setup-children' function, it may also be a function object + ;; (a.k.a a function value). However, we never treat a string + ;; as a command, so we have to check for that explicitly. + ((cl-type (and command (not string))) + (let ((cmd (pop spec)) + (sym (intern + (format + "transient:%s:%s:%d" prefix + (replace-regexp-in-string (plist-get args :key) " " "") + (prog1 gensym-counter (cl-incf gensym-counter)))))) + (use :command + `(prog1 ',sym + (put ',sym 'interactive-only t) + (put ',sym 'completion-predicate #'transient--suffix-only) + (defalias ',sym ,cmd))))) + ((cl-type (or string (and list (not null)))) + (let ((arg (pop spec))) + (cl-typecase arg + (list + (use :shortarg (car arg)) + (use :argument (cadr arg)) + (setq arg (cadr arg))) + (string + (when-let ((shortarg (transient--derive-shortarg arg))) + (use :shortarg shortarg)) + (use :argument arg))) + (use :command + (let ((sym (intern (format "transient:%s:%s" prefix arg)))) + `(prog1 ',sym + (put ',sym 'interactive-only t) + (put ',sym 'completion-predicate #'transient--suffix-only) + (defalias ',sym #'transient--default-infix-command)))) + (pcase (car spec) + ((cl-type (and (not null) (not keyword))) + (setq class 'transient-option) + (use :reader (macroexp-quote (pop spec)))) + ((guard (string-suffix-p "=" arg)) + (setq class 'transient-option)) + (_ (setq class 'transient-switch))))) + (invalid + (error "Need command, argument, `:info' or `:info*'; got %s" invalid))) + (while (keywordp (car spec)) + (let* ((key (pop spec)) + (val (if spec (pop spec) (error "No value for `%s'" key)))) + (pcase key + (:class (setq class val)) + (:level (setq level val)) + (:info (setq class 'transient-information) + (use :description val)) + (:info* (setq class 'transient-information*) + (use :description val)) + ((guard (eq (car-safe val) '\,)) + (use key (cadr val))) + ((guard (or (symbolp val) + (and (listp val) (not (eq (car val) 'lambda))))) + (use key (macroexp-quote val))) + (_ (use key val))))) + (when spec + (error "Need keyword, got %S" (car spec))) + (when-let* (((not (plist-get args :key))) + (shortarg (plist-get args :shortarg))) + (use :key shortarg))) + (list 'list + (or level transient--default-child-level) + (macroexp-quote (or class 'transient-suffix)) + (cons 'list args)))) + +(defun transient--derive-shortarg (arg) + (save-match-data + (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) + (match-string 1 arg)))) + +(defun transient-command-completion-not-suffix-only-p (symbol _buffer) + "Say whether SYMBOL should be offered as a completion. +If the value of SYMBOL's `completion-predicate' property is +`transient--suffix-only', then return nil, otherwise return t. +This is the case when a command should only ever be used as a +suffix of a transient prefix command (as opposed to bindings +in regular keymaps or by using `execute-extended-command')." + (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) + +(defalias 'transient--suffix-only #'ignore + "Ignore ARGUMENTS, do nothing, and return nil. +Also see `transient-command-completion-not-suffix-only-p'. +Only use this alias as the value of the `completion-predicate' +symbol property.") + +(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 + (not read-extended-command-predicate)) + (setq read-extended-command-predicate + #'transient-command-completion-not-suffix-only-p)) + +(defun transient-parse-suffix (prefix suffix) + "Parse SUFFIX, to be added to PREFIX. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) + (eval (car (transient--parse-child prefix suffix)) t)) + +(defun transient-parse-suffixes (prefix suffixes) + "Parse SUFFIXES, to be added to PREFIX. +PREFIX is a prefix command, a symbol. +SUFFIXES is a list of suffix command or a group specification + (of the same forms as expected by `transient-define-prefix'). +Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) + (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) + +;;; Edit + +(defun transient--insert-suffix (prefix loc suffix action &optional keep-other) + (let* ((suf (cl-etypecase suffix + (vector (transient--parse-group prefix suffix)) + (list (transient--parse-suffix prefix suffix)) + (string suffix))) + (mem (transient--layout-member loc prefix)) + (elt (car mem))) + (setq suf (eval suf t)) + (cond + ((not mem) + (message "Cannot insert %S into %s; %s not found" + suffix prefix loc)) + ((or (and (vectorp suffix) (not (vectorp elt))) + (and (listp suffix) (vectorp elt)) + (and (stringp suffix) (vectorp elt))) + (message "Cannot place %S into %s at %s; %s" + suffix prefix loc + "suffixes and groups cannot be siblings")) + (t + (when-let* ((bindingp (listp suf)) + (key (transient--spec-key suf)) + (conflict (car (transient--layout-member key prefix))) + (conflictp + (and (not (and (eq action 'replace) + (eq conflict elt))) + (or (not keep-other) + (eq (plist-get (nth 2 suf) :command) + (plist-get (nth 2 conflict) :command))) + (equal (transient--suffix-predicate suf) + (transient--suffix-predicate conflict))))) + (transient-remove-suffix prefix key)) + (pcase-exhaustive action + ('insert (setcdr mem (cons elt (cdr mem))) + (setcar mem suf)) + ('append (setcdr mem (cons suf (cdr mem)))) + ('replace (setcar mem suf))))))) + +;;;###autoload +(defun transient-insert-suffix (prefix loc suffix &optional keep-other) + "Insert a SUFFIX into PREFIX before LOC. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'insert keep-other)) + +;;;###autoload +(defun transient-append-suffix (prefix loc suffix &optional keep-other) + "Insert a SUFFIX into PREFIX after LOC. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'append keep-other)) + +;;;###autoload +(defun transient-replace-suffix (prefix loc suffix) + "Replace the suffix at LOC in PREFIX with SUFFIX. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--insert-suffix prefix loc suffix 'replace)) + +;;;###autoload +(defun transient-remove-suffix (prefix loc) + "Remove the suffix or group at LOC in PREFIX. +PREFIX is a prefix command, a symbol. +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (declare (indent defun)) + (transient--layout-member loc prefix 'remove)) + +(defun transient-get-suffix (prefix loc) + "Return the suffix or group at LOC in PREFIX. +PREFIX is a prefix command, a symbol. +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (if-let ((mem (transient--layout-member loc prefix))) + (car mem) + (error "%s not found in %s" loc prefix))) + +(defun transient-suffix-put (prefix loc prop value) + "Edit the suffix at LOC in PREFIX, setting PROP to VALUE. +PREFIX is a prefix command, a symbol. +SUFFIX is a suffix command or a group specification (of + the same forms as expected by `transient-define-prefix'). +LOC is a command, a key vector, a key description (a string + as returned by `key-description'), or a coordination list + (whose last element may also be a command or key). +See info node `(transient)Modifying Existing Transients'." + (let ((suf (transient-get-suffix prefix loc))) + (setf (elt suf 2) + (plist-put (elt suf 2) prop value)))) + +(defun transient--layout-member (loc prefix &optional remove) + (let ((val (or (get prefix 'transient--layout) + (error "%s is not a transient command" prefix)))) + (when (listp loc) + (while (integerp (car loc)) + (let* ((children (if (vectorp val) (aref val 3) val)) + (mem (transient--nthcdr (pop loc) children))) + (if (and remove (not loc)) + (let ((rest (delq (car mem) children))) + (if (vectorp val) + (aset val 3 rest) + (put prefix 'transient--layout rest)) + (setq val nil)) + (setq val (if loc (car mem) mem))))) + (setq loc (car loc))) + (if loc + (transient--layout-member-1 (transient--kbd loc) val remove) + val))) + +(defun transient--layout-member-1 (loc layout remove) + (cond ((listp layout) + (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove)) + layout)) + ((vectorp (car (aref layout 3))) + (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove)) + (aref layout 3))) + (remove + (aset layout 3 + (delq (car (transient--group-member loc layout)) + (aref layout 3))) + nil) + ((transient--group-member loc layout)))) + +(defun transient--group-member (loc group) + (cl-member-if (lambda (suffix) + (and (listp suffix) + (let* ((def (nth 2 suffix)) + (cmd (plist-get def :command))) + (if (symbolp loc) + (eq cmd loc) + (equal (transient--kbd + (or (plist-get def :key) + (transient--command-key cmd))) + loc))))) + (aref group 3))) + +(defun transient--kbd (keys) + (when (vectorp keys) + (setq keys (key-description keys))) + (when (stringp keys) + (setq keys (kbd keys))) + keys) + +(defun transient--spec-key (spec) + (let ((plist (nth 2 spec))) + (or (plist-get plist :key) + (transient--command-key + (plist-get plist :command))))) + +(defun transient--command-key (cmd) + (and-let* ((obj (transient--suffix-prototype cmd))) + (cond ((slot-boundp obj 'key) + (oref obj key)) + ((slot-exists-p obj 'shortarg) + (if (slot-boundp obj 'shortarg) + (oref obj shortarg) + (transient--derive-shortarg (oref obj argument))))))) + +(defun transient--nthcdr (n list) + (nthcdr (if (< n 0) (- (length list) (abs n)) n) list)) + +;;; Variables + +(defvar transient-current-prefix nil + "The transient from which this suffix command was invoked. +This is an object representing that transient, use +`transient-current-command' to get the respective command.") + +(defvar transient-current-command nil + "The transient from which this suffix command was invoked. +This is a symbol representing that transient, use +`transient-current-prefix' to get the respective object.") + +(defvar transient-current-suffixes nil + "The suffixes of the transient from which this suffix command was invoked. +This is a list of objects. Usually it is sufficient to instead +use the function `transient-args', which returns a list of +values. In complex cases it might be necessary to use this +variable instead.") + +(defvar transient-exit-hook nil + "Hook run after exiting a transient.") + +(defvar transient-setup-buffer-hook nil + "Hook run when setting up the transient buffer. +That buffer is current and empty when this hook runs.") + +(defvar transient--prefix nil) +(defvar transient--layout nil) +(defvar transient--suffixes nil) + +(defconst transient--stay t "Do not exit the transient.") +(defconst transient--exit nil "Do exit the transient.") + +(defvar transient--exitp nil "Whether to exit the transient.") +(defvar transient--showp nil "Whether to show the transient popup buffer.") +(defvar transient--helpp nil "Whether help-mode is active.") +(defvar transient--editp nil "Whether edit-mode is active.") + +(defvar transient--refreshp nil + "Whether to refresh the transient completely.") + +(defvar transient--all-levels-p nil + "Whether temporary display of suffixes on all levels is active.") + +(defvar transient--timer nil) + +(defvar transient--stack nil) + +(defvar transient--minibuffer-depth 0) + +(defvar transient--buffer-name " *transient*" + "Name of the transient buffer.") + +(defvar transient--buffer nil + "The transient menu buffer.") + +(defvar transient--window nil + "The window used to display the transient popup buffer.") + +(defvar transient--original-window nil + "The window that was selected before the transient was invoked. +Usually it remains selected while the transient is active.") + +(defvar transient--original-buffer nil + "The buffer that was current before the transient was invoked. +Usually it remains current while the transient is active.") + +(defvar transient--restore-winconf nil + "Window configuration to restore after exiting help.") + +(defvar transient--shadowed-buffer nil + "The buffer that is temporarily shadowed by the transient buffer. +This is bound while the suffix predicate is being evaluated and while +drawing in the transient buffer.") + +(defvar transient--pending-suffix nil + "The suffix that is currently being processed. +This is bound while the suffix predicate is being evaluated, +and while functions that return faces are being evaluated.") + +(defvar transient--pending-group nil + "The group that is currently being processed. +This is bound while the suffixes are drawn in the transient buffer.") + +(defvar transient--debug nil + "Whether to put debug information into *Messages*.") + +(defvar transient--history nil) + +(defvar transient--scroll-commands + '(transient-scroll-up + transient-scroll-down + mwheel-scroll + scroll-bar-toolkit-scroll)) + +;;; Identities + +(defun transient-active-prefix (&optional prefixes) + "Return the active transient object. + +Return nil if there is no active transient, if the transient buffer +isn't shown, and while the active transient is suspended (e.g., while +the minibuffer is in use). + +Unlike `transient-current-prefix', which is only ever non-nil in code +that is run directly by a command that is invoked while a transient +is current, this function is also suitable for use in asynchronous +code, such as timers and callbacks (this function's main use-case). + +If optional PREFIXES is non-nil, it must be a prefix command symbol +or a list of symbols, in which case the active transient object is +only returned if it matches one of PREFIXES." + (and transient--showp + transient--prefix + (or (not prefixes) + (memq (oref transient--prefix command) (ensure-list prefixes))) + (or (memq 'transient--pre-command pre-command-hook) + (and (memq t pre-command-hook) + (memq 'transient--pre-command + (default-value 'pre-command-hook)))) + transient--prefix)) + +(defun transient-prefix-object () + "Return the current prefix as an object. + +While a transient is being setup or refreshed (which involves +preparing its suffixes) the variable `transient--prefix' can be +used to access the prefix object. Thus this is what has to be +used in suffix methods such as `transient-format-description', +and in object-specific functions that are stored in suffix slots +such as `description'. + +When a suffix command is invoked (i.e., in its `interactive' form +and function body) then the variable `transient-current-prefix' +has to be used instead. + +Two distinct variables are needed, because any prefix may itself +be used as a suffix of another prefix, and such sub-prefixes have +to be able to tell themselves apart from the prefix they were +invoked from. + +Regular suffix commands, which are not prefixes, do not have to +concern themselves with this distinction, so they can use this +function instead. In the context of a plain suffix, it always +returns the value of the appropriate variable." + (or transient--prefix transient-current-prefix)) + +(defun transient-suffix-object (&optional command) + "Return the object associated with the current suffix command. + +Each suffix commands is associated with an object, which holds +additional information about the suffix, such as its value (in +the case of an infix command, which is a kind of suffix command). + +This function is intended to be called by infix commands, which +are usually aliases of `transient--default-infix-command', which +is defined like this: + + (defun transient--default-infix-command () + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) + +\(User input is read outside of `interactive' to prevent the +command from being added to `command-history'. See #23.) + +Such commands need to be able to access their associated object +to guide how `transient-infix-read' reads the new value and to +store the read value. Other suffix commands (including non-infix +commands) may also need the object to guide their behavior. + +This function attempts to return the object associated with the +current suffix command even if the suffix command was not invoked +from a transient. (For some suffix command that is a valid thing +to do, for others it is not.) In that case nil may be returned, +if the command was not defined using one of the macros intended +to define such commands. + +The optional argument COMMAND is intended for internal use. If +you are contemplating using it in your own code, then you should +probably use this instead: + + (get COMMAND \\='transient--suffix)" + (when command + (cl-check-type command command)) + (cond + (transient--pending-suffix) + ((or transient--prefix + transient-current-prefix) + (let ((suffixes + (cl-remove-if-not + (lambda (obj) + (eq (oref obj command) + (or command + (if (eq this-command 'transient-set-level) + ;; This is how it can look up for which + ;; command it is setting the level. + this-original-command + this-command)))) + (or transient--suffixes + transient-current-suffixes)))) + (or (if (cdr suffixes) + (cl-find-if + (lambda (obj) + (equal (listify-key-sequence (transient--kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes) + (car suffixes)) + ;; COMMAND is only provided if `this-command' is meaningless, in + ;; which case `this-command-keys' is also meaningless, making it + ;; impossible to disambiguate redundant bindings. + (if command + (car suffixes) + (error "BUG: Cannot determine suffix object"))))) + ((and-let* ((obj (transient--suffix-prototype (or command this-command))) + (obj (clone obj))) + (progn ; work around debbugs#31840 + (transient-init-scope obj) + (transient-init-value obj) + obj))))) + +(defun transient--suffix-prototype (command) + (or (get command 'transient--suffix) + (seq-some (lambda (cmd) (get cmd 'transient--suffix)) + (function-alias-p command)))) + +;;; Keymaps + +(defvar-keymap transient-base-map + :doc "Parent of other keymaps used by Transient. + +This is the parent keymap of all the keymaps that are used in +all transients: `transient-map' (which in turn is the parent +of the transient-specific keymaps), `transient-edit-map' and +`transient-sticky-map'. + +If you change a binding here, then you might also have to edit +`transient-sticky-map' and `transient-common-commands'. While +the latter isn't a proper transient prefix command, it can be +edited using the same functions as used for transients. + +If you add a new command here, then you must also add a binding +to `transient-predicate-map'." + "ESC ESC ESC" #'transient-quit-all + "C-g" #'transient-quit-one + "C-q" #'transient-quit-all + "C-z" #'transient-suspend + "C-v" #'transient-scroll-up + "C-M-v" #'transient-scroll-down + "<next>" #'transient-scroll-up + "<prior>" #'transient-scroll-down) + +(defvar transient-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map transient-base-map) + (keymap-set map "C-u" #'universal-argument) + (keymap-set map "C--" #'negative-argument) + (keymap-set map "C-t" #'transient-show) + (keymap-set map "?" #'transient-help) + (keymap-set map "C-h" #'transient-help) + ;; Also bound to "C-x p" and "C-x n" in transient-common-commands. + (keymap-set map "C-M-p" #'transient-history-prev) + (keymap-set map "C-M-n" #'transient-history-next) + (when (fboundp 'other-frame-prefix) ;Emacs >= 28.1 + (keymap-set map "C-x 5 5" 'other-frame-prefix) + (keymap-set map "C-x 4 4" 'other-window-prefix)) + map) + "Top-level keymap used by all transients. + +If you add a new command here, then you must also add a binding +to `transient-predicate-map'. Also see `transient-base-map'.") + +(defvar-keymap transient-edit-map + :doc "Keymap that is active while a transient in is in \"edit mode\"." + :parent transient-base-map + "?" #'transient-help + "C-h" #'transient-help + "C-x l" #'transient-set-level) + +(defvar-keymap transient-sticky-map + :doc "Keymap that is active while an incomplete key sequence is active." + :parent transient-base-map + "C-g" #'transient-quit-seq) + +(defvar transient--common-command-prefixes '(?\C-x)) + +(put 'transient-common-commands + 'transient--layout + (list + (eval + (car (transient--parse-child + 'transient-common-commands + (vector + :hide + (lambda () + (and (not (memq + (car (bound-and-true-p transient--redisplay-key)) + transient--common-command-prefixes)) + (not transient-show-common-commands))) + (vector + "Value commands" + (list "C-x s " "Set" #'transient-set) + (list "C-x C-s" "Save" #'transient-save) + (list "C-x C-k" "Reset" #'transient-reset) + (list "C-x p " "Previous value" #'transient-history-prev) + (list "C-x n " "Next value" #'transient-history-next)) + (vector + "Sticky commands" + ;; Like `transient-sticky-map' except that + ;; "C-g" has to be bound to a different command. + (list "C-g" "Quit prefix or transient" #'transient-quit-one) + (list "C-q" "Quit transient stack" #'transient-quit-all) + (list "C-z" "Suspend transient stack" #'transient-suspend)) + (vector + "Customize" + (list "C-x t" 'transient-toggle-common :description + (lambda () + (if transient-show-common-commands + "Hide common commands" + "Show common permanently"))) + (list "C-x l" "Show/hide suffixes" #'transient-set-level) + (list "C-x a" #'transient-toggle-level-limit))))) + t))) + +(defvar-keymap transient-popup-navigation-map + :doc "One of the keymaps used when popup navigation is enabled. +See `transient-enable-popup-navigation'." + "<down-mouse-1>" #'transient-noop + "<up>" #'transient-backward-button + "<down>" #'transient-forward-button + "C-r" #'transient-isearch-backward + "C-s" #'transient-isearch-forward + "M-RET" #'transient-push-button) + +(defvar-keymap transient-button-map + :doc "One of the keymaps used when popup navigation is enabled. +See `transient-enable-popup-navigation'." + "<mouse-1>" #'transient-push-button + "<mouse-2>" #'transient-push-button) + +(defvar-keymap transient-resume-mode-map + :doc "Keymap for `transient-resume-mode'. + +This keymap remaps every command that would usually just quit the +documentation buffer to `transient-resume', which additionally +resumes the suspended transient." + "<remap> <Man-quit>" #'transient-resume + "<remap> <Info-exit>" #'transient-resume + "<remap> <quit-window>" #'transient-resume) + +(defvar-keymap transient-predicate-map + :doc "Base keymap used to map common commands to their transient behavior. + +The \"transient behavior\" of a command controls, among other +things, whether invoking the command causes the transient to be +exited or not, and whether infix arguments are exported before +doing so. + +Each \"key\" is a command that is common to all transients and +that is bound in `transient-map', `transient-edit-map', +`transient-sticky-map' and/or `transient-common-command'. + +Each binding is a \"pre-command\", a function that controls the +transient behavior of the respective command. + +For transient commands that are bound in individual transients, +the transient behavior is specified using the `:transient' slot +of the corresponding object." + "<transient-suspend>" #'transient--do-suspend + "<transient-help>" #'transient--do-stay + "<transient-set-level>" #'transient--do-stay + "<transient-history-prev>" #'transient--do-stay + "<transient-history-next>" #'transient--do-stay + "<universal-argument>" #'transient--do-stay + "<universal-argument-more>" #'transient--do-stay + "<negative-argument>" #'transient--do-minus + "<digit-argument>" #'transient--do-stay + "<other-frame-prefix>" #'transient--do-stay + "<other-window-prefix>" #'transient--do-stay + "<top-level>" #'transient--do-quit-all + "<transient-quit-all>" #'transient--do-quit-all + "<transient-quit-one>" #'transient--do-quit-one + "<transient-quit-seq>" #'transient--do-stay + "<transient-show>" #'transient--do-stay + "<transient-update>" #'transient--do-stay + "<transient-toggle-common>" #'transient--do-stay + "<transient-set>" #'transient--do-call + "<transient-set-and-exit>" #'transient--do-exit + "<transient-save>" #'transient--do-call + "<transient-save-and-exit>" #'transient--do-exit + "<transient-reset>" #'transient--do-call + "<describe-key-briefly>" #'transient--do-stay + "<describe-key>" #'transient--do-stay + "<transient-scroll-up>" #'transient--do-stay + "<transient-scroll-down>" #'transient--do-stay + "<mwheel-scroll>" #'transient--do-stay + "<scroll-bar-toolkit-scroll>" #'transient--do-stay + "<transient-noop>" #'transient--do-noop + "<transient-mouse-push-button>" #'transient--do-move + "<transient-push-button>" #'transient--do-push-button + "<transient-backward-button>" #'transient--do-move + "<transient-forward-button>" #'transient--do-move + "<transient-isearch-backward>" #'transient--do-move + "<transient-isearch-forward>" #'transient--do-move + ;; If a valid but incomplete prefix sequence is followed by + ;; an unbound key, then Emacs calls the `undefined' command + ;; but does not set `this-command', `this-original-command' + ;; or `real-this-command' accordingly. Instead they are nil. + "<nil>" #'transient--do-warn + ;; Bound to the `mouse-movement' event, this command is similar + ;; to `ignore'. + "<ignore-preserving-kill-region>" #'transient--do-noop) + +(defvar transient--transient-map nil) +(defvar transient--predicate-map nil) +(defvar transient--redisplay-map nil) +(defvar transient--redisplay-key nil) + +(defun transient--push-keymap (var) + (let ((map (symbol-value var))) + (transient--debug " push %s%s" var (if map "" " VOID")) + (when map + (with-demoted-errors "transient--push-keymap: %S" + (internal-push-keymap map 'overriding-terminal-local-map))))) + +(defun transient--pop-keymap (var) + (let ((map (symbol-value var))) + (when map + (transient--debug " pop %s" var) + (with-demoted-errors "transient--pop-keymap: %S" + (internal-pop-keymap map 'overriding-terminal-local-map))))) + +(defun transient--make-transient-map () + (let ((map (make-sparse-keymap))) + (set-keymap-parent map (if transient--editp + transient-edit-map + transient-map)) + (dolist (obj transient--suffixes) + (let ((key (oref obj key))) + (when (vectorp key) + (setq key (key-description key)) + (oset obj key key)) + (when transient-substitute-key-function + (setq key (save-match-data + (funcall transient-substitute-key-function obj))) + (oset obj key key)) + (let* ((kbd (kbd key)) + (cmd (oref obj command)) + (alt (transient--lookup-key map kbd))) + (cond ((not alt) + (define-key map kbd cmd)) + ((eq alt cmd)) + ((transient--inapt-suffix-p obj)) + ((and-let* ((obj (transient-suffix-object alt))) + (transient--inapt-suffix-p obj)) + (define-key map kbd cmd)) + (transient-detect-key-conflicts + (error "Cannot bind %S to %s and also %s" + (string-trim key) cmd alt)) + ((define-key map kbd cmd)))))) + (when-let ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) + (when-let ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) + (when-let ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) + (when transient-enable-popup-navigation + ;; `transient--make-redisplay-map' maps only over bindings that are + ;; directly in the base keymap, so that cannot be a composed keymap. + (set-keymap-parent + map (make-composed-keymap + (keymap-parent map) + transient-popup-navigation-map))) + map)) + +(defun transient--make-predicate-map () + (let* ((default (transient--resolve-pre-command + (oref transient--prefix transient-suffix))) + (return (and transient--stack (eq default t))) + (map (make-sparse-keymap))) + (set-keymap-parent map transient-predicate-map) + (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) + (transient--resolve-pre-command + (not (oref transient--prefix transient-switch-frame)))) + (memq (transient--resolve-pre-command + (oref transient--prefix transient-non-suffix)) + '(nil transient--do-warn transient--do-noop))) + (define-key map [handle-switch-frame] #'transient--do-suspend)) + (dolist (obj transient--suffixes) + (let* ((cmd (oref obj command)) + (kind (cond ((get cmd 'transient--prefix) 'prefix) + ((cl-typep obj 'transient-infix) 'infix) + (t 'suffix)))) + (cond + ((oref obj inapt) + (define-key map (vector cmd) #'transient--do-warn-inapt)) + ((slot-boundp obj 'transient) + (define-key map (vector cmd) + (pcase (list kind + (transient--resolve-pre-command (oref obj transient)) + return) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix nil ,_) #'transient--do-stack) + (`(infix t ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(,_ nil ,_) #'transient--do-exit) + (`(,_ ,do ,_) do)))) + ((not (lookup-key transient-predicate-map (vector cmd))) + (define-key map (vector cmd) + (pcase (list kind default return) + (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_) + #'transient--do-recurse) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix ,_ ,_) #'transient--do-stack) + (`(infix ,_ ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(suffix nil ,_) #'transient--do-exit) + (`(suffix ,do ,_) do))))))) + map)) + +(defun transient--make-redisplay-map () + (setq transient--redisplay-key + (pcase this-command + ('transient-update + (setq transient--showp t) + (let ((keys (listify-key-sequence (this-single-command-raw-keys)))) + (setq unread-command-events (mapcar (lambda (key) (cons t key)) keys)) + keys)) + ('transient-quit-seq + (setq unread-command-events + (butlast (listify-key-sequence + (this-single-command-raw-keys)) + 2)) + (butlast transient--redisplay-key)) + (_ nil))) + (let ((topmap (make-sparse-keymap)) + (submap (make-sparse-keymap))) + (when transient--redisplay-key + (define-key topmap (vconcat transient--redisplay-key) submap) + (set-keymap-parent submap transient-sticky-map)) + (map-keymap-internal + (lambda (key def) + (when (and (not (eq key ?\e)) + (listp def) + (keymapp def)) + (define-key topmap (vconcat transient--redisplay-key (list key)) + #'transient-update))) + (if transient--redisplay-key + (let ((key (vconcat transient--redisplay-key))) + (or (lookup-key transient--transient-map key) + (and-let* ((regular (lookup-key local-function-key-map key))) + (lookup-key transient--transient-map (vconcat regular))))) + transient--transient-map)) + topmap)) + +;;; Setup + +(defun transient-setup (&optional name layout edit &rest params) + "Setup the transient specified by NAME. + +This function is called by transient prefix commands to setup the +transient. In that case NAME is mandatory, LAYOUT and EDIT must +be nil and PARAMS may be (but usually is not) used to set, e.g., +the \"scope\" of the transient (see `transient-define-prefix'). + +This function is also called internally, in which case LAYOUT and +EDIT may be non-nil." + (transient--debug 'setup) + (transient--with-emergency-exit :setup + (cond + ((not name) + ;; Switching between regular and edit mode. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (setq name (oref transient--prefix command)) + (setq params (list :scope (oref transient--prefix scope)))) + (transient--prefix + ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}" + ;; of an outer prefix. Unlike the usual `transient--do-stack', + ;; these predicates fail to clean up after the outer prefix. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map)) + ((not (or layout ; resuming parent/suspended prefix + transient-current-command)) ; entering child prefix + (transient--stack-zap)) ; replace suspended prefix, if any + (edit + ;; Returning from help to edit. + (setq transient--editp t))) + (transient--env-apply + (lambda () + (transient--init-transient name layout params) + (transient--history-init transient--prefix) + (setq transient--original-window (selected-window)) + (setq transient--original-buffer (current-buffer)) + (setq transient--minibuffer-depth (minibuffer-depth)) + (transient--redisplay)) + (get name 'transient--prefix)) + (transient--setup-transient) + (transient--suspend-which-key-mode))) + +(cl-defgeneric transient-setup-children (group children) + "Setup the CHILDREN of GROUP. +If the value of the `setup-children' slot is non-nil, then call +that function with CHILDREN as the only argument and return the +value. Otherwise return CHILDREN as is." + (if (slot-boundp group 'setup-children) + (funcall (oref group setup-children) children) + children)) + +(defun transient--env-apply (fn &optional prefix) + (if-let ((env (oref (or prefix transient--prefix) environment))) + (funcall env fn) + (funcall fn))) + +(defun transient--init-transient (&optional name layout params) + (unless name + ;; Re-init. + (if (eq transient--refreshp 'updated-value) + ;; Preserve the prefix value this once, because the + ;; invoked suffix indicates that it has updated that. + (setq transient--refreshp (oref transient--prefix refresh-suffixes)) + ;; Otherwise update the prefix value from suffix values. + (oset transient--prefix value (transient-get-value)))) + (transient--init-objects name layout params) + (transient--init-keymaps)) + +(defun transient--init-keymaps () + (setq transient--predicate-map (transient--make-predicate-map)) + (setq transient--transient-map (transient--make-transient-map)) + (setq transient--redisplay-map (transient--make-redisplay-map))) + +(defun transient--init-objects (&optional name layout params) + (if name + (setq transient--prefix (transient--init-prefix name params)) + (setq name (oref transient--prefix command))) + (setq transient--refreshp (oref transient--prefix refresh-suffixes)) + (setq transient--layout (or (and (not transient--refreshp) layout) + (transient--init-suffixes name))) + (setq transient--suffixes (transient--flatten-suffixes transient--layout))) + +(defun transient--init-prefix (name &optional params) + (let ((obj (let ((proto (get name 'transient--prefix))) + (apply #'clone proto + :prototype proto + :level (or (alist-get t (alist-get name transient-levels)) + transient-default-level) + params)))) + (transient--setup-recursion obj) + (transient-init-value obj) + obj)) + +(defun transient--init-suffixes (name) + (let ((levels (alist-get name transient-levels))) + (cl-mapcan (lambda (c) (transient--init-child levels c nil)) + (append (get name 'transient--layout) + (and (not transient--editp) + (get 'transient-common-commands + 'transient--layout)))))) + +(defun transient--flatten-suffixes (layout) + (cl-labels ((s (def) + (cond + ((stringp def) nil) + ((cl-typep def 'transient-information) nil) + ((listp def) (cl-mapcan #'s def)) + ((cl-typep def 'transient-group) + (cl-mapcan #'s (oref def suffixes))) + ((cl-typep def 'transient-suffix) + (list def))))) + (cl-mapcan #'s layout))) + +(defun transient--init-child (levels spec parent) + (cl-etypecase spec + (vector (transient--init-group levels spec parent)) + (list (transient--init-suffix levels spec parent)) + (string (list spec)))) + +(defun transient--init-group (levels spec parent) + (pcase-let ((`(,level ,class ,args ,children) (append spec nil))) + (and-let* (((transient--use-level-p level)) + (obj (apply class :level level args)) + ((transient--use-suffix-p obj)) + ((prog1 t + (when (or (and parent (oref parent inapt)) + (transient--inapt-suffix-p obj)) + (oset obj inapt t)))) + (suffixes (cl-mapcan + (lambda (c) (transient--init-child levels c obj)) + (transient-setup-children obj children)))) + (progn ; work around debbugs#31840 + (oset obj suffixes suffixes) + (list obj))))) + +(defun transient--init-suffix (levels spec parent) + (pcase-let* ((`(,level ,class ,args) spec) + (cmd (plist-get args :command)) + (key (transient--kbd (plist-get args :key))) + (level (or (alist-get (cons cmd key) levels nil nil #'equal) + (alist-get cmd levels) + level))) + (let ((fn (and (symbolp cmd) + (symbol-function cmd)))) + (when (autoloadp fn) + (transient--debug " autoload %s" cmd) + (autoload-do-load fn))) + (when (transient--use-level-p level) + (let ((obj (if (child-of-class-p class 'transient-information) + (apply class :level level args) + (unless (and cmd (symbolp cmd)) + (error "BUG: Non-symbolic suffix command: %s" cmd)) + (if-let ((proto (and cmd (transient--suffix-prototype cmd)))) + (apply #'clone proto :level level args) + (apply class :command cmd :level level args))))) + (cond ((not cmd)) + ((commandp cmd)) + ((or (cl-typep obj 'transient-switch) + (cl-typep obj 'transient-option)) + ;; As a temporary special case, if the package was compiled + ;; with an older version of Transient, then we must define + ;; "anonymous" switch and option commands here. + (defalias cmd #'transient--default-infix-command)) + ((transient--use-suffix-p obj) + (error "Suffix command %s is not defined or autoloaded" cmd))) + (unless (cl-typep obj 'transient-information) + (transient--init-suffix-key obj)) + (when (transient--use-suffix-p obj) + (if (or (and parent (oref parent inapt)) + (transient--inapt-suffix-p obj)) + (oset obj inapt t) + (transient-init-scope obj) + (transient-init-value obj)) + (list obj)))))) + +(cl-defmethod transient--init-suffix-key ((obj transient-suffix)) + (unless (slot-boundp obj 'key) + (error "No key for %s" (oref obj command)))) + +(cl-defmethod transient--init-suffix-key ((obj transient-argument)) + (if (transient-switches--eieio-childp obj) + (cl-call-next-method obj) + (when-let* (((not (slot-boundp obj 'shortarg))) + (shortarg (transient--derive-shortarg (oref obj argument)))) + (oset obj shortarg shortarg)) + (unless (slot-boundp obj 'key) + (if (slot-boundp obj 'shortarg) + (oset obj key (oref obj shortarg)) + (error "No key for %s" (oref obj command)))))) + +(defun transient--use-level-p (level &optional edit) + (or transient--all-levels-p + (and transient--editp (not edit)) + (and (>= level 1) + (<= level (oref transient--prefix level))))) + +(defun transient--use-suffix-p (obj) + (let ((transient--shadowed-buffer (current-buffer)) + (transient--pending-suffix obj)) + (transient--do-suffix-p + (oref obj if) + (oref obj if-not) + (oref obj if-nil) + (oref obj if-non-nil) + (oref obj if-mode) + (oref obj if-not-mode) + (oref obj if-derived) + (oref obj if-not-derived) + t))) + +(defun transient--inapt-suffix-p (obj) + (let ((transient--shadowed-buffer (current-buffer)) + (transient--pending-suffix obj)) + (transient--do-suffix-p + (oref obj inapt-if) + (oref obj inapt-if-not) + (oref obj inapt-if-nil) + (oref obj inapt-if-non-nil) + (oref obj inapt-if-mode) + (oref obj inapt-if-not-mode) + (oref obj inapt-if-derived) + (oref obj inapt-if-not-derived) + nil))) + +(defun transient--do-suffix-p + (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived + default) + (cond + (if (funcall if)) + (if-not (not (funcall if-not))) + (if-non-nil (symbol-value if-non-nil)) + (if-nil (not (symbol-value if-nil))) + (if-mode (if (atom if-mode) + (eq major-mode if-mode) + (memq major-mode if-mode))) + (if-not-mode (not (if (atom if-not-mode) + (eq major-mode if-not-mode) + (memq major-mode if-not-mode)))) + (if-derived (if (or (atom if-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-derived) + (apply #'derived-mode-p if-derived))) + (if-not-derived (not (if (or (atom if-not-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-not-derived) + (apply #'derived-mode-p if-not-derived)))) + (default))) + +(defun transient--suffix-predicate (spec) + (let ((plist (nth 2 spec))) + (seq-some (lambda (prop) + (and-let* ((pred (plist-get plist prop))) + (list prop pred))) + '( :if :if-not + :if-nil :if-non-nil + :if-mode :if-not-mode + :if-derived :if-not-derived + :inapt-if :inapt-if-not + :inapt-if-nil :inapt-if-non-nil + :inapt-if-mode :inapt-if-not-mode + :inapt-if-derived :inapt-if-not-derived)))) + +;;; Flow-Control + +(defun transient--setup-transient () + (transient--debug 'setup-transient) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (add-hook 'pre-command-hook #'transient--pre-command) + (add-hook 'post-command-hook #'transient--post-command) + (advice-add 'recursive-edit :around #'transient--recursive-edit) + (when transient--exitp + ;; This prefix command was invoked as the suffix of another. + ;; Prevent `transient--post-command' from removing the hooks + ;; that we just added. + (setq transient--exitp 'replace))) + +(defun transient--refresh-transient () + (transient--debug 'refresh-transient) + (transient--pop-keymap 'transient--predicate-map) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (transient--init-transient) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (transient--redisplay)) + +(defun transient--pre-command () + (transient--debug 'pre-command) + (transient--with-emergency-exit :pre-command + ;; The use of `overriding-terminal-local-map' does not prevent the + ;; lookup of command remappings in the overridden maps, which can + ;; lead to a suffix being remapped to a non-suffix. We have to undo + ;; the remapping in that case. However, remapping a non-suffix to + ;; another should remain possible. + (when (and (transient--get-pre-command this-original-command 'suffix) + (not (transient--get-pre-command this-command 'suffix))) + (setq this-command this-original-command)) + (cond + ((memq this-command '(transient-update transient-quit-seq)) + (transient--pop-keymap 'transient--redisplay-map)) + ((and transient--helpp + (not (memq this-command '(transient-quit-one + transient-quit-all)))) + (cond + ((transient-help) + (transient--do-suspend) + (setq this-command 'transient-suspend) + (transient--pre-exit)) + ((not (transient--edebug-command-p)) + (setq this-command 'transient-undefined)))) + ((and transient--editp + (transient-suffix-object) + (not (memq this-command '(transient-quit-one + transient-quit-all + transient-help)))) + (setq this-command 'transient-set-level) + (transient--wrap-command)) + (t + (setq transient--exitp nil) + (let ((exitp (eq (transient--call-pre-command) transient--exit))) + (transient--wrap-command) + (when exitp + (transient--pre-exit))))))) + +(defun transient--pre-exit () + (transient--debug 'pre-exit) + (transient--delete-window) + (transient--timer-cancel) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (unless transient--showp + (let ((message-log-max nil)) + (message ""))) + (setq transient--transient-map nil) + (setq transient--predicate-map nil) + (setq transient--redisplay-map nil) + (setq transient--redisplay-key nil) + (setq transient--helpp nil) + (setq transient--editp nil) + (setq transient--prefix nil) + (setq transient--layout nil) + (setq transient--suffixes nil) + (setq transient--original-window nil) + (setq transient--original-buffer nil) + (setq transient--window nil)) + +(defun transient--delete-window () + (when (window-live-p transient--window) + (let ((win transient--window) + (remain-in-minibuffer-window + (and (minibuffer-selected-window) + (selected-window)))) + (cond + ((eq (car (window-parameter win 'quit-restore)) 'other) + ;; Window used to display another buffer. + (set-window-parameter win 'no-other-window + (window-parameter win 'prev--no-other-window)) + (set-window-parameter win 'prev--no-other-window nil)) + ((with-demoted-errors "Error while exiting transient: %S" + (delete-window win)))) + (when (buffer-live-p transient--buffer) + (kill-buffer transient--buffer)) + (setq transient--buffer nil) + (when remain-in-minibuffer-window + (select-window remain-in-minibuffer-window))))) + +(defun transient--export () + (setq transient-current-prefix transient--prefix) + (setq transient-current-command (oref transient--prefix command)) + (setq transient-current-suffixes transient--suffixes) + (transient--history-push transient--prefix)) + +(defun transient--suspend-override (&optional nohide) + (transient--debug 'suspend-override) + (transient--timer-cancel) + (cond ((and (not nohide) transient-hide-during-minibuffer-read) + (transient--delete-window)) + ((and transient--prefix transient--redisplay-key) + (setq transient--redisplay-key nil) + (when transient--showp + (if-let ((win (minibuffer-selected-window))) + (with-selected-window win + (transient--show)) + (transient--show))))) + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (remove-hook 'pre-command-hook #'transient--pre-command) + (remove-hook 'post-command-hook #'transient--post-command)) + +(defun transient--resume-override (&optional _ignore) + (transient--debug 'resume-override) + (when (and transient--showp transient-hide-during-minibuffer-read) + (transient--show)) + (transient--push-keymap 'transient--transient-map) + (transient--push-keymap 'transient--redisplay-map) + (add-hook 'pre-command-hook #'transient--pre-command) + (add-hook 'post-command-hook #'transient--post-command)) + +(defun transient--recursive-edit (fn) + (transient--debug 'recursive-edit) + (if (not transient--prefix) + (funcall fn) + (transient--suspend-override (bound-and-true-p edebug-active)) + (funcall fn) ; Already unwind protected. + (cond ((memq this-command '(top-level abort-recursive-edit)) + (setq transient--exitp t) + (transient--post-exit this-command) + (transient--delete-window)) + (transient--prefix + (transient--resume-override))))) + +(defmacro transient--with-suspended-override (&rest body) + (let ((depth (make-symbol "depth")) + (setup (make-symbol "setup")) + (exit (make-symbol "exit"))) + `(if (and transient--transient-map + (memq transient--transient-map + overriding-terminal-local-map)) + (let ((,depth (1+ (minibuffer-depth))) ,setup ,exit) + (setq ,setup + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-setup) + (remove-hook 'minibuffer-setup-hook ,setup) + (transient--suspend-override))) + (setq ,exit + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-exit) + (when (= (minibuffer-depth) ,depth) + (transient--resume-override)))) + (unwind-protect + (progn + (add-hook 'minibuffer-setup-hook ,setup) + (add-hook 'minibuffer-exit-hook ,exit) + ,@body) + (remove-hook 'minibuffer-setup-hook ,setup) + (remove-hook 'minibuffer-exit-hook ,exit))) + ,@body))) + +(defun transient--wrap-command () + (static-if (>= emacs-major-version 30) + (letrec + ((prefix transient--prefix) + (suffix this-command) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99)))) + (cl-assert + (>= emacs-major-version 30) nil + "Emacs was downgraded, making it necessary to recompile Transient")) + ;; (< emacs-major-version 30) + (let* ((prefix transient--prefix) + (suffix this-command) + (advice nil) + (advice-interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil)))))) + (advice-body + (lambda (fn &rest args) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (setq advice `(lambda (fn &rest args) + (interactive ,advice-interactive) + (apply ',advice-body fn args))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99))))))) + +(defun transient--premature-post-command () + (and (equal (this-command-keys-vector) []) + (= (minibuffer-depth) + (1+ transient--minibuffer-depth)) + (progn + (transient--debug 'premature-post-command) + (transient--suspend-override) + (oset (or transient--prefix transient-current-prefix) + unwind-suffix + (if transient--exitp + #'transient--post-exit + #'transient--resume-override)) + t))) + +(defun transient--post-command () + (unless (transient--premature-post-command) + (transient--debug 'post-command) + (transient--with-emergency-exit :post-command + (cond (transient--exitp (transient--post-exit)) + ;; If `this-command' is the current transient prefix, then we + ;; have already taken care of updating the transient buffer... + ((and (eq this-command (oref transient--prefix command)) + ;; ... but if `prefix-arg' is non-nil, then the values + ;; of `this-command' and `real-this-command' are untrue + ;; because `prefix-command-preserve-state' changes them. + ;; We cannot use `current-prefix-arg' because it is set + ;; too late (in `command-execute'), and if it were set + ;; earlier, then we likely still would not be able to + ;; rely on it, and `prefix-command-preserve-state-hook' + ;; would have to be used to record that a universal + ;; argument is in effect. + (not prefix-arg))) + (transient--refreshp + (transient--env-apply #'transient--refresh-transient)) + ((let ((old transient--redisplay-map) + (new (transient--make-redisplay-map))) + (unless (equal old new) + (transient--pop-keymap 'transient--redisplay-map) + (setq transient--redisplay-map new) + (transient--push-keymap 'transient--redisplay-map)) + (transient--env-apply #'transient--redisplay))))) + (setq transient-current-prefix nil) + (setq transient-current-command nil) + (setq transient-current-suffixes nil))) + +(defun transient--post-exit (&optional command) + (transient--debug 'post-exit) + (unless (and (eq transient--exitp 'replace) + (or transient--prefix + ;; The current command could act as a prefix, + ;; but decided not to call `transient-setup', + ;; or it is prevented from doing so because it + ;; uses the minibuffer and the user aborted + ;; that. + (prog1 nil + (if (let ((obj (transient-suffix-object command))) + (and (slot-boundp obj 'transient) + (oref obj transient))) + ;; This sub-prefix is a transient suffix; + ;; go back to outer prefix, by calling + ;; `transient--stack-pop' further down. + (setq transient--exitp nil) + (transient--stack-zap))))) + (remove-hook 'pre-command-hook #'transient--pre-command) + (remove-hook 'post-command-hook #'transient--post-command) + (advice-remove 'recursive-edit #'transient--recursive-edit)) + (let ((resume (and transient--stack + (not (memq transient--exitp '(replace suspend)))))) + (unless (or resume (eq transient--exitp 'replace)) + (setq transient--showp nil)) + (setq transient--exitp nil) + (setq transient--helpp nil) + (setq transient--editp nil) + (setq transient--all-levels-p nil) + (setq transient--minibuffer-depth 0) + (run-hooks 'transient-exit-hook) + (when command + (setq transient-current-prefix nil) + (setq transient-current-command nil) + (setq transient-current-suffixes nil)) + (when resume + (transient--stack-pop)))) + +(defun transient--stack-push () + (transient--debug 'stack-push) + (push (list (oref transient--prefix command) + transient--layout + transient--editp + :transient-suffix (oref transient--prefix transient-suffix) + :scope (oref transient--prefix scope)) + transient--stack)) + +(defun transient--stack-pop () + (transient--debug 'stack-pop) + (and transient--stack + (prog1 t (apply #'transient-setup (pop transient--stack))))) + +(defun transient--stack-zap () + (transient--debug 'stack-zap) + (setq transient--stack nil)) + +(defun transient--redisplay () + (if (or (eq transient-show-popup t) + transient--showp) + (unless + (or (memq this-command transient--scroll-commands) + (and (or (memq this-command '(mouse-drag-region + mouse-set-region)) + (equal (key-description (this-command-keys-vector)) + "<mouse-movement>")) + (and (eq (current-buffer) transient--buffer)))) + (transient--show)) + (when (and (numberp transient-show-popup) + (not (zerop transient-show-popup)) + (not transient--timer)) + (transient--timer-start)) + (transient--show-brief))) + +(defun transient--timer-start () + (setq transient--timer + (run-at-time (abs transient-show-popup) nil + (lambda () + (transient--timer-cancel) + (transient--show) + (let ((message-log-max nil)) + (message "")))))) + +(defun transient--timer-cancel () + (when transient--timer + (cancel-timer transient--timer) + (setq transient--timer nil))) + +(defun transient--debug (arg &rest args) + (when transient--debug + (let ((inhibit-message (not (eq transient--debug 'message)))) + (if (symbolp arg) + (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" + arg + (cond ((and (symbolp this-command) this-command)) + ((fboundp 'help-fns-function-name) + (help-fns-function-name this-command)) + ((byte-code-function-p this-command) + "#[...]") + (this-command)) + (key-description (this-command-keys-vector)) + transient--exitp + (cond ((keywordp (car args)) + (format ", from: %s" + (substring (symbol-name (car args)) 1))) + ((stringp (car args)) + (concat ", " (apply #'format args))) + ((functionp (car args)) + (concat ", " (apply (car args) (cdr args)))) + (""))) + (apply #'message arg args))))) + +(defun transient--emergency-exit (&optional id) + "Exit the current transient command after an error occurred. +When no transient is active (i.e., when `transient--prefix' is +nil) then do nothing. Optional ID is a keyword identifying the +exit." + (transient--debug 'emergency-exit id) + (when transient--prefix + (setq transient--stack nil) + (setq transient--exitp t) + (transient--pre-exit) + (transient--post-exit this-command))) + +;;; Pre-Commands + +(defun transient--call-pre-command () + (if-let ((fn (transient--get-pre-command this-command))) + (let ((action (funcall fn))) + (when (eq action transient--exit) + (setq transient--exitp (or transient--exitp t))) + action) + (if (let ((keys (this-command-keys-vector))) + (eq (aref keys (1- (length keys))) ?\C-g)) + (setq this-command 'transient-noop) + (unless (transient--edebug-command-p) + (setq this-command 'transient-undefined))) + transient--stay)) + +(defun transient--get-pre-command (&optional cmd enforce-type) + (or (and (not (eq enforce-type 'non-suffix)) + (symbolp cmd) + (lookup-key transient--predicate-map (vector cmd))) + (and (not (eq enforce-type 'suffix)) + (transient--resolve-pre-command + (oref transient--prefix transient-non-suffix) + t)))) + +(defun transient--resolve-pre-command (pre &optional resolve-boolean) + (cond ((booleanp pre) + (if resolve-boolean + (if pre #'transient--do-stay #'transient--do-warn) + pre)) + ((string-match-p "--do-" (symbol-name pre)) pre) + ((let ((sym (intern (format "transient--do-%s" pre)))) + (if (functionp sym) sym pre))))) + +(defun transient--do-stay () + "Call the command without exporting variables and stay transient." + transient--stay) + +(defun transient--do-noop () + "Call `transient-noop' and stay transient." + (setq this-command 'transient-noop) + transient--stay) + +(defun transient--do-warn () + "Call `transient-undefined' and stay transient." + (setq this-command 'transient-undefined) + transient--stay) + +(defun transient--do-warn-inapt () + "Call `transient-inapt' and stay transient." + (setq this-command 'transient-inapt) + transient--stay) + +(defun transient--do-call () + "Call the command after exporting variables and stay transient." + (transient--export) + transient--stay) + +(defun transient--do-return () + "Call the command after exporting variables and return to parent prefix. +If there is no parent prefix, then behave like `transient--do-exit'." + (if (not transient--stack) + (transient--do-exit) + (transient--export) + transient--exit)) + +(defun transient--do-exit () + "Call the command after exporting variables and exit the transient." + (transient--export) + (transient--stack-zap) + transient--exit) + +(defun transient--do-leave () + "Call the command without exporting variables and exit the transient." + (transient--stack-zap) + transient--exit) + +(defun transient--do-push-button () + "Call the command represented by the activated button. +Use that command's pre-command to determine transient behavior." + (if (and (mouse-event-p last-command-event) + (not (eq (posn-window (event-start last-command-event)) + transient--window))) + transient--stay + (setq this-command + (with-selected-window transient--window + (get-text-property (if (mouse-event-p last-command-event) + (posn-point (event-start last-command-event)) + (point)) + 'command))) + (transient--call-pre-command))) + +(defun transient--do-recurse () + "Call the transient prefix command, preparing for return to active transient. +If there is no parent prefix, then just call the command." + (transient--do-stack)) + +(defun transient--setup-recursion (prefix-obj) + (when transient--stack + (let ((command (oref prefix-obj command))) + (when-let ((suffix-obj (transient-suffix-object command))) + (when (memq (if (slot-boundp suffix-obj 'transient) + (oref suffix-obj transient) + (oref transient-current-prefix transient-suffix)) + (list t #'transient--do-recurse)) + (oset prefix-obj transient-suffix t)))))) + +(defun transient--do-stack () + "Call the transient prefix command, stacking the active transient. +Push the active transient to the transient stack." + (transient--export) + (transient--stack-push) + (setq transient--exitp 'replace) + transient--exit) + +(defun transient--do-replace () + "Call the transient prefix command, replacing the active transient. +Do not push the active transient to the transient stack." + (transient--export) + (setq transient--exitp 'replace) + transient--exit) + +(defun transient--do-suspend () + "Suspend the active transient, saving the transient stack." + (transient--stack-push) + (setq transient--exitp 'suspend) + transient--exit) + +(defun transient--do-quit-one () + "If active, quit help or edit mode, else exit the active transient." + (cond (transient--helpp + (setq transient--helpp nil) + transient--stay) + (transient--editp + (setq transient--editp nil) + (transient-setup) + transient--stay) + (prefix-arg + transient--stay) + (transient--exit))) + +(defun transient--do-quit-all () + "Exit all transients without saving the transient stack." + (transient--stack-zap) + transient--exit) + +(defun transient--do-move () + "Call the command if `transient-enable-popup-navigation' is non-nil. +In that case behave like `transient--do-stay', otherwise similar +to `transient--do-warn'." + (unless transient-enable-popup-navigation + (setq this-command 'transient-inhibit-move)) + transient--stay) + +(defun transient--do-minus () + "Call `negative-argument' or pivot to `transient-update'. +If `negative-argument' is invoked using \"-\" then preserve the +prefix argument and pivot to `transient-update'." + (when (equal (this-command-keys) "-") + (setq this-command 'transient-update)) + transient--stay) + +(put 'transient--do-stay 'transient-face 'transient-key-stay) +(put 'transient--do-noop 'transient-face 'transient-key-noop) +(put 'transient--do-warn 'transient-face 'transient-key-noop) +(put 'transient--do-warn-inapt 'transient-face 'transient-key-noop) +(put 'transient--do-call 'transient-face 'transient-key-stay) +(put 'transient--do-return 'transient-face 'transient-key-return) +(put 'transient--do-exit 'transient-face 'transient-key-exit) +(put 'transient--do-leave 'transient-face 'transient-key-exit) + +(put 'transient--do-recurse 'transient-face 'transient-key-stay) +(put 'transient--do-stack 'transient-face 'transient-key-stay) +(put 'transient--do-replace 'transient-face 'transient-key-exit) +(put 'transient--do-suspend 'transient-face 'transient-key-exit) + +(put 'transient--do-quit-one 'transient-face 'transient-key-return) +(put 'transient--do-quit-all 'transient-face 'transient-key-exit) +(put 'transient--do-move 'transient-face 'transient-key-stay) +(put 'transient--do-minus 'transient-face 'transient-key-stay) + +;;; Commands +;;;; Noop + +(defun transient-noop () + "Do nothing at all." + (interactive)) + +(defun transient-undefined () + "Warn the user that the pressed key is not bound to any suffix." + (interactive) + (transient--invalid "Unbound suffix")) + +(defun transient-inapt () + "Warn the user that the invoked command is inapt." + (interactive) + (transient--invalid "Inapt command")) + +(defun transient--invalid (msg) + (ding) + (message "%s: `%s' (Use `%s' to abort, `%s' for help)%s" + msg + (propertize (key-description (this-single-command-keys)) + 'face 'font-lock-warning-face) + (propertize "C-g" 'face 'transient-key) + (propertize "?" 'face 'transient-key) + ;; `this-command' is `transient-undefined' or `transient-inapt'. + ;; Show the command (`this-original-command') the user actually + ;; tried to invoke. + (if-let ((cmd (or (ignore-errors (symbol-name this-original-command)) + (ignore-errors (symbol-name this-command))))) + (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) + "")) + (unless (and transient--transient-map + (memq transient--transient-map overriding-terminal-local-map)) + (let ((transient--prefix (or transient--prefix 'sic))) + (transient--emergency-exit)) + (view-lossage) + (other-window 1) + (display-warning 'transient "Inconsistent transient state detected. +This should never happen. +Please open an issue and post the shown command log." :error))) + +(defun transient-inhibit-move () + "Warn the user that popup navigation is disabled." + (interactive) + (message "To enable use of `%s', please customize `%s'" + this-original-command + 'transient-enable-popup-navigation)) + +;;;; Core + +(defun transient-quit-all () + "Exit all transients without saving the transient stack." + (interactive)) + +(defun transient-quit-one () + "Exit the current transients, returning to outer transient, if any." + (interactive)) + +(defun transient-quit-seq () + "Abort the current incomplete key sequence." + (interactive)) + +(defun transient-update () + "Redraw the transient's state in the popup buffer." + (interactive) + (setq prefix-arg current-prefix-arg)) + +(defun transient-show () + "Show the transient's state in the popup buffer." + (interactive) + (setq transient--showp t)) + +(defun transient-push-button () + "Invoke the suffix command represented by this button." + (interactive)) + +;;;; Suspend + +(defun transient-suspend () + "Suspend the current transient. +It can later be resumed using `transient-resume', while no other +transient is active." + (interactive)) + +(define-minor-mode transient-resume-mode + "Auxiliary minor-mode used to resume a transient after viewing help.") + +(defun transient-resume () + "Resume a previously suspended stack of transients." + (interactive) + (cond (transient--stack + (let ((winconf transient--restore-winconf)) + (kill-local-variable 'transient--restore-winconf) + (when transient-resume-mode + (transient-resume-mode -1) + (quit-window)) + (when winconf + (set-window-configuration winconf))) + (transient--stack-pop)) + (transient-resume-mode + (kill-local-variable 'transient--restore-winconf) + (transient-resume-mode -1) + (quit-window)) + (t + (message "No suspended transient command")))) + +;;;; Help + +(defun transient-help (&optional interactive) + "Show help for the active transient or one of its suffixes.\n\n(fn)" + (interactive (list t)) + (if interactive + (setq transient--helpp t) + (with-demoted-errors "transient-help: %S" + (when (lookup-key transient--transient-map + (this-single-command-raw-keys)) + (setq transient--helpp nil) + (let ((winconf (current-window-configuration))) + (transient-show-help + (if (eq this-original-command 'transient-help) + transient--prefix + (or (transient-suffix-object) + this-original-command))) + (setq-local transient--restore-winconf winconf)) + (fit-window-to-buffer nil (frame-height) (window-height)) + (transient-resume-mode) + (message (substitute-command-keys + "Type \\`q' to resume transient command.")) + t)))) + +;;;; Level + +(defun transient-set-level (&optional command level) + "Set the level of the transient or one of its suffix commands." + (interactive + (let ((command this-original-command) + (prefix (oref transient--prefix command))) + (and (or (not (eq command 'transient-set-level)) + (and transient--editp + (setq command prefix))) + (list command + (let ((keys (this-single-command-raw-keys))) + (and (lookup-key transient--transient-map keys) + (progn + (transient--show) + (string-to-number + (transient--read-number-N + (format "Set level for `%s': " command) + nil nil (not (eq command prefix))))))))))) + (cond + ((not command) + (setq transient--editp t) + (transient-setup)) + (level + (let* ((prefix (oref transient--prefix command)) + (alist (alist-get prefix transient-levels)) + (akey command)) + (cond ((eq command prefix) + (oset transient--prefix level level) + (setq akey t)) + (t + (oset (transient-suffix-object command) level level) + (when (cdr (cl-remove-if-not (lambda (obj) + (eq (oref obj command) command)) + transient--suffixes)) + (setq akey (cons command (this-command-keys)))))) + (setf (alist-get akey alist) level) + (setf (alist-get prefix transient-levels) alist)) + (transient-save-levels) + (transient--show)) + (t + (transient-undefined)))) + +(transient-define-suffix transient-toggle-level-limit () + "Toggle whether to temporarily displayed suffixes on all levels." + :description + (lambda () + (cond + ((= transient-default-level transient--max-level) + "Always displaying all levels") + (transient--all-levels-p + (format "Hide suffix %s" + (propertize + (format "levels > %s" (oref (transient-prefix-object) level)) + 'face 'transient-higher-level))) + ("Show all suffix levels"))) + :inapt-if (lambda () (= transient-default-level transient--max-level)) + :transient t + (interactive) + (setq transient--all-levels-p (not transient--all-levels-p)) + (setq transient--refreshp t)) + +;;;; Value + +(defun transient-set () + "Set active transient's value for this Emacs session." + (interactive) + (transient-set-value (transient-prefix-object))) + +(defalias 'transient-set-and-exit #'transient-set + "Set active transient's value for this Emacs session and exit.") + +(defun transient-save () + "Save active transient's value for this and future Emacs sessions." + (interactive) + (transient-save-value (transient-prefix-object))) + +(defalias 'transient-save-and-exit #'transient-save + "Save active transient's value for this and future Emacs sessions and exit.") + +(defun transient-reset () + "Clear the set and saved values of the active transient." + (interactive) + (transient-reset-value (transient-prefix-object))) + +(defun transient-history-next () + "Switch to the next value used for the active transient." + (interactive) + (let* ((obj transient--prefix) + (pos (1- (oref obj history-pos))) + (hst (oref obj history))) + (if (< pos 0) + (user-error "End of history") + (oset obj history-pos pos) + (oset obj value (nth pos hst)) + (mapc #'transient-init-value transient--suffixes)))) + +(defun transient-history-prev () + "Switch to the previous value used for the active transient." + (interactive) + (let* ((obj transient--prefix) + (pos (1+ (oref obj history-pos))) + (hst (oref obj history)) + (len (length hst))) + (if (> pos (1- len)) + (user-error "End of history") + (oset obj history-pos pos) + (oset obj value (nth pos hst)) + (mapc #'transient-init-value transient--suffixes)))) + +(transient-define-suffix transient-preset () + "Put this preset into action." + :class transient-value-preset + (interactive) + (transient-prefix-set (oref (transient-suffix-object) set))) + +;;;; Auxiliary + +(defun transient-toggle-common () + "Toggle whether common commands are permanently shown." + (interactive) + (setq transient-show-common-commands (not transient-show-common-commands))) + +(defun transient-toggle-debug () + "Toggle debugging statements for transient commands." + (interactive) + (setq transient--debug (not transient--debug)) + (message "Debugging transient %s" + (if transient--debug "enabled" "disabled"))) + +(transient-define-suffix transient-echo-arguments (arguments) + "Show the transient's active ARGUMENTS in the echo area. +Intended for use in prefixes used for demonstration purposes, +such as when suggesting a new feature or reporting an issue." + :transient t + :description "Echo arguments" + :key "x" + (interactive (list (transient-args transient-current-command))) + (message "%s: %s" + (key-description (this-command-keys)) + (mapconcat (lambda (arg) + (propertize (if (string-match-p " " arg) + (format "%S" arg) + arg) + 'face 'transient-argument)) + arguments " "))) + +;;; Value +;;;; Init + +(cl-defgeneric transient-init-scope (obj) + "Set the scope of the suffix object OBJ. + +The scope is actually a property of the transient prefix, not of +individual suffixes. However it is possible to invoke a suffix +command directly instead of from a transient. In that case, if +the suffix expects a scope, then it has to determine that itself +and store it in its `scope' slot. + +This function is called for all suffix commands, but unless a +concrete method is implemented this falls through to the default +implementation, which is a noop.") + +(cl-defmethod transient-init-scope ((_ transient-suffix)) + "Noop." nil) + +(cl-defgeneric transient-init-value (_) + "Set the initial value of the object OBJ. + +This function is called for all prefix and suffix commands. + +For suffix commands (including infix argument commands) the +default implementation is a noop. Classes derived from the +abstract `transient-infix' class must implement this function. +Non-infix suffix commands usually don't have a value." + nil) + +(cl-defmethod transient-init-value :around ((obj transient-prefix)) + "If bound, then call OBJ's `init-value' function. +Otherwise call the primary method according to object's class." + (if (slot-boundp obj 'init-value) + (funcall (oref obj init-value) obj) + (cl-call-next-method obj))) + +(cl-defmethod transient-init-value :around ((obj transient-infix)) + "If bound, then call OBJ's `init-value' function. +Otherwise call the primary method according to object's class." + (if (slot-boundp obj 'init-value) + (funcall (oref obj init-value) obj) + (cl-call-next-method obj))) + +(cl-defmethod transient-init-value ((obj transient-prefix)) + (if (slot-boundp obj 'value) + (oref obj value) + (oset obj value + (if-let ((saved (assq (oref obj command) transient-values))) + (cdr saved) + (transient-default-value obj))))) + +(cl-defmethod transient-init-value ((obj transient-argument)) + (oset obj value + (let ((value (oref transient--prefix value)) + (argument (and (slot-boundp obj 'argument) + (oref obj argument))) + (multi-value (oref obj multi-value)) + (case-fold-search nil) + (regexp (if (slot-exists-p obj 'argument-regexp) + (oref obj argument-regexp) + (format "\\`%s\\(.*\\)" (oref obj argument))))) + (if (memq multi-value '(t rest)) + (cdr (assoc argument value)) + (let ((match (lambda (v) + (and (stringp v) + (string-match regexp v) + (match-string 1 v))))) + (if multi-value + (delq nil (mapcar match value)) + (cl-some match value))))))) + +(cl-defmethod transient-init-value ((obj transient-switch)) + (oset obj value + (car (member (oref obj argument) + (oref transient--prefix value))))) + +;;;; Default + +(cl-defgeneric transient-default-value (_) + "Return the default value." + nil) + +(cl-defmethod transient-default-value ((obj transient-prefix)) + (if-let ((default (and (slot-boundp obj 'default-value) + (oref obj default-value)))) + (if (functionp default) + (funcall default) + default) + nil)) + +;;;; Read + +(cl-defgeneric transient-infix-read (obj) + "Determine the new value of the infix object OBJ. + +This function merely determines the value; `transient-infix-set' +is used to actually store the new value in the object. + +For most infix classes this is done by reading a value from the +user using the reader specified by the `reader' slot (using the +`transient-infix' method described below). + +For some infix classes the value is changed without reading +anything in the minibuffer, i.e., the mere act of invoking the +infix command determines what the new value should be, based +on the previous value.") + +(cl-defmethod transient-infix-read :around ((obj transient-infix)) + "Refresh the transient buffer and call the next method. + +Also wrap `cl-call-next-method' with two macros: +- `transient--with-suspended-override' allows use of minibuffer. +- `transient--with-emergency-exit' arranges for the transient to + be exited in case of an error." + (transient--show) + (transient--with-emergency-exit :infix-read + (transient--with-suspended-override + (cl-call-next-method obj)))) + +(cl-defmethod transient-infix-read ((obj transient-infix)) + "Read a value while taking care of history. + +This method is suitable for a wide variety of infix commands, +including but not limited to inline arguments and variables. + +If you do not use this method for your own infix class, then +you should likely replicate a lot of the behavior of this +method. If you fail to do so, then users might not appreciate +the lack of history, for example. + +Only for very simple classes that toggle or cycle through a very +limited number of possible values should you replace this with a +simple method that does not handle history. (E.g., for a command +line switch the only possible values are \"use it\" and \"don't use +it\", in which case it is pointless to preserve history.)" + (with-slots (value multi-value always-read allow-empty choices) obj + (if (and value + (not multi-value) + (not always-read) + transient--prefix) + (oset obj value nil) + (let* ((enable-recursive-minibuffers t) + (reader (oref obj reader)) + (choices (if (functionp choices) (funcall choices) choices)) + (prompt (transient-prompt obj)) + (value (if multi-value (string-join value ",") value)) + (history-key (or (oref obj history-key) + (oref obj command))) + (transient--history (alist-get history-key transient-history)) + (transient--history (if (or (null value) + (eq value (car transient--history))) + transient--history + (cons value transient--history))) + (initial-input (and transient-read-with-initial-input + (car transient--history))) + (history (if initial-input + (cons 'transient--history 1) + 'transient--history)) + (value + (cond + (reader (funcall reader prompt initial-input history)) + (multi-value + (completing-read-multiple prompt choices nil nil + initial-input history)) + (choices + (completing-read prompt choices nil t initial-input history)) + ((read-string prompt initial-input history))))) + (cond ((and (equal value "") (not allow-empty)) + (setq value nil)) + ((and (equal value "\"\"") allow-empty) + (setq value ""))) + (when value + (when (and (bound-and-true-p ivy-mode) + (stringp (car transient--history))) + (set-text-properties 0 (length (car transient--history)) nil + (car transient--history))) + (setf (alist-get history-key transient-history) + (delete-dups transient--history))) + value)))) + +(cl-defmethod transient-infix-read ((obj transient-switch)) + "Toggle the switch on or off." + (if (oref obj value) nil (oref obj argument))) + +(cl-defmethod transient-infix-read ((obj transient-switches)) + "Cycle through the mutually exclusive switches. +The last value is \"don't use any of these switches\"." + (let ((choices (mapcar (apply-partially #'format (oref obj argument-format)) + (oref obj choices)))) + (if-let ((value (oref obj value))) + (cadr (member value choices)) + (car choices)))) + +(cl-defmethod transient-infix-read ((command symbol)) + "Elsewhere use the reader of the infix command COMMAND. +Use this if you want to share an infix's history with a regular +stand-alone command." + (if-let ((obj (transient--suffix-prototype command))) + (cl-letf (((symbol-function #'transient--show) #'ignore)) + (transient-infix-read obj)) + (error "Not a suffix command: `%s'" command))) + +;;;; Readers + +(defun transient-read-file (prompt _initial-input _history) + "Read a file." + (file-local-name (expand-file-name (read-file-name prompt)))) + +(defun transient-read-existing-file (prompt _initial-input _history) + "Read an existing file." + (file-local-name (expand-file-name (read-file-name prompt nil nil t)))) + +(defun transient-read-directory (prompt _initial-input _history) + "Read a directory." + (file-local-name (expand-file-name (read-directory-name prompt)))) + +(defun transient-read-existing-directory (prompt _initial-input _history) + "Read an existing directory." + (file-local-name (expand-file-name (read-directory-name prompt nil nil t)))) + +(defun transient-read-number-N0 (prompt initial-input history) + "Read a natural number (including zero) and return it as a string." + (transient--read-number-N prompt initial-input history t)) + +(defun transient-read-number-N+ (prompt initial-input history) + "Read a natural number (excluding zero) and return it as a string." + (transient--read-number-N prompt initial-input history nil)) + +(defun transient--read-number-N (prompt initial-input history include-zero) + (save-match-data + (cl-block nil + (while t + (let ((str (read-from-minibuffer prompt initial-input nil nil history))) + (when (or (string-equal str "") + (string-match-p (if include-zero + "\\`\\(0\\|[1-9][0-9]*\\)\\'" + "\\`[1-9][0-9]*\\'") + str)) + (cl-return str))) + (message "Please enter a natural number (%s zero)." + (if include-zero "including" "excluding")) + (sit-for 1))))) + +(defun transient-read-date (prompt default-time _history) + "Read a date using `org-read-date' (which see)." + (require 'org) + (when (fboundp 'org-read-date) + (org-read-date 'with-time nil nil prompt default-time))) + +;;;; Prompt + +(cl-defgeneric transient-prompt (obj) + "Return the prompt to be used to read infix object OBJ's value.") + +(cl-defmethod transient-prompt ((obj transient-infix)) + "Return the prompt to be used to read infix object OBJ's value. + +This implementation should be suitable for almost all infix +commands. + +If the value of OBJ's `prompt' slot is non-nil, then it must be +a string or a function. If it is a string, then use that. If +it is a function, then call that with OBJ as the only argument. +That function must return a string, which is then used as the +prompt. + +Otherwise, if the value of either the `argument' or `variable' +slot of OBJ is a string, then base the prompt on that (preferring +the former), appending either \"=\" (if it appears to be a +command-line option) or \": \". + +Finally fall through to using \"(BUG: no prompt): \" as the +prompt." + (if-let ((prompt (oref obj prompt))) + (let ((prompt (if (functionp prompt) + (funcall prompt obj) + prompt))) + (if (stringp prompt) + prompt + "(BUG: no prompt): ")) + (or (and-let* ((arg (and (slot-boundp obj 'argument) (oref obj argument)))) + (if (and (stringp arg) (string-suffix-p "=" arg)) + arg + (concat arg ": "))) + (and-let* ((var (and (slot-boundp obj 'variable) (oref obj variable)))) + (and (stringp var) + (concat var ": "))) + "(BUG: no prompt): "))) + +;;;; Set + +(cl-defgeneric transient-infix-set (obj value) + "Set the value of infix object OBJ to VALUE.") + +(cl-defmethod transient-infix-set ((obj transient-infix) value) + "Set the value of infix object OBJ to VALUE." + (oset obj value value)) + +(cl-defmethod transient-infix-set :after ((obj transient-argument) value) + "Unset incompatible infix arguments." + (when-let* ((value) + (val (transient-infix-value obj)) + (arg (if (slot-boundp obj 'argument) + (oref obj argument) + (oref obj argument-format))) + (spec (oref transient--prefix incompatible)) + (filter (lambda (x rule) + (and (member x rule) + (remove x rule)))) + (incomp (nconc + (cl-mapcan (apply-partially filter arg) spec) + (and (not (equal val arg)) + (cl-mapcan (apply-partially filter val) spec))))) + (dolist (obj transient--suffixes) + (when-let* (((cl-typep obj 'transient-argument)) + (val (transient-infix-value obj)) + (arg (if (slot-boundp obj 'argument) + (oref obj argument) + (oref obj argument-format))) + ((if (equal val arg) + (member arg incomp) + (or (member val incomp) + (member arg incomp))))) + (transient-infix-set obj nil))))) + +(defun transient-prefix-set (value) + "Set the value of the active transient prefix to VALUE. +Intended for use by transient suffix commands." + (oset transient--prefix value value) + (setq transient--refreshp 'updated-value)) + +(cl-defgeneric transient-set-value (obj) + "Persist the value of the transient prefix OBJ. +Only intended for use by `transient-set'. +Also see `transient-prefix-set'.") + +(cl-defmethod transient-set-value ((obj transient-prefix)) + (oset (oref obj prototype) value (transient-get-value)) + (transient--history-push obj)) + +;;;; Save + +(cl-defgeneric transient-save-value (obj) + "Save the value of the transient prefix OBJ.") + +(cl-defmethod transient-save-value ((obj transient-prefix)) + (let ((value (transient-get-value))) + (oset (oref obj prototype) value value) + (setf (alist-get (oref obj command) transient-values) value) + (transient-save-values)) + (transient--history-push obj)) + +;;;; Reset + +(cl-defgeneric transient-reset-value (obj) + "Clear the set and saved values of the transient prefix OBJ.") + +(cl-defmethod transient-reset-value ((obj transient-prefix)) + (let ((value (transient-default-value obj))) + (oset obj value value) + (oset (oref obj prototype) value value) + (setf (alist-get (oref obj command) transient-values nil 'remove) nil) + (transient-save-values)) + (transient--history-push obj) + (mapc #'transient-init-value transient--suffixes)) + +;;;; Get + +(defun transient-args (prefix) + "Return the value of the transient prefix command PREFIX. +If the current command was invoked from the transient prefix +command PREFIX, then return the active infix arguments. If +the current command was not invoked from PREFIX, then return +the set, saved or default value for PREFIX." + (cl-mapcan #'transient--get-wrapped-value (transient-suffixes prefix))) + +(defun transient-suffixes (prefix) + "Return the suffix objects of the transient prefix command PREFIX." + (if (eq transient-current-command prefix) + transient-current-suffixes + (let ((transient--prefix (transient--init-prefix prefix))) + (transient--flatten-suffixes + (transient--init-suffixes prefix))))) + +(defun transient-get-value () + (transient--with-emergency-exit :get-value + (cl-mapcan (lambda (obj) + (and (or (not (slot-exists-p obj 'unsavable)) + (not (oref obj unsavable))) + (transient--get-wrapped-value obj))) + (or transient--suffixes transient-current-suffixes)))) + +(defun transient--get-wrapped-value (obj) + (and-let* ((value (transient-infix-value obj))) + (pcase-exhaustive (and (slot-exists-p obj 'multi-value) + (oref obj multi-value)) + ('nil (list value)) + ((or 't 'rest) (list value)) + ('repeat value)))) + +(cl-defgeneric transient-infix-value (obj) + "Return the value of the suffix object OBJ. + +This function is called by `transient-args' (which see), meaning +this function is how the value of a transient is determined so +that the invoked suffix command can use it. + +Currently most values are strings, but that is not set in stone. +Nil is not a value, it means \"no value\". + +Usually only infixes have a value, but see the method for +`transient-suffix'.") + +(cl-defmethod transient-infix-value ((_ transient-suffix)) + "Return nil, which means \"no value\". + +Infix arguments contribute the transient's value while suffix +commands consume it. This function is called for suffixes anyway +because a command that both contributes to the transient's value +and also consumes it is not completely unconceivable. + +If you define such a command, then you must define a derived +class and implement this function because this default method +does nothing." nil) + +(cl-defmethod transient-infix-value ((obj transient-infix)) + "Return the value of OBJ's `value' slot." + (oref obj value)) + +(cl-defmethod transient-infix-value ((obj transient-option)) + "Return ARGUMENT and VALUE as a unit or nil if the latter is nil." + (and-let* ((value (oref obj value))) + (let ((arg (oref obj argument))) + (pcase-exhaustive (oref obj multi-value) + ('nil (concat arg value)) + ((or 't 'rest) (cons arg value)) + ('repeat (mapcar (lambda (v) (concat arg v)) value)))))) + +(cl-defmethod transient-infix-value ((_ transient-variable)) + "Return nil, which means \"no value\". + +Setting the value of a variable is done by, well, setting the +value of the variable. I.e., this is a side-effect and does +not contribute to the value of the transient." + nil) + +;;;; Utilities + +(defun transient-arg-value (arg args) + "Return the value of ARG as it appears in ARGS. + +For a switch return a boolean. For an option return the value as +a string, using the empty string for the empty value, or nil if +the option does not appear in ARGS." + (if (string-suffix-p "=" arg) + (save-match-data + (and-let* ((match (let ((case-fold-search nil) + (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" + (substring arg 0 -1)))) + (cl-find-if (lambda (a) + (and (stringp a) + (string-match re a))) + args)))) + (or (match-string 1 match) ""))) + (and (member arg args) t))) + +(defun transient-scope () + "Return the value of the `scope' slot of the current prefix." + (oref (transient-prefix-object) scope)) + +;;; History + +(cl-defgeneric transient--history-key (obj) + "Return OBJ's history key. +If the value of the `history-key' slot is non-nil, then return +that. Otherwise return the value of the `command' slot." + (or (oref obj history-key) + (oref obj command))) + +(cl-defgeneric transient--history-push (obj) + "Push the current value of OBJ to its entry in `transient-history'." + (let ((key (transient--history-key obj))) + (setf (alist-get key transient-history) + (let ((args (transient-get-value))) + (cons args (delete args (alist-get key transient-history))))))) + +(cl-defgeneric transient--history-init (obj) + "Initialize OBJ's `history' slot. +This is the transient-wide history; many individual infixes also +have a history of their own.") + +(cl-defmethod transient--history-init ((obj transient-prefix)) + "Initialize OBJ's `history' slot from the variable `transient-history'." + (let ((val (oref obj value))) + (oset obj history + (cons val (delete val (alist-get (transient--history-key obj) + transient-history)))))) + +;;; Draw + +(defun transient--show-brief () + (let ((message-log-max nil)) + (if (and transient-show-popup (<= transient-show-popup 0)) + (message "%s-" (key-description (this-command-keys))) + (message + "%s- [%s] %s" + (key-description (this-command-keys)) + (oref transient--prefix command) + (mapconcat + #'identity + (sort + (cl-mapcan + (lambda (suffix) + (let ((key (kbd (oref suffix key)))) + ;; Don't list any common commands. + (and (not (memq (oref suffix command) + `(,(lookup-key transient-map key) + ,(lookup-key transient-sticky-map key) + ;; From transient-common-commands: + transient-set + transient-save + transient-history-prev + transient-history-next + transient-quit-one + transient-toggle-common + transient-set-level))) + (list (propertize (oref suffix key) 'face 'transient-key))))) + transient--suffixes) + #'string<) + (propertize "|" 'face 'transient-delimiter)))))) + +(defun transient--show () + (transient--timer-cancel) + (setq transient--showp t) + (let ((transient--shadowed-buffer (current-buffer)) + (focus nil)) + (setq transient--buffer (get-buffer-create transient--buffer-name)) + (with-current-buffer transient--buffer + (when transient-enable-popup-navigation + (setq focus (or (button-get (point) 'command) + (and (not (bobp)) + (button-get (1- (point)) 'command)) + (transient--heading-at-point)))) + (erase-buffer) + (run-hooks 'transient-setup-buffer-hook) + (when transient-force-fixed-pitch + (transient--force-fixed-pitch)) + (setq window-size-fixed (if (window-full-height-p) 'width t)) + (when (bound-and-true-p tab-line-format) + (setq tab-line-format nil)) + (setq header-line-format nil) + (setq mode-line-format + (if (or (natnump transient-mode-line-format) + (eq transient-mode-line-format 'line)) + nil + transient-mode-line-format)) + (setq mode-line-buffer-identification + (symbol-name (oref transient--prefix command))) + (if transient-enable-popup-navigation + (setq-local cursor-in-non-selected-windows 'box) + (setq cursor-type nil)) + (setq display-line-numbers nil) + (setq show-trailing-whitespace nil) + (transient--insert-groups) + (when (or transient--helpp transient--editp) + (transient--insert-help)) + (when-let ((line (transient--separator-line))) + (insert line))) + (unless (window-live-p transient--window) + (setq transient--window + (display-buffer transient--buffer + transient-display-buffer-action))) + (when (window-live-p transient--window) + (with-selected-window transient--window + (set-window-parameter nil 'prev--no-other-window + (window-parameter nil 'no-other-window)) + (set-window-parameter nil 'no-other-window t) + (goto-char (point-min)) + (when transient-enable-popup-navigation + (transient--goto-button focus)) + (transient--fit-window-to-buffer transient--window))))) + +(defun transient--fit-window-to-buffer (window) + (let ((window-resize-pixelwise t) + (window-size-fixed nil)) + (if (eq (car (window-parameter window 'quit-restore)) 'other) + ;; Grow but never shrink window that previously displayed + ;; another buffer and is going to display that again. + (fit-window-to-buffer window nil (window-height window)) + (fit-window-to-buffer window nil 1)))) + +(defun transient--separator-line () + (and-let* ((height (cond ((not window-system) nil) + ((natnump transient-mode-line-format) + transient-mode-line-format) + ((eq transient-mode-line-format 'line) 1))) + (face `(,@(and (>= emacs-major-version 27) '(:extend t)) + :background + ,(or (face-foreground (transient--key-face nil 'non-suffix) + nil t) + "#gray60")))) + (concat (propertize "__" 'face face 'display `(space :height (,height))) + (propertize "\n" 'face face 'line-height t)))) + +(defmacro transient-with-shadowed-buffer (&rest body) + "While in the transient buffer, temporarily make the shadowed buffer current." + (declare (indent 0) (debug t)) + `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) + ,@body)) + +(defun transient--insert-groups () + (let ((groups (cl-mapcan (lambda (group) + (let ((hide (oref group hide))) + (and (not (and (functionp hide) + (transient-with-shadowed-buffer + (funcall hide)))) + (list group)))) + transient--layout))) + (while-let ((group (pop groups))) + (transient--insert-group group) + (when groups + (insert ?\n))))) + +(defvar transient--max-group-level 1) + +(cl-defgeneric transient--insert-group (group) + "Format GROUP and its elements and insert the result.") + +(cl-defmethod transient--insert-group :around ((group transient-group)) + "Insert GROUP's description, if any." + (when-let ((desc (transient-with-shadowed-buffer + (transient-format-description group)))) + (insert desc ?\n)) + (let ((transient--max-group-level + (max (oref group level) transient--max-group-level)) + (transient--pending-group group)) + (cl-call-next-method group))) + +(cl-defmethod transient--insert-group ((group transient-row)) + (transient--maybe-pad-keys group) + (dolist (suffix (oref group suffixes)) + (insert (transient-with-shadowed-buffer (transient-format suffix))) + (insert " ")) + (insert ?\n)) + +(cl-defmethod transient--insert-group ((group transient-column) + &optional skip-empty) + (transient--maybe-pad-keys group) + (dolist (suffix (oref group suffixes)) + (let ((str (transient-with-shadowed-buffer (transient-format suffix)))) + (unless (and (not skip-empty) (equal str "")) + (insert str) + (unless (string-match-p ".\n\\'" str) + (insert ?\n)))))) + +(cl-defmethod transient--insert-group ((group transient-columns)) + (if transient-force-single-column + (dolist (group (oref group suffixes)) + (transient--insert-group group t)) + (let* ((columns + (mapcar + (lambda (column) + (transient--maybe-pad-keys column group) + (transient-with-shadowed-buffer + `(,@(and-let* ((desc (transient-format-description column))) + (list desc)) + ,@(let ((transient--pending-group column)) + (mapcar #'transient-format (oref column suffixes)))))) + (oref group suffixes))) + (stops (transient--column-stops columns))) + (dolist (row (apply #'transient--mapn #'list columns)) + (let ((stops stops)) + (dolist (cell row) + (let ((stop (pop stops))) + (when cell + (transient--align-to stop) + (insert cell))))) + (insert ?\n))))) + +(cl-defmethod transient--insert-group ((group transient-subgroups)) + (let ((subgroups (oref group suffixes))) + (while-let ((subgroup (pop subgroups))) + (transient--maybe-pad-keys subgroup group) + (transient--insert-group subgroup) + (when subgroups + (insert ?\n))))) + +(cl-defgeneric transient-format (obj) + "Format and return OBJ for display. + +When this function is called, then the current buffer is some +temporary buffer. If you need the buffer from which the prefix +command was invoked to be current, then do so by temporarily +making `transient--original-buffer' current.") + +(cl-defmethod transient-format ((arg string)) + "Return the string ARG after applying the `transient-heading' face." + (propertize arg 'face 'transient-heading)) + +(cl-defmethod transient-format ((_ null)) + "Return a string containing just the newline character." + "\n") + +(cl-defmethod transient-format ((arg integer)) + "Return a string containing just the ARG character." + (char-to-string arg)) + +(cl-defmethod transient-format :around ((obj transient-suffix)) + "Add additional formatting if appropriate. +When reading user input for this infix, then highlight it. +When edit-mode is enabled, then prepend the level information. +When `transient-enable-popup-navigation' is non-nil then format +as a button." + (let ((str (cl-call-next-method obj))) + (when (and (cl-typep obj 'transient-infix) + (eq (oref obj command) this-original-command) + (active-minibuffer-window)) + (setq str (transient--add-face str 'transient-active-infix))) + (when transient--editp + (setq str (concat (let ((level (oref obj level))) + (propertize (format " %s " level) + 'face (if (transient--use-level-p level t) + 'transient-enabled-suffix + 'transient-disabled-suffix))) + str))) + (when (and transient-enable-popup-navigation + (slot-boundp obj 'command)) + (setq str (make-text-button str nil + 'type 'transient + 'suffix obj + 'command (oref obj command)))) + str)) + +(cl-defmethod transient-format ((obj transient-infix)) + "Return a string generated using OBJ's `format'. +%k is formatted using `transient-format-key'. +%d is formatted using `transient-format-description'. +%v is formatted using `transient-format-value'." + (format-spec (oref obj format) + `((?k . ,(transient-format-key obj)) + (?d . ,(transient-format-description obj)) + (?v . ,(transient-format-value obj))))) + +(cl-defmethod transient-format ((obj transient-suffix)) + "Return a string generated using OBJ's `format'. +%k is formatted using `transient-format-key'. +%d is formatted using `transient-format-description'." + (format-spec (oref obj format) + `((?k . ,(transient-format-key obj)) + (?d . ,(transient-format-description obj))))) + +(cl-defgeneric transient-format-key (obj) + "Format OBJ's `key' for display and return the result.") + +(cl-defmethod transient-format-key :around ((obj transient-suffix)) + "Add `transient-inapt-suffix' face if suffix is inapt." + (let ((str (cl-call-next-method))) + (if (oref obj inapt) + (transient--add-face str 'transient-inapt-suffix) + str))) + +(cl-defmethod transient-format-key ((obj transient-suffix)) + "Format OBJ's `key' for display and return the result." + (let ((key (if (slot-boundp obj 'key) (oref obj key) "")) + (cmd (and (slot-boundp obj 'command) (oref obj command)))) + (when-let ((width (oref transient--pending-group pad-keys))) + (setq key (truncate-string-to-width key width nil ?\s))) + (if transient--redisplay-key + (let ((len (length transient--redisplay-key)) + (seq (cl-coerce (edmacro-parse-keys key t) 'list))) + (cond + ((member (seq-take seq len) + (list transient--redisplay-key + (thread-last transient--redisplay-key + (cl-substitute ?- 'kp-subtract) + (cl-substitute ?= 'kp-equal) + (cl-substitute ?+ 'kp-add)))) + (let ((pre (key-description (vconcat (seq-take seq len)))) + (suf (key-description (vconcat (seq-drop seq len))))) + (setq pre (string-replace "RET" "C-m" pre)) + (setq pre (string-replace "TAB" "C-i" pre)) + (setq suf (string-replace "RET" "C-m" suf)) + (setq suf (string-replace "TAB" "C-i" suf)) + ;; We use e.g., "-k" instead of the more correct "- k", + ;; because the former is prettier. If we did that in + ;; the definition, then we want to drop the space that + ;; is reinserted above. False-positives are possible + ;; for silly bindings like "-C-c C-c". + (unless (string-search " " key) + (setq pre (string-replace " " "" pre)) + (setq suf (string-replace " " "" suf))) + (concat (propertize pre 'face 'transient-unreachable-key) + (and (string-prefix-p (concat pre " ") key) " ") + (propertize suf 'face (transient--key-face cmd)) + (save-excursion + (and (string-match " +\\'" key) + (propertize (match-string 0 key) + 'face 'fixed-pitch)))))) + ((transient--lookup-key transient-sticky-map (kbd key)) + (propertize key 'face (transient--key-face cmd))) + (t + (propertize key 'face 'transient-unreachable-key)))) + (propertize key 'face (transient--key-face cmd))))) + +(cl-defmethod transient-format-key :around ((obj transient-argument)) + "Handle `transient-highlight-mismatched-keys'." + (let ((key (cl-call-next-method obj))) + (cond + ((not transient-highlight-mismatched-keys) key) + ((not (slot-boundp obj 'shortarg)) + (transient--add-face key 'transient-nonstandard-key)) + ((not (string-equal key (oref obj shortarg))) + (transient--add-face key 'transient-mismatched-key)) + (key)))) + +(cl-defgeneric transient-format-description (obj) + "Format OBJ's `description' for display and return the result.") + +(cl-defmethod transient-format-description ((obj transient-suffix)) + "The `description' slot may be a function, in which case that is +called inside the correct buffer (see `transient--insert-group') +and its value is returned to the caller." + (transient--get-description obj)) + +(cl-defmethod transient-format-description ((obj transient-value-preset)) + (pcase-let* (((eieio description key set) obj) + ((eieio value) transient--prefix) + (active (seq-set-equal-p set value))) + (format + "%s %s" + (propertize (or description (format "Preset %s" key)) + 'face (and active 'transient-argument)) + (format (propertize "(%s)" 'face 'transient-delimiter) + (mapconcat (lambda (arg) + (propertize + arg 'face (cond (active 'transient-argument) + ((member arg value) + '((:weight demibold) + transient-inactive-argument)) + ('transient-inactive-argument)))) + set " "))))) + +(cl-defmethod transient-format-description ((obj transient-group)) + "Format the description by calling the next method. +If the result doesn't use the `face' property at all, then apply the +face `transient-heading' to the complete string." + (and-let* ((desc (transient--get-description obj))) + (cond ((oref obj inapt) + (propertize desc 'face 'transient-inapt-suffix)) + ((text-property-not-all 0 (length desc) 'face nil desc) + desc) + ((propertize desc 'face 'transient-heading))))) + +(cl-defmethod transient-format-description :around ((obj transient-suffix)) + "Format the description by calling the next method. +If the result is nil, then use \"(BUG: no description)\" as the +description. If the OBJ's `key' is currently unreachable, then +apply the face `transient-unreachable' to the complete string." + (let ((desc (or (cl-call-next-method obj) + (and (slot-boundp transient--prefix 'suffix-description) + (funcall (oref transient--prefix suffix-description) + obj))))) + (if desc + (when-let ((face (transient--get-face obj 'face))) + (setq desc (transient--add-face desc face t))) + (setq desc (propertize "(BUG: no description)" 'face 'error))) + (when (if transient--all-levels-p + (> (oref obj level) transient--default-prefix-level) + (and transient-highlight-higher-levels + (> (max (oref obj level) transient--max-group-level) + transient--default-prefix-level))) + (setq desc (transient--add-face desc 'transient-higher-level))) + (when-let ((inapt-face (and (oref obj inapt) + (transient--get-face obj 'inapt-face)))) + (setq desc (transient--add-face desc inapt-face))) + (when (and (slot-boundp obj 'key) + (transient--key-unreachable-p obj)) + (setq desc (transient--add-face desc 'transient-unreachable))) + desc)) + +(cl-defgeneric transient-format-value (obj) + "Format OBJ's value for display and return the result.") + +(cl-defmethod transient-format-value ((obj transient-suffix)) + (propertize (oref obj argument) + 'face (if (oref obj value) + 'transient-argument + 'transient-inactive-argument))) + +(cl-defmethod transient-format-value ((obj transient-option)) + (let ((argument (oref obj argument))) + (if-let ((value (oref obj value))) + (pcase-exhaustive (oref obj multi-value) + ('nil + (concat (propertize argument 'face 'transient-argument) + (propertize value 'face 'transient-value))) + ((or 't 'rest) + (concat (propertize (if (string-suffix-p " " argument) + argument + (concat argument " ")) + 'face 'transient-argument) + (propertize (mapconcat #'prin1-to-string value " ") + 'face 'transient-value))) + ('repeat + (mapconcat (lambda (value) + (concat (propertize argument 'face 'transient-argument) + (propertize value 'face 'transient-value))) + value " "))) + (propertize argument 'face 'transient-inactive-argument)))) + +(cl-defmethod transient-format-value ((obj transient-switches)) + (with-slots (value argument-format choices) obj + (format (propertize argument-format + 'face (if value + 'transient-argument + 'transient-inactive-argument)) + (format + (propertize "[%s]" 'face 'transient-delimiter) + (mapconcat + (lambda (choice) + (propertize choice 'face + (if (equal (format argument-format choice) value) + 'transient-value + 'transient-inactive-value))) + choices + (propertize "|" 'face 'transient-delimiter)))))) + +(cl-defmethod transient--get-description ((obj transient-child)) + (and-let* ((desc (oref obj description))) + (if (functionp desc) + (if (= (car (transient--func-arity desc)) 1) + (funcall desc obj) + (funcall desc)) + desc))) + +(cl-defmethod transient--get-face ((obj transient-suffix) slot) + (and-let* (((slot-boundp obj slot)) + (face (slot-value obj slot))) + (if (and (not (facep face)) + (functionp face)) + (let ((transient--pending-suffix obj)) + (if (= (car (transient--func-arity face)) 1) + (funcall face obj) + (funcall face))) + face))) + +(defun transient--add-face (string face &optional append beg end) + (let ((str (copy-sequence string))) + (add-face-text-property (or beg 0) (or end (length str)) face append str) + str)) + +(defun transient--key-face (&optional cmd enforce-type) + (or (and transient-semantic-coloring + (not transient--helpp) + (not transient--editp) + (or (and cmd (get cmd 'transient-face)) + (get (transient--get-pre-command cmd enforce-type) + 'transient-face))) + (if cmd 'transient-key 'transient-key-noop))) + +(defun transient--key-unreachable-p (obj) + (and transient--redisplay-key + (let ((key (oref obj key))) + (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list) + (length transient--redisplay-key)) + transient--redisplay-key) + (transient--lookup-key transient-sticky-map (kbd key))))))) + +(defun transient--lookup-key (keymap key) + (let ((val (lookup-key keymap key))) + (and val (not (integerp val)) val))) + +(defun transient--maybe-pad-keys (group &optional parent) + (when-let ((pad (or (oref group pad-keys) + (and parent (oref parent pad-keys))))) + (oset group pad-keys + (apply #'max + (if (integerp pad) pad 0) + (seq-keep (lambda (suffix) + (and (eieio-object-p suffix) + (slot-boundp suffix 'key) + (length (oref suffix key)))) + (oref group suffixes)))))) + +(defun transient--pixel-width (string) + (save-window-excursion + (with-temp-buffer + (insert string) + (set-window-dedicated-p nil nil) + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size + nil (line-beginning-position) (point)))))) + +(defun transient--column-stops (columns) + (let* ((var-pitch (or transient-align-variable-pitch + (oref transient--prefix variable-pitch))) + (char-width (and var-pitch (transient--pixel-width " ")))) + (transient--seq-reductions-from + (apply-partially #'+ (* 2 (if var-pitch char-width 1))) + (transient--mapn + (lambda (cells min) + (apply #'max + (if min (if var-pitch (* min char-width) min) 0) + (mapcar (if var-pitch #'transient--pixel-width #'length) cells))) + columns + (oref transient--prefix column-widths)) + 0))) + +(defun transient--align-to (stop) + (unless (zerop stop) + (insert (if (or transient-align-variable-pitch + (oref transient--prefix variable-pitch)) + (propertize " " 'display `(space :align-to (,stop))) + (make-string (max 0 (- stop (current-column))) ?\s))))) + +(defun transient-command-summary-or-name (obj) + "Return the summary or name of the command represented by OBJ. + +If the command has a doc-string, then return the first line of +that, else its name. + +Intended to be temporarily used as the `:suffix-description' of +a prefix command, while porting a regular keymap to a transient." + (let ((command (oref obj command))) + (if-let ((doc (documentation command))) + (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face) + (propertize (symbol-name command) 'face 'font-lock-function-name-face)))) + +;;; Help + +(cl-defgeneric transient-show-help (obj) + "Show documentation for the command represented by OBJ.") + +(cl-defmethod transient-show-help ((obj transient-prefix)) + "Call `show-help' if non-nil, else show `info-manual', +if non-nil, else show the `man-page' if non-nil, else use +`describe-function'." + (with-slots (show-help info-manual man-page command) obj + (cond (show-help (funcall show-help obj)) + (info-manual (transient--show-manual info-manual)) + (man-page (transient--show-manpage man-page)) + ((transient--describe-function command))))) + +(cl-defmethod transient-show-help ((obj transient-suffix)) + "Call `show-help' if non-nil, else use `describe-function'. +Also used to dispatch showing documentation for the current +prefix. If the suffix is a sub-prefix, then also call the +prefix method." + (cond + ((eq this-command 'transient-help) + (transient-show-help transient--prefix)) + ((let ((prefix (get (oref obj command) + 'transient--prefix))) + (and prefix (not (eq (oref transient--prefix command) this-command)) + (prog1 t (transient-show-help prefix))))) + ((if-let ((show-help (oref obj show-help))) + (funcall show-help obj) + (transient--describe-function this-command))))) + +(cl-defmethod transient-show-help ((obj transient-infix)) + "Call `show-help' if non-nil, else show the `man-page' +if non-nil, else use `describe-function'. When showing the +manpage, then try to jump to the correct location." + (if-let ((show-help (oref obj show-help))) + (funcall show-help obj) + (if-let ((man-page (oref transient--prefix man-page)) + (argument (and (slot-boundp obj 'argument) + (oref obj argument)))) + (transient--show-manpage man-page argument) + (transient--describe-function this-command)))) + +;; `cl-generic-generalizers' doesn't support `command' et al. +(cl-defmethod transient-show-help (cmd) + "Show the command doc-string." + (transient--describe-function cmd)) + +(defmacro transient-with-help-window (&rest body) + "Evaluate BODY, send output to *Help* buffer, and display it in a window. +Select the help window, and make the help buffer current and return it." + (declare (indent 0)) + `(let ((buffer nil) + (help-window-select t)) + (with-help-window (help-buffer) + ,@body + (setq buffer (current-buffer))) + (set-buffer buffer))) + +(defun transient--describe-function (fn) + (let* ((buffer nil) + (help-window-select t) + (temp-buffer-window-setup-hook + (cons (lambda () (setq buffer (current-buffer))) + temp-buffer-window-setup-hook))) + (describe-function fn) + (set-buffer buffer))) + +(defun transient--show-manual (manual) + (info manual)) + +(defun transient--show-manpage (manpage &optional argument) + (require 'man) + (let* ((Man-notify-method 'meek) + (buf (Man-getpage-in-background manpage)) + (proc (get-buffer-process buf))) + (while (and proc (eq (process-status proc) 'run)) + (accept-process-output proc)) + (switch-to-buffer buf) + (when argument + (transient--goto-argument-description argument)))) + +(defun transient--goto-argument-description (arg) + (goto-char (point-min)) + (let ((case-fold-search nil) + ;; This matches preceding/proceeding options. Options + ;; such as "-a", "-S[<keyid>]", and "--grep=<pattern>" + ;; are matched by this regex without the shy group. + ;; The ". " in the shy group is for options such as + ;; "-m parent-number", and the "-[^[:space:]]+ " is + ;; for options such as "--mainline parent-number" + (others "-\\(?:. \\|-[^[:space:]]+ \\)?[^[:space:]]+")) + (when (re-search-forward + (if (equal arg "--") + ;; Special case. + "^[\t\s]+\\(--\\(?: \\|$\\)\\|\\[--\\]\\)" + ;; Should start with whitespace and may have + ;; any number of options before and/or after. + (format + "^[\t\s]+\\(?:%s, \\)*?\\(?1:%s\\)%s\\(?:, %s\\)*$" + others + ;; Options don't necessarily end in an "=" + ;; (e.g., "--gpg-sign[=<keyid>]") + (string-remove-suffix "=" arg) + ;; Simple options don't end in an "=". Splitting this + ;; into 2 cases should make getting false positives + ;; less likely. + (if (string-suffix-p "=" arg) + ;; "[^[:space:]]*[^.[:space:]]" matches the option + ;; value, which is usually after the option name + ;; and either '=' or '[='. The value can't end in + ;; a period, as that means it's being used at the + ;; end of a sentence. The space is for options + ;; such as '--mainline parent-number'. + "\\(?: \\|\\[?=\\)[^[:space:]]*[^.[:space:]]" + ;; Either this doesn't match anything (e.g., "-a"), + ;; or the option is followed by a value delimited + ;; by a "[", "<", or ":". A space might appear + ;; before this value, as in "-f <file>". The + ;; space alternative is for options such as + ;; "-m parent-number". + "\\(?:\\(?: \\| ?[\\[<:]\\)[^[:space:]]*[^.[:space:]]\\)?") + others)) + nil t) + (goto-char (match-beginning 1))))) + +(defun transient--insert-help () + (unless (looking-back "\n\n" 2) + (insert "\n")) + (when transient--helpp + (insert + (format (propertize "\ +Type a %s to show help for that suffix command, or %s to show manual. +Type %s to exit help.\n" + 'face 'transient-heading) + (propertize "<KEY>" 'face 'transient-key) + (propertize "?" 'face 'transient-key) + (propertize "C-g" 'face 'transient-key)))) + (when transient--editp + (unless transient--helpp + (insert + (format (propertize "\ +Type a %s to set level for that suffix command. +Type %s to set what levels are available for this prefix command.\n" + 'face 'transient-heading) + (propertize "<KEY>" 'face 'transient-key) + (propertize "C-x l" 'face 'transient-key)))) + (with-slots (level) transient--prefix + (insert + (format (propertize " +Suffixes on levels %s are available. +Suffixes on levels %s and %s are unavailable.\n" + 'face 'transient-heading) + (propertize (format "1-%s" level) + 'face 'transient-enabled-suffix) + (propertize " 0 " + 'face 'transient-disabled-suffix) + (propertize (format ">=%s" (1+ level)) + 'face 'transient-disabled-suffix)))))) + +(cl-defgeneric transient-show-summary (obj &optional return) + "Show brief summary about the command at point in the echo area. + +If OBJ's `summary' slot is a string, use that. If it is a function, +call that with OBJ as the only argument and use the returned string. +If `summary' is or returns something other than a string or nil, +show no summary. If `summary' is or returns nil, use the first line +of the documentation string, if any. + +If RETURN is non-nil, return the summary instead of showing it. +This is used when a tooltip is needed.") + +(cl-defmethod transient-show-summary ((obj transient-suffix) &optional return) + (with-slots (command summary) obj + (when-let* + ((doc (cond ((functionp summary) + (funcall summary obj)) + (summary) + ((car (split-string (documentation command) "\n"))))) + ((stringp doc)) + ((not (equal doc + (car (split-string (documentation + 'transient--default-infix-command) + "\n")))))) + (when (string-suffix-p "." doc) + (setq doc (substring doc 0 -1))) + (if return + doc + (let ((message-log-max nil)) + (message "%s" doc)))))) + +;;; Popup Navigation + +(defun transient-scroll-up (&optional arg) + "Scroll text of transient popup window upward ARG lines. +If ARG is nil scroll near full screen. This is a wrapper +around `scroll-up-command' (which see)." + (interactive "^P") + (with-selected-window transient--window + (scroll-up-command arg))) + +(defun transient-scroll-down (&optional arg) + "Scroll text of transient popup window down ARG lines. +If ARG is nil scroll near full screen. This is a wrapper +around `scroll-down-command' (which see)." + (interactive "^P") + (with-selected-window transient--window + (scroll-down-command arg))) + +(defun transient-backward-button (n) + "Move to the previous button in the transient popup buffer. +See `backward-button' for information about N." + (interactive "p") + (with-selected-window transient--window + (backward-button n t) + (when (eq transient-enable-popup-navigation 'verbose) + (transient-show-summary (get-text-property (point) 'suffix))))) + +(defun transient-forward-button (n) + "Move to the next button in the transient popup buffer. +See `forward-button' for information about N." + (interactive "p") + (with-selected-window transient--window + (forward-button n t) + (when (eq transient-enable-popup-navigation 'verbose) + (transient-show-summary (get-text-property (point) 'suffix))))) + +(define-button-type 'transient + 'face nil + 'keymap transient-button-map + 'help-echo (lambda (win buf pos) + (with-selected-window win + (with-current-buffer buf + (transient-show-summary + (get-text-property pos 'suffix) t))))) + +(defun transient--goto-button (command) + (cond + ((stringp command) + (when (re-search-forward (concat "^" (regexp-quote command)) nil t) + (goto-char (match-beginning 0)))) + (command + (cl-flet ((found () (eq (button-get (button-at (point)) 'command) command))) + (while (and (ignore-errors (forward-button 1)) + (not (found)))) + (unless (found) + (goto-char (point-min)) + (ignore-errors (forward-button 1)) + (unless (found) + (goto-char (point-min)))))))) + +(defun transient--heading-at-point () + (and (eq (get-text-property (point) 'face) 'transient-heading) + (let ((beg (line-beginning-position))) + (buffer-substring-no-properties + beg (next-single-property-change + beg 'face nil (line-end-position)))))) + +;;; Compatibility +;;;; Popup Isearch + +(defvar-keymap transient--isearch-mode-map + :parent isearch-mode-map + "<remap> <isearch-exit>" #'transient-isearch-exit + "<remap> <isearch-cancel>" #'transient-isearch-cancel + "<remap> <isearch-abort>" #'transient-isearch-abort) + +(defun transient-isearch-backward (&optional regexp-p) + "Do incremental search backward. +With a prefix argument, do an incremental regular expression +search instead." + (interactive "P") + (transient--isearch-setup) + (let ((isearch-mode-map transient--isearch-mode-map)) + (isearch-mode nil regexp-p))) + +(defun transient-isearch-forward (&optional regexp-p) + "Do incremental search forward. +With a prefix argument, do an incremental regular expression +search instead." + (interactive "P") + (transient--isearch-setup) + (let ((isearch-mode-map transient--isearch-mode-map)) + (isearch-mode t regexp-p))) + +(defun transient-isearch-exit () + "Like `isearch-exit' but adapted for `transient'." + (interactive) + (isearch-exit) + (transient--isearch-exit)) + +(defun transient-isearch-cancel () + "Like `isearch-cancel' but adapted for `transient'." + (interactive) + (condition-case nil (isearch-cancel) (quit)) + (transient--isearch-exit)) + +(defun transient-isearch-abort () + "Like `isearch-abort' but adapted for `transient'." + (interactive) + (let ((around (lambda (fn) + (condition-case nil (funcall fn) (quit)) + (transient--isearch-exit)))) + (advice-add 'isearch-cancel :around around) + (unwind-protect + (isearch-abort) + (advice-remove 'isearch-cancel around)))) + +(defun transient--isearch-setup () + (select-window transient--window) + (transient--suspend-override t)) + +(defun transient--isearch-exit () + (select-window transient--original-window) + (transient--resume-override)) + +;;;; Edebug + +(defun transient--edebug-command-p () + (and (bound-and-true-p edebug-active) + (or (memq this-command '(top-level abort-recursive-edit)) + (string-prefix-p "edebug" (symbol-name this-command))))) + +;;;; Miscellaneous + +(cl-pushnew (list nil (concat "^\\s-*(" + (eval-when-compile + (regexp-opt + '("transient-define-prefix" + "transient-define-suffix" + "transient-define-infix" + "transient-define-argument") + t)) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)") + 2) + lisp-imenu-generic-expression :test #'equal) + +(declare-function which-key-mode "ext:which-key" (&optional arg)) + +(defun transient--suspend-which-key-mode () + (when (bound-and-true-p which-key-mode) + (which-key-mode -1) + (add-hook 'transient-exit-hook #'transient--resume-which-key-mode))) + +(defun transient--resume-which-key-mode () + (unless transient--prefix + (which-key-mode 1) + (remove-hook 'transient-exit-hook #'transient--resume-which-key-mode))) + +(defun transient-bind-q-to-quit () + "Modify some keymaps to bind \"q\" to the appropriate quit command. + +\"C-g\" is the default binding for such commands now, but Transient's +predecessor Magit-Popup used \"q\" instead. If you would like to get +that binding back, then call this function in your init file like so: + + (with-eval-after-load \\='transient + (transient-bind-q-to-quit)) + +Individual transients may already bind \"q\" to something else +and such a binding would shadow the quit binding. If that is the +case then \"Q\" is bound to whatever \"q\" would have been bound +to by setting `transient-substitute-key-function' to a function +that does that. Of course \"Q\" may already be bound to something +else, so that function binds \"M-q\" to that command instead. +Of course \"M-q\" may already be bound to something else, but +we stop there." + (keymap-set transient-base-map "q" #'transient-quit-one) + (keymap-set transient-sticky-map "q" #'transient-quit-seq) + (setq transient-substitute-key-function + #'transient-rebind-quit-commands)) + +(defun transient-rebind-quit-commands (obj) + "See `transient-bind-q-to-quit'." + (let ((key (oref obj key))) + (cond ((string-equal key "q") "Q") + ((string-equal key "Q") "M-q") + (key)))) + +(defun transient--force-fixed-pitch () + (require 'face-remap) + (face-remap-reset-base 'default) + (face-remap-add-relative 'default 'fixed-pitch)) + +(defun transient--func-arity (fn) + (func-arity (advice--cd*r (if (symbolp fn) (symbol-function fn) fn)))) + +(defun transient--seq-reductions-from (function sequence initial-value) + (let ((acc (list initial-value))) + (seq-doseq (elt sequence) + (push (funcall function (car acc) elt) acc)) + (nreverse acc))) + +(defun transient--mapn (function &rest lists) + "Apply FUNCTION to elements of LISTS. +Like `cl-mapcar' but while that stops when the shortest list +is exhausted, continue until the longest list is, using nil +as stand-in for elements of exhausted lists." + (let (result) + (while (catch 'more (mapc (lambda (l) (and l (throw 'more t))) lists) nil) + (push (apply function (mapcar #'car-safe lists)) result) + (setq lists (mapcar #'cdr lists))) + (nreverse result))) + +;;; Font-Lock + +(defconst transient-font-lock-keywords + (eval-when-compile + `((,(concat "(" + (regexp-opt (list "transient-define-prefix" + "transient-define-infix" + "transient-define-argument" + "transient-define-suffix") + t) + "\\_>[ \t'(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face nil t))))) + +(font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords) + +;;; Auxiliary Classes +;;;; `transient-lisp-variable' + +(defclass transient-lisp-variable (transient-variable) + ((reader :initform #'transient-lisp-variable--reader) + (always-read :initform t) + (set-value :initarg :set-value :initform #'set)) + "[Experimental] Class used for Lisp variables.") + +(cl-defmethod transient-init-value ((obj transient-lisp-variable)) + (oset obj value (symbol-value (oref obj variable)))) + +(cl-defmethod transient-infix-set ((obj transient-lisp-variable) value) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value value))) + +(cl-defmethod transient-format-description ((obj transient-lisp-variable)) + (or (cl-call-next-method obj) + (symbol-name (oref obj variable)))) + +(cl-defmethod transient-format-value ((obj transient-lisp-variable)) + (propertize (prin1-to-string (oref obj value)) + 'face 'transient-value)) + +(cl-defmethod transient-prompt ((obj transient-lisp-variable)) + (if (and (slot-boundp obj 'prompt) + (oref obj prompt)) + (cl-call-next-method obj) + (format "Set %s: " (oref obj variable)))) + +(defun transient-lisp-variable--reader (prompt initial-input _history) + (read--expression prompt initial-input)) + +;;; _ +(provide 'transient) +;; Local Variables: +;; indent-tabs-mode: nil +;; checkdoc-symbol-words: ("command-line" "edit-mode" "help-mode") +;; End: +;;; transient.el ends here diff --git a/emacs/elpa/transient-20241115.2034/transient.elc b/emacs/elpa/transient-20241115.2034/transient.elc Binary files differ. diff --git a/emacs/elpa/transient-20241115.2034/transient.info b/emacs/elpa/transient-20241115.2034/transient.info @@ -0,0 +1,3383 @@ +This is transient.info, produced by makeinfo version 6.8 from +transient.texi. + + Copyright (C) 2018–2024 Free Software Foundation, Inc. + + You can redistribute this document 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 document 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. + +INFO-DIR-SECTION Emacs misc features +START-INFO-DIR-ENTRY +* Transient: (transient). Transient Commands. +END-INFO-DIR-ENTRY + + +File: transient.info, Node: Top, Next: Introduction, Up: (dir) + +Transient User and Developer Manual +*********************************** + +Transient is the library used to implement the keyboard-driven “menus” +in Magit. It is distributed as a separate package, so that it can be +used to implement similar menus in other packages. + + This manual can be bit hard to digest when getting started. A useful +resource to get over that hurdle is Psionic K’s interactive tutorial, +available at <https://github.com/positron-solutions/transient-showcase>. + +This manual is for Transient version 0.7.9. + + Copyright (C) 2018–2024 Free Software Foundation, Inc. + + You can redistribute this document 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 document 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. + +* Menu: + +* Introduction:: +* Usage:: +* Modifying Existing Transients:: +* Defining New Commands:: +* Classes and Methods:: +* FAQ:: +* Keystroke Index:: +* Command and Function Index:: +* Variable Index:: +* Concept Index:: +* GNU General Public License:: + +— The Detailed Node Listing — + +Usage + +* Invoking Transients:: +* Aborting and Resuming Transients:: +* Common Suffix Commands:: +* Saving Values:: +* Using History:: +* Getting Help for Suffix Commands:: +* Enabling and Disabling Suffixes:: +* Other Commands:: +* Configuration:: + +Defining New Commands + +* Technical Introduction:: +* Defining Transients:: +* Binding Suffix and Infix Commands:: +* Defining Suffix and Infix Commands:: +* Using Infix Arguments:: +* Transient State:: + +Binding Suffix and Infix Commands + +* Group Specifications:: +* Suffix Specifications:: + + +Classes and Methods + +* Group Classes:: +* Group Methods:: +* Prefix Classes:: +* Suffix Classes:: +* Suffix Methods:: +* Prefix Slots:: +* Suffix Slots:: +* Predicate Slots:: + +Suffix Methods + +* Suffix Value Methods:: +* Suffix Format Methods:: + + + + +File: transient.info, Node: Introduction, Next: Usage, Prev: Top, Up: Top + +1 Introduction +************** + +Transient is the library used to implement the keyboard-driven “menus” +in Magit. It is distributed as a separate package, so that it can be +used to implement similar menus in other packages. + + This manual can be bit hard to digest when getting started. A useful +resource to get over that hurdle is Psionic K’s interactive tutorial, +available at <https://github.com/positron-solutions/transient-showcase>. + +Some things that Transient can do +================================= + + • Display current state of arguments + • Display and manage lifecycle of modal bindings + • Contextual user interface + • Flow control for wizard-like composition of interactive forms + • History & persistence + • Rendering arguments for controlling CLI programs + +Complexity in CLI programs +========================== + +Complexity tends to grow with time. How do you manage the complexity of +commands? Consider the humble shell command ‘ls’. It now has over +_fifty_ command line options. Some of these are boolean flags (‘ls +-l’). Some take arguments (‘ls --sort=s’). Some have no effect unless +paired with other flags (‘ls -lh’). Some are mutually exclusive. Some +shell commands even have so many options that they introduce +_subcommands_ (‘git branch’, ‘git commit’), each with their own rich set +of options (‘git branch -f’). + +Using Transient for composing interactive commands +================================================== + +What about Emacs commands used interactively? How do these handle +options? One solution is to make many versions of the same command, so +you don’t need to! Consider: ‘delete-other-windows’ vs. +‘delete-other-windows-vertically’ (among many similar examples). + + Some Emacs commands will simply prompt you for the next "argument" +(‘M-x switch-to-buffer’). Another common solution is to use prefix +arguments which usually start with ‘C-u’. Sometimes these are sensibly +numerical in nature (‘C-u 4 M-x forward-paragraph’ to move forward 4 +paragraphs). But sometimes they function instead as boolean "switches" +(‘C-u C-SPACE’ to jump to the last mark instead of just setting it, ‘C-u +C-u C-SPACE’ to unconditionally set the mark). Since there aren’t many +standards for the use of prefix options, you have to read the command’s +documentation to find out what the possibilities are. + + But when an Emacs command grows to have a truly large set of options +and arguments, with dependencies between them, lots of option values, +etc., these simple approaches just don’t scale. Transient is designed +to solve this issue. Think of it as the humble prefix argument ‘C-u’, +_raised to the power of 10_. Like ‘C-u’, it is key driven. Like the +shell, it supports boolean "flag" options, options that take arguments, +and even "sub-commands", with their own options. But instead of +searching through a man page or command documentation, well-designed +transients _guide_ their users to the relevant set of options (and even +their possible values!) directly, taking into account any important +pre-existing Emacs settings. And while for shell commands like ‘ls’, +there is only one way to "execute" (hit ‘Return’!), transients can +"execute" using multiple different keys tied to one of many +self-documenting _actions_ (imagine having 5 different colored return +keys on your keyboard!). Transients make navigating and setting large, +complex groups of command options and arguments easy. Fun even. Once +you’ve tried it, it’s hard to go back to the ‘C-u what can I do here +again?’ way. + + +File: transient.info, Node: Usage, Next: Modifying Existing Transients, Prev: Introduction, Up: Top + +2 Usage +******* + +* Menu: + +* Invoking Transients:: +* Aborting and Resuming Transients:: +* Common Suffix Commands:: +* Saving Values:: +* Using History:: +* Getting Help for Suffix Commands:: +* Enabling and Disabling Suffixes:: +* Other Commands:: +* Configuration:: + + +File: transient.info, Node: Invoking Transients, Next: Aborting and Resuming Transients, Up: Usage + +2.1 Invoking Transients +======================= + +A transient prefix command is invoked like any other command by pressing +the key that is bound to that command. The main difference to other +commands is that a transient prefix command activates a transient +keymap, which temporarily binds the transient’s infix and suffix +commands. Bindings from other keymaps may, or may not, be disabled +while the transient state is in effect. + + There are two kinds of commands that are available after invoking a +transient prefix command; infix and suffix commands. Infix commands set +some value (which is then shown in a popup buffer), without leaving the +transient. Suffix commands, on the other hand, usually quit the +transient and they may use the values set by the infix commands, i.e., +the infix *arguments*. + + Instead of setting arguments to be used by a suffix command, infix +commands may also set some value by side-effect, e.g., by setting the +value of some variable. + + +File: transient.info, Node: Aborting and Resuming Transients, Next: Common Suffix Commands, Prev: Invoking Transients, Up: Usage + +2.2 Aborting and Resuming Transients +==================================== + +To quit the transient without invoking a suffix command press ‘C-g’. + + Key bindings in transient keymaps may be longer than a single event. +After pressing a valid prefix key, all commands whose bindings do not +begin with that prefix key are temporarily unavailable and grayed out. +To abort the prefix key press ‘C-g’ (which in this case only quits the +prefix key, but not the complete transient). + + A transient prefix command can be bound as a suffix of another +transient. Invoking such a suffix replaces the current transient state +with a new transient state, i.e., the available bindings change and the +information displayed in the popup buffer is updated accordingly. +Pressing ‘C-g’ while a nested transient is active only quits the +innermost transient, causing a return to the previous transient. + + ‘C-q’ or ‘C-z’ on the other hand always exits all transients. If you +use the latter, then you can later resume the stack of transients using +‘M-x transient-resume’. + +‘C-g’ (‘transient-quit-seq’) +‘C-g’ (‘transient-quit-one’) + This key quits the currently active incomplete key sequence, if + any, or else the current transient. When quitting the current + transient, it returns to the previous transient, if any. + + Transient’s predecessor bound ‘q’ instead of ‘C-g’ to the quit +command. To learn how to get that binding back see +‘transient-bind-q-to-quit’’s documentation string. + +‘C-q’ (‘transient-quit-all’) + This command quits the currently active incomplete key sequence, if + any, and all transients, including the active transient and all + suspended transients, if any. + +‘C-z’ (‘transient-suspend’) + Like ‘transient-quit-all’, this command quits an incomplete key + sequence, if any, and all transients. Additionally, it saves the + stack of transients so that it can easily be resumed (which is + particularly useful if you quickly need to do “something else” and + the stack is deeper than a single transient, and/or you have + already changed the values of some infix arguments). + + Note that only a single stack of transients can be saved at a time. + If another stack is already saved, then saving a new stack discards + the previous stack. + +‘M-x transient-resume’ + This command resumes the previously suspended stack of transients, + if any. + + +File: transient.info, Node: Common Suffix Commands, Next: Saving Values, Prev: Aborting and Resuming Transients, Up: Usage + +2.3 Common Suffix Commands +========================== + +A few shared suffix commands are available in all transients. These +suffix commands are not shown in the popup buffer by default. + + This includes the aborting commands mentioned in the previous +section, as well as some other commands that are all bound to ‘C-x KEY’. +After ‘C-x’ is pressed, a section featuring all these common commands is +temporarily shown in the popup buffer. After invoking one of them, the +section disappears again. Note, however, that one of these commands is +described as “Show common permanently”; invoke that if you want the +common commands to always be shown for all transients. + +‘C-x t’ (‘transient-toggle-common’) + This command toggles whether the generic commands that are common + to all transients are always displayed or only after typing the + incomplete prefix key sequence ‘C-x’. This only affects the + current Emacs session. + + -- User Option: transient-show-common-commands + This option controls whether shared suffix commands are shown + alongside the transient-specific infix and suffix commands. By + default, the shared commands are not shown to avoid overwhelming + the user with too many options. + + While a transient is active, pressing ‘C-x’ always shows the common + commands. The value of this option can be changed for the current + Emacs session by typing ‘C-x t’ while a transient is active. + + The other common commands are described in either the previous or in +one of the following sections. + + Some of Transient’s key bindings differ from the respective bindings +of Magit-Popup; see *note FAQ:: for more information. + + +File: transient.info, Node: Saving Values, Next: Using History, Prev: Common Suffix Commands, Up: Usage + +2.4 Saving Values +================= + +After setting the infix arguments in a transient, the user can save +those arguments for future invocations. + + Most transients will start out with the saved arguments when they are +invoked. There are a few exceptions, though. Some transients are +designed so that the value that they use is stored externally as the +buffer-local value of some variable. Invoking such a transient again +uses the buffer-local value. (1) + + If the user does not save the value and just exits using a regular +suffix command, then the value is merely saved to the transient’s +history. That value won’t be used when the transient is next invoked, +but it is easily accessible (see *note Using History::). + +‘C-x s’ (‘transient-set’) + This command saves the value of the active transient for this Emacs + session. + +‘C-x C-s’ (‘transient-save’) + Save the value of the active transient persistently across Emacs + sessions. + +‘C-x C-k’ (‘transient-reset’) + Clear the set and saved values of the active transient. + + -- User Option: transient-values-file + This option names the file that is used to persist the values of + transients between Emacs sessions. + + ---------- Footnotes ---------- + + (1) ‘magit-diff’ and ‘magit-log’ are two prominent examples, and +their handling of buffer-local values is actually a bit more complicated +than outlined above and even customizable. + + +File: transient.info, Node: Using History, Next: Getting Help for Suffix Commands, Prev: Saving Values, Up: Usage + +2.5 Using History +================= + +Every time the user invokes a suffix command the transient’s current +value is saved to its history. These values can be cycled through the +same way one can cycle through the history of commands that read +user-input in the minibuffer. + +‘C-M-p’ (‘transient-history-prev’) +‘C-x p’ + This command switches to the previous value used for the active + transient. + +‘C-M-n’ (‘transient-history-next’) +‘C-x n’ + This command switches to the next value used for the active + transient. + + In addition to the transient-wide history, Transient of course +supports per-infix history. When an infix reads user-input using the +minibuffer, the user can use the regular minibuffer history commands to +cycle through previously used values. Usually the same keys as those +mentioned above are bound to those commands. + + Authors of transients should arrange for different infix commands +that read the same kind of value to also use the same history key (see +*note Suffix Slots::). + + Both kinds of history are saved to a file when Emacs is exited. + + -- User Option: transient-history-file + This option names the file that is used to persist the history of + transients and their infixes between Emacs sessions. + + -- User Option: transient-history-limit + This option controls how many history elements are kept at the time + the history is saved in ‘transient-history-file’. + + +File: transient.info, Node: Getting Help for Suffix Commands, Next: Enabling and Disabling Suffixes, Prev: Using History, Up: Usage + +2.6 Getting Help for Suffix Commands +==================================== + +Transients can have many suffixes and infixes that the user might not be +familiar with. To make it trivial to get help for these, Transient +provides access to the documentation directly from the active transient. + +‘C-h’ (‘transient-help’) + This command enters help mode. When help mode is active, typing a + key shows information about the suffix command that the key + normally is bound to (instead of invoking it). Pressing ‘C-h’ a + second time shows information about the _prefix_ command. + + After typing a key, the stack of transient states is suspended and + information about the suffix command is shown instead. Typing ‘q’ + in the help buffer buries that buffer and resumes the transient + state. + + What sort of documentation is shown depends on how the transient was +defined. For infix commands that represent command-line arguments this +ideally shows the appropriate manpage. ‘transient-help’ then tries to +jump to the correct location within that. Info manuals are also +supported. The fallback is to show the command’s documentation string, +for non-infix suffixes this is usually appropriate. + + +File: transient.info, Node: Enabling and Disabling Suffixes, Next: Other Commands, Prev: Getting Help for Suffix Commands, Up: Usage + +2.7 Enabling and Disabling Suffixes +=================================== + +The user base of a package that uses transients can be very diverse. +This is certainly the case for Magit; some users have been using it and +Git for a decade, while others are just getting started now. + + For that reason a mechanism is needed that authors can use to +classify a transient’s infixes and suffixes along the +essentials...everything spectrum. We use the term “levels” to describe +that mechanism. + + Each suffix command is placed on a level and each transient has a +level (called “transient-level”), which controls which suffix commands +are available. Integers between 1 and 7 (inclusive) are valid levels. +For suffixes, 0 is also valid; it means that the suffix is not displayed +at any level. + + The levels of individual transients and/or their individual suffixes +can be changed interactively, by invoking the transient and then +pressing ‘C-x l’ to enter the “edit” mode, see below. + + The default level for both transients and their suffixes is 4. The +‘transient-default-level’ option only controls the default for +transients. The default suffix level is always 4. The authors of +transients should place certain suffixes on a higher level, if they +expect that it won’t be of use to most users, and they should place very +important suffixes on a lower level, so that they remain available even +if the user lowers the transient level. + + -- User Option: transient-default-level + This option controls which suffix levels are made available by + default. It sets the transient-level for transients for which the + user has not set that individually. + + -- User Option: transient-levels-file + This option names the file that is used to persist the levels of + transients and their suffixes between Emacs sessions. + +‘C-x l’ (‘transient-set-level’) + This command enters edit mode. When edit mode is active, then all + infixes and suffixes that are currently usable are displayed along + with their levels. The colors of the levels indicate whether they + are enabled or not. The level of the transient is also displayed + along with some usage information. + + In edit mode, pressing the key that would usually invoke a certain + suffix instead prompts the user for the level that suffix should be + placed on. + + Help mode is available in edit mode. + + To change the transient level press ‘C-x l’ again. + + To exit edit mode press ‘C-g’. + + Note that edit mode does not display any suffixes that are not + currently usable. ‘magit-rebase’, for example, shows different + suffixes depending on whether a rebase is already in progress or + not. The predicates also apply in edit mode. + + Therefore, to control which suffixes are available given a certain + state, you have to make sure that that state is currently active. + +‘C-x a’ (‘transient-toggle-level-limit’) + This command toggle whether suffixes that are on levels higher than + the level specified by ‘transient-default-level’ are temporarily + available anyway. + + +File: transient.info, Node: Other Commands, Next: Configuration, Prev: Enabling and Disabling Suffixes, Up: Usage + +2.8 Other Commands +================== + +When invoking a transient in a small frame, the transient window may not +show the complete buffer, making it necessary to scroll, using the +following commands. These commands are never shown in the transient +window, and the key bindings are the same as for ‘scroll-up-command’ and +‘scroll-down-command’ in other buffers. + + -- Command: transient-scroll-up arg + This command scrolls text of transient popup window upward ARG + lines. If ARG is ‘nil’, then it scrolls near full screen. This is + a wrapper around ‘scroll-up-command’ (which see). + + -- Command: transient-scroll-down arg + This command scrolls text of transient popup window down ARG lines. + If ARG is ‘nil’, then it scrolls near full screen. This is a + wrapper around ‘scroll-down-command’ (which see). + + +File: transient.info, Node: Configuration, Prev: Other Commands, Up: Usage + +2.9 Configuration +================= + +More options are described in *note Common Suffix Commands::, in *note +Saving Values::, in *note Using History:: and in *note Enabling and +Disabling Suffixes::. + +Essential Options +----------------- + +Also see *note Common Suffix Commands::. + + -- User Option: transient-show-popup + This option controls whether the current transient’s infix and + suffix commands are shown in the popup buffer. + + • If ‘t’ (the default) then the popup buffer is shown as soon as + a transient prefix command is invoked. + + • If ‘nil’, then the popup buffer is not shown unless the user + explicitly requests it, by pressing an incomplete prefix key + sequence. + + • If a number, then the a brief one-line summary is shown + instead of the popup buffer. If zero or negative, then not + even that summary is shown; only the pressed key itself is + shown. + + The popup is shown when the user explicitly requests it by + pressing an incomplete prefix key sequence. Unless this is + zero, the popup is shown after that many seconds of inactivity + (using the absolute value). + + -- User Option: transient-enable-popup-navigation + This option controls whether navigation commands are enabled in the + transient popup buffer. If the value is ‘verbose’, additionally + show brief documentation about the command under point in the echo + area. + + While a transient is active the transient popup buffer is not the + current buffer, making it necessary to use dedicated commands to + act on that buffer itself. This is disabled by default. If this + option is non-‘nil’, then the following features are available: + + • ‘<UP>’ moves the cursor to the previous suffix. + • ‘<DOWN>’ moves the cursor to the next suffix. + • ‘M-<RET>’ invokes the suffix the cursor is on. + • ‘mouse-1’ invokes the clicked on suffix. + • ‘C-s’ and ‘C-r’ start isearch in the popup buffer. + + By default ‘M-<RET>’ is bound to ‘transient-push-button’, instead + of ‘<RET>’, because if a transient allows the invocation of + non-suffixes, then it is likely, that you would want ‘<RET>’ to do + what it would do if no transient were active." + + -- User Option: transient-display-buffer-action + This option specifies the action used to display the transient + popup buffer. The transient popup buffer is displayed in a window + using ‘(display-buffer BUFFER transient-display-buffer-action)’. + + The value of this option has the form ‘(FUNCTION . ALIST)’, where + FUNCTION is a function or a list of functions. Each such function + should accept two arguments: a buffer to display and an alist of + the same form as ALIST. See *note (elisp)Choosing Window::, for + details. + + The default is: + + (display-buffer-in-side-window + (side . bottom) + (inhibit-same-window . t) + (window-parameters (no-other-window . t))) + + This displays the window at the bottom of the selected frame. + Another useful FUNCTION is ‘display-buffer-below-selected’, which + is what ‘magit-popup’ used by default. For more alternatives see + *note (elisp)Buffer Display Action Functions::, and *note + (elisp)Buffer Display Action Alists::. + + Note that the buffer that was current before the transient buffer + is shown should remain the current buffer. Many suffix commands + act on the thing at point, if appropriate, and if the transient + buffer became the current buffer, then that would change what is at + point. To that effect ‘inhibit-same-window’ ensures that the + selected window is not used to show the transient buffer. + + It may be possible to display the window in another frame, but + whether that works in practice depends on the window-manager. If + the window manager selects the new window (Emacs frame), then that + unfortunately changes which buffer is current. + + If you change the value of this option, then you might also want to + change the value of ‘transient-mode-line-format’. + +Accessibility Options +--------------------- + + -- User Option: transient-force-single-column + This option controls whether the use of a single column to display + suffixes is enforced. This might be useful for users with low + vision who use large text and might otherwise have to scroll in two + dimensions. + +Auxiliary Options +----------------- + + -- User Option: transient-mode-line-format + This option controls whether the transient popup buffer has a + mode-line, separator line, or neither. + + If ‘nil’, then the buffer has no mode-line. If the buffer is not + displayed right above the echo area, then this probably is not a + good value. + + If ‘line’ (the default) or a natural number, then the buffer has no + mode-line, but a line is drawn in its place. If a number is used, + that specifies the thickness of the line. On termcap frames we + cannot draw lines, so there ‘line’ and numbers are synonyms for + ‘nil’. + + The color of the line is used to indicate if non-suffixes are + allowed and whether they exit the transient. The foreground color + of ‘transient-key-noop’ (if non-suffixes are disallowed), + ‘transient-key-stay’ (if allowed and transient stays active), or + ‘transient-key-exit’ (if allowed and they exit the transient) is + used to draw the line. + + Otherwise this can be any mode-line format. See *note (elisp)Mode + Line Format::, for details. + + -- User Option: transient-semantic-coloring + This option controls whether colors are used to indicate the + transient behavior of commands. + + If non-‘nil’, then the key binding of each suffix is colorized to + indicate whether it exits the transient state or not. The color of + the prefix is indicated using the line that is drawn when the value + of ‘transient-mode-line-format’ is ‘line’. + + -- User Option: transient-highlight-mismatched-keys + This option controls whether key bindings of infix commands that do + not match the respective command-line argument should be + highlighted. For other infix commands this option has no effect. + + When this option is non-‘nil’, the key binding for an infix + argument is highlighted when only a long argument (e.g., + ‘--verbose’) is specified but no shorthand (e.g., ‘-v’). In the + rare case that a shorthand is specified but the key binding does + not match, then it is highlighted differently. + + Highlighting mismatched key bindings is useful when learning the + arguments of the underlying command-line tool; you wouldn’t want to + learn any short-hands that do not actually exist. + + The highlighting is done using one of the faces + ‘transient-mismatched-key’ and ‘transient-nonstandard-key’. + + -- User Option: transient-substitute-key-function + This function is used to modify key bindings. If the value of this + option is ‘nil’ (the default), then no substitution is performed. + + This function is called with one argument, the prefix object, and + must return a key binding description, either the existing key + description it finds in the ‘key’ slot, or the key description that + replaces the prefix key. It could be used to make other + substitutions, but that is discouraged. + + For example, ‘=’ is hard to reach using my custom keyboard layout, + so I substitute ‘(’ for that, which is easy to reach using a layout + optimized for lisp. + + (setq transient-substitute-key-function + (lambda (obj) + (let ((key (oref obj key))) + (if (string-match "\\`\\(=\\)[a-zA-Z]" key) + (replace-match "(" t t key 1) + key)))) + + -- User Option: transient-read-with-initial-input + This option controls whether the last history element is used as + the initial minibuffer input when reading the value of an infix + argument from the user. If ‘nil’, there is no initial input and + the first element has to be accessed the same way as the older + elements. + + -- User Option: transient-hide-during-minibuffer-read + This option controls whether the transient buffer is hidden while + user input is being read in the minibuffer. + + -- User Option: transient-align-variable-pitch + This option controls whether columns are aligned pixel-wise in the + popup buffer. + + If this is non-‘nil’, then columns are aligned pixel-wise to + support variable-pitch fonts. Keys are not aligned, so you should + use a fixed-pitch font for the ‘transient-key’ face. Other key + faces inherit from that face unless a theme is used that breaks + that relationship. + + This option is intended for users who use a variable-pitch font for + the ‘default’ face. + + -- User Option: transient-force-fixed-pitch + This option controls whether to force the use of a monospaced font + in popup buffer. Even if you use a proportional font for the + ‘default’ face, you might still want to use a monospaced font in + transient’s popup buffer. Setting this option to ‘t’ causes + ‘default’ to be remapped to ‘fixed-pitch’ in that buffer. + +Developer Options +----------------- + +These options are mainly intended for developers. + + -- User Option: transient-detect-key-conflicts + This option controls whether key binding conflicts should be + detected at the time the transient is invoked. If so, this results + in an error, which prevents the transient from being used. Because + of that, conflicts are ignored by default. + + Conflicts cannot be determined earlier, i.e., when the transient is + being defined and when new suffixes are being added, because at + that time there can be false-positives. It is actually valid for + multiple suffixes to share a common key binding, provided the + predicates of those suffixes prevent that more than one of them is + enabled at a time. + + -- User Option: transient-highlight-higher-levels + This option controls whether suffixes that would not be available + by default are highlighted. + + When non-‘nil’ then the descriptions of suffixes are highlighted if + their level is above 4, the default of ‘transient-default-level’. + Assuming you have set that variable to 7, this highlights all + suffixes that won’t be available to users without them making the + same customization. + + +File: transient.info, Node: Modifying Existing Transients, Next: Defining New Commands, Prev: Usage, Up: Top + +3 Modifying Existing Transients +******************************* + +To an extent, transients can be customized interactively, see *note +Enabling and Disabling Suffixes::. This section explains how existing +transients can be further modified non-interactively. Let’s begin with +an example: + + (transient-append-suffix 'magit-patch-apply "-3" + '("-R" "Apply in reverse" "--reverse")) + + This inserts a new infix argument to toggle the ‘--reverse’ argument +after the infix argument that toggles ‘-3’ in ‘magit-patch-apply’. + + The following functions share a few arguments: + + • PREFIX is a transient prefix command, a symbol. + + • SUFFIX is a transient infix or suffix specification in the same + form as expected by ‘transient-define-prefix’. Note that an infix + is a special kind of suffix. Depending on context “suffixes” means + “suffixes (including infixes)” or “non-infix suffixes”. Here it + means the former. See *note Suffix Specifications::. + + SUFFIX may also be a group in the same form as expected by + ‘transient-define-prefix’. See *note Group Specifications::. + + • LOC is a command, a key vector, a key description (a string as + returned by ‘key-description’), or a list specifying coordinates + (the last element may also be a command or key). For example ‘(1 0 + -1)’ identifies the last suffix (‘-1’) of the first subgroup (‘0’) + of the second group (‘1’). + + If LOC is a list of coordinates, then it can be used to identify a + group, not just an individual suffix command. + + The function ‘transient-get-suffix’ can be useful to determine + whether a certain coordination list identifies the suffix or group + that you expect it to identify. In hairy cases it may be necessary + to look at the definition of the transient prefix command. + + These functions operate on the information stored in the +‘transient--layout’ property of the PREFIX symbol. Suffix entries in +that tree are not objects but have the form ‘(LEVEL CLASS PLIST)’, where +PLIST should set at least ‘:key’, ‘:description’ and ‘:command’. + + -- Function: transient-insert-suffix prefix loc suffix &optional + keep-other + -- Function: transient-append-suffix prefix loc suffix &optional + keep-other + These functions insert the suffix or group SUFFIX into PREFIX + before or after LOC. + + Conceptually adding a binding to a transient prefix is similar to + adding a binding to a keymap, but this is complicated by the fact + that multiple suffix commands can be bound to the same key, + provided they are never active at the same time, see *note + Predicate Slots::. + + Unfortunately both false-positives and false-negatives are + possible. To deal with the former use non-‘nil’ KEEP-OTHER. To + deal with the latter remove the conflicting binding explicitly. + + -- Function: transient-replace-suffix prefix loc suffix + This function replaces the suffix or group at LOC in PREFIX with + suffix or group SUFFIX. + + -- Function: transient-remove-suffix prefix loc + This function removes the suffix or group at LOC in PREFIX. + + -- Function: transient-get-suffix prefix loc + This function returns the suffix or group at LOC in PREFIX. The + returned value has the form mentioned above. + + -- Function: transient-suffix-put prefix loc prop value + This function edits the suffix or group at LOC in PREFIX, by + setting the PROP of its plist to VALUE. + + Most of these functions do not signal an error if they cannot perform +the requested modification. The functions that insert new suffixes show +a warning if LOC cannot be found in PREFIX without signaling an error. +The reason for doing it like this is that establishing a key binding +(and that is what we essentially are trying to do here) should not +prevent the rest of the configuration from loading. Among these +functions only ‘transient-get-suffix’ and ‘transient-suffix-put’ may +signal an error. + + +File: transient.info, Node: Defining New Commands, Next: Classes and Methods, Prev: Modifying Existing Transients, Up: Top + +4 Defining New Commands +*********************** + +* Menu: + +* Technical Introduction:: +* Defining Transients:: +* Binding Suffix and Infix Commands:: +* Defining Suffix and Infix Commands:: +* Using Infix Arguments:: +* Transient State:: + + +File: transient.info, Node: Technical Introduction, Next: Defining Transients, Up: Defining New Commands + +4.1 Technical Introduction +========================== + +Taking inspiration from prefix keys and prefix arguments, Transient +implements a similar abstraction involving a prefix command, infix +arguments and suffix commands. + + When the user calls a transient prefix command, a transient +(temporary) keymap is activated, which binds the transient’s infix and +suffix commands, and functions that control the transient state are +added to ‘pre-command-hook’ and ‘post-command-hook’. The available +suffix and infix commands and their state are shown in a popup buffer +until the transient state is exited by invoking a suffix command. + + Calling an infix command causes its value to be changed. How that is +done depends on the type of the infix command. The simplest case is an +infix command that represents a command-line argument that does not take +a value. Invoking such an infix command causes the switch to be toggled +on or off. More complex infix commands may read a value from the user, +using the minibuffer. + + Calling a suffix command usually causes the transient to be exited; +the transient keymaps and hook functions are removed, the popup buffer +no longer shows information about the (no longer bound) suffix commands, +the values of some public global variables are set, while some internal +global variables are unset, and finally the command is actually called. +Suffix commands can also be configured to not exit the transient. + + A suffix command can, but does not have to, use the infix arguments +in much the same way any command can choose to use or ignore the prefix +arguments. For a suffix command that was invoked from a transient, the +variable ‘transient-current-suffixes’ and the function ‘transient-args’ +serve about the same purpose as the variables ‘prefix-arg’ and +‘current-prefix-arg’ do for any command that was called after the prefix +arguments have been set using a command such as ‘universal-argument’. + + Transient can be used to implement simple “command dispatchers”. The +main benefit then is that the user can see all the available commands in +a popup buffer, which can be thought of as a “menus”. That is useful by +itself because it frees the user from having to remember all the keys +that are valid after a certain prefix key or command. Magit’s +‘magit-dispatch’ (on ‘C-x M-g’) command is an example of using Transient +to merely implement a command dispatcher. + + In addition to that, Transient also allows users to interactively +pass arguments to commands. These arguments can be much more complex +than what is reasonable when using prefix arguments. There is a limit +to how many aspects of a command can be controlled using prefix +arguments. Furthermore, what a certain prefix argument means for +different commands can be completely different, and users have to read +documentation to learn and then commit to memory what a certain prefix +argument means to a certain command. + + Transient suffix commands, on the other hand, can accept dozens of +different arguments without the user having to remember anything. When +using Transient, one can call a command with arguments that are just as +complex as when calling the same function non-interactively from Lisp. + + Invoking a transient suffix command with arguments is similar to +invoking a command in a shell with command-line completion and history +enabled. One benefit of the Transient interface is that it remembers +history not only on a global level (“this command was invoked using +these arguments, and previously it was invoked using those other +arguments”), but also remembers the values of individual arguments +independently. See *note Using History::. + + After a transient prefix command is invoked, ‘C-h KEY’ can be used to +show the documentation for the infix or suffix command that ‘KEY’ is +bound to (see *note Getting Help for Suffix Commands::), and infixes and +suffixes can be removed from the transient using ‘C-x l KEY’. Infixes +and suffixes that are disabled by default can be enabled the same way. +See *note Enabling and Disabling Suffixes::. + + Transient ships with support for a few different types of specialized +infix commands. A command that sets a command line option, for example, +has different needs than a command that merely toggles a boolean flag. +Additionally, Transient provides abstractions for defining new types, +which the author of Transient did not anticipate (or didn’t get around +to implementing yet). + + Note that suffix commands also support regular prefix arguments. A +suffix command may even be called with both infix and prefix arguments +at the same time. If you invoke a command as a suffix of a transient +prefix command, but also want to pass prefix arguments to it, then first +invoke the prefix command, and only after doing that invoke the prefix +arguments, before finally invoking the suffix command. If you instead +began by providing the prefix arguments, then those would apply to the +prefix command, not the suffix command. Likewise, if you want to change +infix arguments before invoking a suffix command with prefix arguments, +then change the infix arguments before invoking the prefix arguments. +In other words, regular prefix arguments always apply to the next +command, and since transient prefix, infix and suffix commands are just +regular commands, the same applies to them. (Regular prefix keys behave +differently because they are not commands at all, instead they are just +incomplete key sequences, and those cannot be interrupted with prefix +commands.) + + +File: transient.info, Node: Defining Transients, Next: Binding Suffix and Infix Commands, Prev: Technical Introduction, Up: Defining New Commands + +4.2 Defining Transients +======================= + +A transient consists of a prefix command and at least one suffix +command, though usually a transient has several infix and suffix +commands. The below macro defines the transient prefix command *and* +binds the transient’s infix and suffix commands. In other words, it +defines the complete transient, not just the transient prefix command +that is used to invoke that transient. + + -- Macro: transient-define-prefix name arglist [docstring] [keyword + value]... group... [body...] + This macro defines NAME as a transient prefix command and binds the + transient’s infix and suffix commands. + + ARGLIST are the arguments that the prefix command takes. DOCSTRING + is the documentation string and is optional. + + These arguments can optionally be followed by keyword-value pairs. + Each key has to be a keyword symbol, either ‘:class’ or a keyword + argument supported by the constructor of that class. The + ‘transient-prefix’ class is used if the class is not specified + explicitly. + + GROUPs add key bindings for infix and suffix commands and specify + how these bindings are presented in the popup buffer. At least one + GROUP has to be specified. See *note Binding Suffix and Infix + Commands::. + + The BODY is optional. If it is omitted, then ARGLIST is ignored + and the function definition becomes: + + (lambda () + (interactive) + (transient-setup 'NAME)) + + If BODY is specified, then it must begin with an ‘interactive’ form + that matches ARGLIST, and it must call ‘transient-setup’. It may, + however, call that function only when some condition is satisfied. + + All transients have a (possibly ‘nil’) value, which is exported + when suffix commands are called, so that they can consume that + value. For some transients it might be necessary to have a sort of + secondary value, called a “scope”. Such a scope would usually be + set in the command’s ‘interactive’ form and has to be passed to the + setup function: + + (transient-setup 'NAME nil nil :scope SCOPE) + + For example, the scope of the ‘magit-branch-configure’ transient is + the branch whose variables are being configured. + + +File: transient.info, Node: Binding Suffix and Infix Commands, Next: Defining Suffix and Infix Commands, Prev: Defining Transients, Up: Defining New Commands + +4.3 Binding Suffix and Infix Commands +===================================== + +The macro ‘transient-define-prefix’ is used to define a transient. This +defines the actual transient prefix command (see *note Defining +Transients::) and adds the transient’s infix and suffix bindings, as +described below. + + Users and third-party packages can add additional bindings using +functions such as ‘transient-insert-suffix’ (see *note Modifying +Existing Transients::). These functions take a “suffix specification” +as one of their arguments, which has the same form as the specifications +used in ‘transient-define-prefix’. + +* Menu: + +* Group Specifications:: +* Suffix Specifications:: + + +File: transient.info, Node: Group Specifications, Next: Suffix Specifications, Up: Binding Suffix and Infix Commands + +4.3.1 Group Specifications +-------------------------- + +The suffix and infix commands of a transient are organized in groups. +The grouping controls how the descriptions of the suffixes are outlined +visually but also makes it possible to set certain properties for a set +of suffixes. + + Several group classes exist, some of which organize suffixes in +subgroups. In most cases the class does not have to be specified +explicitly, but see *note Group Classes::. + + Groups are specified in the call to ‘transient-define-prefix’, using +vectors. Because groups are represented using vectors, we cannot use +square brackets to indicate an optional element and instead use curly +brackets to do the latter. + + Group specifications then have this form: + + [{LEVEL} {DESCRIPTION} {KEYWORD VALUE}... ELEMENT...] + + The LEVEL is optional and defaults to 4. See *note Enabling and +Disabling Suffixes::. + + The DESCRIPTION is optional. If present, it is used as the heading +of the group. + + The KEYWORD-VALUE pairs are optional. Each keyword has to be a +keyword symbol, either ‘:class’ or a keyword argument supported by the +constructor of that class. + + • One of these keywords, ‘:description’, is equivalent to specifying + DESCRIPTION at the very beginning of the vector. The + recommendation is to use ‘:description’ if some other keyword is + also used, for consistency, or DESCRIPTION otherwise, because it + looks better. + + • Likewise ‘:level’ is equivalent to LEVEL. + + • Other important keywords include the ‘:if...’ and ‘:inapt-if...’ + keywords. These keywords control whether the group is available in + a certain situation. + + For example, one group of the ‘magit-rebase’ transient uses ‘:if + magit-rebase-in-progress-p’, which contains the suffixes that are + useful while rebase is already in progress; and another that uses + ‘:if-not magit-rebase-in-progress-p’, which contains the suffixes + that initiate a rebase. + + These predicates can also be used on individual suffixes and are + only documented once, see *note Predicate Slots::. + + • The value of ‘:hide’, if non-‘nil’, is a predicate that controls + whether the group is hidden by default. The key bindings for + suffixes of a hidden group should all use the same prefix key. + Pressing that prefix key should temporarily show the group and its + suffixes, which assumes that a predicate like this is used: + + (lambda () + (eq (car transient--redisplay-key) + ?\C-c)) ; the prefix key shared by all bindings + + • The value of ‘:setup-children’, if non-‘nil’, is a function that + takes one argument, a potentially list of children, and must return + a list of children or an empty list. This can either be used to + somehow transform the group’s children that were defined the normal + way, or to dynamically create the children from scratch. + + The returned children must have the same form as stored in the + prefix’s ‘transient--layout’ property, but it is often more + convenient to use the same form as understood by + ‘transient-define-prefix’, described below. If you use the latter + approach, you can use the ‘transient-parse-suffixes’ and + ‘transient-parse-suffix’ functions to transform them from the + convenient to the expected form. Depending on the used group + class, ‘transient-parse-suffixes’’s SUFFIXES must be a list of + group vectors (for ‘transient-columns’) or a list of suffix lists + (for all other group classes). + + If you explicitly specify children and then transform them using + ‘:setup-children’, then the class of the group is determined as + usual, based on explicitly specified children. + + If you do not explicitly specify children and thus rely solely on + ‘:setup-children’, then you must specify the class using ‘:class’. + For backward compatibility, if you fail to do so, + ‘transient-column’ is used and a warning is displayed. This + warning will eventually be replaced with an error. + + (transient-define-prefix my-finder-by-keyword () + "Select a keyword and list matching packages." + ;; The real `finder-by-keyword' is more convenient + ;; of course, but that is not the point here. + [:class transient-columns + :setup-children + (lambda (_) + (transient-parse-suffixes + 'my-finder-by-keyword + (let ((char (1- ?A))) + (mapcar ; a list ... + (lambda (partition) + (vconcat ; of group vectors ... + (mapcar (lambda (elt) + (let ((keyword (symbol-name (car elt)))) + ; ... where each suffix is a list + (list (format "%c" (cl-incf char)) + keyword + (lambda () + (interactive) + (finder-list-matches keyword))))) + partition))) + (seq-partition finder-known-keywords 7)))))]) + + • The boolean ‘:pad-keys’ argument controls whether keys of all + suffixes contained in a group are right padded, effectively + aligning the descriptions. + + The ELEMENTs are either all subgroups, or all suffixes and strings. +(At least currently no group type exists that would allow mixing +subgroups with commands at the same level, though in principle there is +nothing that prevents that.) + + If the ELEMENTs are not subgroups, then they can be a mixture of +lists, which specify commands, and strings. Strings are inserted +verbatim into the buffer. The empty string can be used to insert gaps +between suffixes, which is particularly useful if the suffixes are +outlined as a table. + + Inside group specifications, including inside contained suffix +specifications, nothing has to be quoted and quoting anyway is invalid. +The value following a keyword, can be explicitly unquoted using ‘,’. +This feature is experimental and should be avoided. + + The form of suffix specifications is documented in the next node. + + +File: transient.info, Node: Suffix Specifications, Prev: Group Specifications, Up: Binding Suffix and Infix Commands + +4.3.2 Suffix Specifications +--------------------------- + +A transient’s suffix and infix commands are bound when the transient +prefix command is defined using ‘transient-define-prefix’, see *note +Defining Transients::. The commands are organized into groups, see +*note Group Specifications::. Here we describe the form used to bind an +individual suffix command. + + The same form is also used when later binding additional commands +using functions such as ‘transient-insert-suffix’, see *note Modifying +Existing Transients::. + + Note that an infix is a special kind of suffix. Depending on context +“suffixes” means “suffixes (including infixes)” or “non-infix suffixes”. +Here it means the former. + + Suffix specifications have this form: + + ([LEVEL] [KEY [DESCRIPTION]] COMMAND|ARGUMENT [KEYWORD VALUE]...) + + LEVEL, KEY and DESCRIPTION can also be specified using the KEYWORDs +‘:level’, ‘:key’ and ‘:description’. If the object that is associated +with COMMAND sets these properties, then they do not have to be +specified here. You can however specify them here anyway, possibly +overriding the object’s values just for the binding inside this +transient. + + • LEVEL is the suffix level, an integer between 1 and 7. See *note + Enabling and Disabling Suffixes::. + + • KEY is the key binding, either a vector or key description string. + + • DESCRIPTION is the description, either a string or a function that + takes zero or one arguments (the suffix object) and returns a + string. The function should be a lambda expression to avoid + ambiguity. In some cases a symbol that is bound as a function + would also work but to be safe you should use ‘:description’ in + that case. + + The next element is either a command or an argument. This is the +only argument that is mandatory in all cases. + + • COMMAND should be a symbol that is bound as a function, which has + to be defined or at least autoloaded as a command by the time the + containing prefix command is invoked. + + Any command will do; it does not need to have an object associated + with it (as would be the case if ‘transient-define-suffix’ or + ‘transient-define-infix’ were used to define it). + + COMMAND can also be a ‘lambda’ expression. + + As mentioned above, the object that is associated with a command + can be used to set the default for certain values that otherwise + have to be set in the suffix specification. Therefore if there is + no object, then you have to make sure to specify the KEY and the + DESCRIPTION. + + As a special case, if you want to add a command that might be + neither defined nor autoloaded, you can use a workaround like: + + (transient-insert-suffix 'some-prefix "k" + '("!" "Ceci n'est pas une commande" no-command + :if (lambda () (featurep 'no-library)))) + + Instead of ‘featurep’ you could also use ‘require’ with a non-‘nil’ + value for NOERROR. + + • The mandatory argument can also be a command-line argument, a + string. In that case an anonymous command is defined and bound. + + Instead of a string, this can also be a list of two strings, in + which case the first string is used as the short argument (which + can also be specified using ‘:shortarg’) and the second as the long + argument (which can also be specified using ‘:argument’). + + Only the long argument is displayed in the popup buffer. See + ‘transient-detect-key-conflicts’ for how the short argument may be + used. + + Unless the class is specified explicitly, the appropriate class is + guessed based on the long argument. If the argument ends with ‘=’ + (e.g., ‘--format=’) then ‘transient-option’ is used, otherwise + ‘transient-switch’. + + Finally, details can be specified using optional KEYWORD-VALUE pairs. +Each keyword has to be a keyword symbol, either ‘:class’ or a keyword +argument supported by the constructor of that class. See *note Suffix +Slots::. + + +File: transient.info, Node: Defining Suffix and Infix Commands, Next: Using Infix Arguments, Prev: Binding Suffix and Infix Commands, Up: Defining New Commands + +4.4 Defining Suffix and Infix Commands +====================================== + +Note that an infix is a special kind of suffix. Depending on context +“suffixes” means “suffixes (including infixes)” or “non-infix suffixes”. + + -- Macro: transient-define-suffix name arglist [docstring] [keyword + value]... body... + This macro defines NAME as a transient suffix command. + + ARGLIST are the arguments that the command takes. DOCSTRING is the + documentation string and is optional. + + These arguments can optionally be followed by keyword-value pairs. + Each keyword has to be a keyword symbol, either ‘:class’ or a + keyword argument supported by the constructor of that class. The + ‘transient-suffix’ class is used if the class is not specified + explicitly. + + The BODY must begin with an ‘interactive’ form that matches + ARGLIST. The infix arguments are usually accessed by using + ‘transient-args’ inside ‘interactive’. + + -- Macro: transient-define-infix name arglist [docstring] [keyword + value]... + This macro defines NAME as a transient infix command. + + ARGLIST is always ignored (but mandatory never-the-less) and + reserved for future use. DOCSTRING is the documentation string and + is optional. + + At least one key-value pair is required. All transient infix + commands are ‘equal’ to each other (but not ‘eq’). It is + meaningless to define an infix command, without providing at least + one keyword argument (usually ‘:argument’ or ‘:variable’, depending + on the class). The suffix class defaults to ‘transient-switch’ and + can be set using the ‘:class’ keyword. + + The function definition is always: + + (lambda () + (interactive) + (let ((obj (transient-suffix-object))) + (transient-infix-set obj (transient-infix-read obj))) + (transient--show)) + + ‘transient-infix-read’ and ‘transient-infix-set’ are generic + functions. Different infix commands behave differently because the + concrete methods are different for different infix command classes. + In rare cases the above command function might not be suitable, + even if you define your own infix command class. In that case you + have to use ‘transient-define-suffix’ to define the infix command + and use ‘t’ as the value of the ‘:transient’ keyword. + + -- Macro: transient-define-argument name arglist [docstring] [keyword + value]... + This macro defines NAME as a transient infix command. + + This is an alias for ‘transient-define-infix’. Only use this alias + to define an infix command that actually sets an infix argument. + To define an infix command that, for example, sets a variable, use + ‘transient-define-infix’ instead. + + +File: transient.info, Node: Using Infix Arguments, Next: Transient State, Prev: Defining Suffix and Infix Commands, Up: Defining New Commands + +4.5 Using Infix Arguments +========================= + +The functions and the variables described below allow suffix commands to +access the value of the transient from which they were invoked; which is +the value of its infix arguments. These variables are set when the user +invokes a suffix command that exits the transient, but before actually +calling the command. + + When returning to the command-loop after calling the suffix command, +the arguments are reset to ‘nil’ (which causes the function to return +‘nil’ too). + + Like for Emacs’s prefix arguments, it is advisable, but not +mandatory, to access the infix arguments inside the command’s +‘interactive’ form. The preferred way of doing that is to call the +‘transient-args’ function, which for infix arguments serves about the +same purpose as ‘prefix-arg’ serves for prefix arguments. + + -- Function: transient-args prefix + This function returns the value of the transient prefix command + PREFIX. + + If the current command was invoked from the transient prefix + command PREFIX, then it returns the active infix arguments. If the + current command was not invoked from PREFIX, then it returns the + set, saved or default value for PREFIX. + + -- Function: transient-arg-value arg args + This function return the value of ARG as it appears in ARGS. + + For a switch a boolean is returned. For an option the value is + returned as a string, using the empty string for the empty value, + or ‘nil’ if the option does not appear in ARGS. + + -- Function: transient-suffixes prefix + This function returns the suffixes of the transient prefix command + PREFIX. This is a list of objects. This function should only be + used if you need the objects (as opposed to just their values) and + if the current command is not being invoked from PREFIX. + + -- Variable: transient-current-suffixes + The suffixes of the transient from which this suffix command was + invoked. This is a list of objects. Usually it is sufficient to + instead use the function ‘transient-args’, which returns a list of + values. In complex cases it might be necessary to use this + variable instead, i.e., if you need access to information beside + the value. + + -- Variable: transient-current-command + The transient from which this suffix command was invoked. The + returned value is a symbol, the transient prefix command. + + -- Variable: transient-current-prefix + The transient from which this suffix command was invoked. The + returned value is a ‘transient-prefix’ object, which holds + information associated with the transient prefix command. + + -- Function: transient-active-prefix + This function returns the active transient object. Return ‘nil’ if + there is no active transient, if the transient buffer isn’t shown, + and while the active transient is suspended (e.g., while the + minibuffer is in use). + + Unlike ‘transient-current-prefix’, which is only ever non-‘nil’ in + code that is run directly by a command that is invoked while a + transient is current, this function is also suitable for use in + asynchronous code, such as timers and callbacks (this function’s + main use-case). + + If optional PREFIXES is non-‘nil’, it must be a prefix command + symbol or a list of symbols, in which case the active transient + object is only returned if it matches one of the PREFIXES. + + +File: transient.info, Node: Transient State, Prev: Using Infix Arguments, Up: Defining New Commands + +4.6 Transient State +=================== + +Invoking a transient prefix command “activates” the respective +transient, i.e., it puts a transient keymap into effect, which binds the +transient’s infix and suffix commands. + + The default behavior while a transient is active is as follows: + + • Invoking an infix command does not affect the transient state; the + transient remains active. + + • Invoking a (non-infix) suffix command “deactivates” the transient + state by removing the transient keymap and performing some + additional cleanup. + + • Invoking a command that is bound in a keymap other than the + transient keymap is disallowed and trying to do so results in a + warning. This does not “deactivate” the transient. + + The behavior can be changed for all suffixes of a particular prefix +and/or for individual suffixes. The values should nearly always be +booleans, but certain functions, called “pre-commands”, can also be +used. These functions are named ‘transient--do-VERB’, and the symbol +‘VERB’ can be used as a shorthand. + + A boolean is interpreted as answering the question "does the +transient stay active, when this command is invoked?" ‘t’ means that +the transient stays active, while ‘nil’ means that invoking the command +exits the transient. + + Note that when the suffix is a “sub-prefix”, invoking that command +always activates that sub-prefix, causing the outer prefix to no longer +be active and displayed. Here ‘t’ means that when you exit the inner +prefix, then the outer prefix becomes active again, while ‘nil’ means +that all outer prefixes are exited at once. + + • The behavior for non-suffixes can be set for a particular prefix, + by the prefix’s ‘transient-non-suffix’ slot to a boolean, a + suitable pre-command function, or a shorthand for such a function. + See *note Pre-commands for Non-Suffixes::. + + • The common behavior for the suffixes of a particular prefix can be + set using the prefix’s ‘transient-suffixes’ slot. + + The value specified in this slot does *not* affect infixes. + Because it affects both regular suffixes as well as sub-prefixes, + which have different needs, it is best to avoid explicitly + specifying a function. + + • The behavior of an individual suffix can be changed using its + ‘transient’ slot. While it is usually best to use a boolean, for + this slot it can occasionally make sense to specify a function + explicitly. + + Note that this slot can be set when defining a suffix command using + ‘transient-define-suffix’ and/or in the definition of the prefix. + If set in both places, then the latter takes precedence, as usual. + + The available pre-command functions are documented in the following +sub-sections. They are called by ‘transient--pre-command’, a function +on ‘pre-command-hook’, and the value that they return determines whether +the transient is exited. To do so the value of one of the constants +‘transient--exit’ or ‘transient--stay’ is used (that way we don’t have +to remember if ‘t’ means “exit” or “stay”). + + Additionally, these functions may change the value of ‘this-command’ +(which explains why they have to be called using ‘pre-command-hook’), +call ‘transient-export’, ‘transient--stack-zap’ or +‘transient--stack-push’; and set the values of ‘transient--exitp’, +‘transient--helpp’ or ‘transient--editp’. + + For completeness sake, some notes about complications: + + • The transient-ness of certain built-in suffix commands is specified + using ‘transient-predicate-map’. This is a special keymap, which + binds commands to pre-commands (as opposed to keys to commands) and + takes precedence over the prefix’s ‘transient-suffix’ slot, but not + the suffix’s ‘transient’ slot. + + • While a sub-prefix is active we nearly always want ‘C-g’ to take + the user back to the “super-prefix”, even when the other suffixes + don’t do that. However, in rare cases this may not be desirable, + and that makes the following complication necessary: + + For ‘transient-suffix’ objects the ‘transient’ slot is unbound. We + can ignore that for the most part because ‘nil’ and the slot being + unbound are treated as equivalent, and mean “do exit”. That isn’t + actually true for suffixes that are sub-prefixes though. For such + suffixes unbound means “do exit but allow going back”, which is the + default, while ‘nil’ means “do exit permanently”, which requires + that slot to be explicitly set to that value. + +Pre-commands for Infixes +------------------------ + +The default for infixes is ‘transient--do-stay’. This is also the only +function that makes sense for infixes, which is why this predicate is +used even if the value of the prefix’s ‘transient-suffix’ slot is ‘t’. +In extremely rare cases, one might want to use something else, which can +be done by setting the infix’s ‘transient’ slot directly. + + -- Function: transient--do-stay + Call the command without exporting variables and stay transient. + +Pre-commands for Suffixes +------------------------- + +By default, invoking a suffix causes the transient to be exited. + + The behavior for an individual suffix command can be changed by +setting its ‘transient’ slot to a boolean (which is highly recommended), +or to one of the following pre-commands. + + -- Function: transient--do-exit + Call the command after exporting variables and exit the transient. + + -- Function: transient--do-return + Call the command after exporting variables and return to the parent + prefix. If there is no parent prefix, then call + ‘transient--do-exit’. + + -- Function: transient--do-call + Call the command after exporting variables and stay transient. + + The following pre-commands are only suitable for sub-prefixes. It is +not necessary to explicitly use these predicates because the correct +predicate is automatically picked based on the value of the ‘transient’ +slot for the sub-prefix itself. + + -- Function: transient--do-recurse + Call the transient prefix command, preparing for return to active + transient. + + Whether we actually return to the parent transient is ultimately + under the control of each invoked suffix. The difference between + this pre-command and ‘transient--do-stack’ is that it changes the + value of the ‘transient-suffix’ slot to ‘t’. + + If there is no parent transient, then only call this command and + skip the second step. + + -- Function: transient--do-stack + Call the transient prefix command, stacking the active transient. + Push the active transient to the transient stack. + + Unless ‘transient--do-recurse’ is explicitly used, this pre-command + is automatically used for suffixes that are prefixes themselves, + i.e., for sub-prefixes. + + -- Function: transient--do-replace + Call the transient prefix command, replacing the active transient. + Do not push the active transient to the transient stack. + + Unless ‘transient--do-recurse’ is explicitly used, this pre-command + is automatically used for suffixes that are prefixes themselves, + i.e., for sub-prefixes. + + -- Function: transient--do-suspend + Suspend the active transient, saving the transient stack. + + This is used by the command ‘transient-suspend’ and optionally also + by “external events” such as ‘handle-switch-frame’. Such bindings + should be added to ‘transient-predicate-map’. + +Pre-commands for Non-Suffixes +----------------------------- + +By default, non-suffixes (commands that are bound in other keymaps +beside the transient keymap) cannot be invoked. Trying to invoke such a +command results in a warning and the transient stays active. + + If you want a different behavior, then set the ‘transient-non-suffix’ +slot of the transient prefix command. The value should be a boolean, +answering the question, "is it allowed to invoke non-suffix commands?, a +pre-command function, or a shorthand for such a function. + + If the value is ‘t’, then non-suffixes can be invoked, when it is +‘nil’ (the default) then they cannot be invoked. + + The only other recommended value is ‘leave’. If that is used, then +non-suffixes can be invoked, but if one is invoked, then that exits the +transient. + + -- Function: transient--do-warn + Call ‘transient-undefined’ and stay transient. + + -- Function: transient--do-stay + Call the command without exporting variables and stay transient. + + -- Function: transient--do-leave + Call the command without exporting variables and exit the + transient. + +Special Pre-Commands +-------------------- + + -- Function: transient--do-quit-one + If active, quit help or edit mode, else exit the active transient. + + This is used when the user pressed ‘C-g’. + + -- Function: transient--do-quit-all + Exit all transients without saving the transient stack. + + This is used when the user pressed ‘C-q’. + + -- Function: transient--do-suspend + Suspend the active transient, saving the transient stack. + + This is used when the user pressed ‘C-z’. + + +File: transient.info, Node: Classes and Methods, Next: FAQ, Prev: Defining New Commands, Up: Top + +5 Classes and Methods +********************* + +Transient uses classes and generic functions to make it possible to +define new types of suffix commands that are similar to existing types, +but behave differently in some aspects. It does the same for groups and +prefix commands, though at least for prefix commands that *currently* +appears to be less important. + + Every prefix, infix and suffix command is associated with an object, +which holds information that controls certain aspects of its behavior. +This happens in two ways. + + • Associating a command with a certain class gives the command a + type. This makes it possible to use generic functions to do + certain things that have to be done differently depending on what + type of command it acts on. + + That in turn makes it possible for third-parties to add new types + without having to convince the maintainer of Transient that that + new type is important enough to justify adding a special case to a + dozen or so functions. + + • Associating a command with an object makes it possible to easily + store information that is specific to that particular command. + + Two commands may have the same type, but obviously their key + bindings and descriptions still have to be different, for example. + + The values of some slots are functions. The ‘reader’ slot for + example holds a function that is used to read a new value for an + infix command. The values of such slots are regular functions. + + Generic functions are used when a function should do something + different based on the type of the command, i.e., when all commands + of a certain type should behave the same way but different from the + behavior for other types. Object slots that hold a regular + function as value are used when the task that they perform is + likely to differ even between different commands of the same type. + +* Menu: + +* Group Classes:: +* Group Methods:: +* Prefix Classes:: +* Suffix Classes:: +* Suffix Methods:: +* Prefix Slots:: +* Suffix Slots:: +* Predicate Slots:: + + +File: transient.info, Node: Group Classes, Next: Group Methods, Up: Classes and Methods + +5.1 Group Classes +================= + +The type of a group can be specified using the ‘:class’ property at the +beginning of the class specification, e.g., ‘[:class transient-columns +...]’ in a call to ‘transient-define-prefix’. + + • The abstract ‘transient-child’ class is the base class of both + ‘transient-group’ (and therefore all groups) as well as of + ‘transient-suffix’ (and therefore all suffix and infix commands). + + This class exists because the elements (or “children”) of certain + groups can be other groups instead of suffix and infix commands. + + • The abstract ‘transient-group’ class is the superclass of all other + group classes. + + • The ‘transient-column’ class is the simplest group. + + This is the default “flat” group. If the class is not specified + explicitly and the first element is not a vector (i.e., not a + group), then this class is used. + + This class displays each element on a separate line. + + • The ‘transient-row’ class displays all elements on a single line. + + • The ‘transient-columns’ class displays commands organized in + columns. + + Direct elements have to be groups whose elements have to be + commands or strings. Each subgroup represents a column. This + class takes care of inserting the subgroups’ elements. + + This is the default “nested” group. If the class is not specified + explicitly and the first element is a vector (i.e., a group), then + this class is used. + + • The ‘transient-subgroups’ class wraps other groups. + + Direct elements have to be groups whose elements have to be + commands or strings. This group inserts an empty line between + subgroups. The subgroups themselves are responsible for displaying + their elements. + + +File: transient.info, Node: Group Methods, Next: Prefix Classes, Prev: Group Classes, Up: Classes and Methods + +5.2 Group Methods +================= + + -- Function: transient-setup-children group children + This generic function can be used to setup the children or a group. + + The default implementation usually just returns the children + unchanged, but if the ‘setup-children’ slot of GROUP is non-‘nil’, + then it calls that function with CHILDREN as the only argument and + returns the value. + + The children are given as a (potentially empty) list consisting of + either group or suffix specifications. These functions can make + arbitrary changes to the children including constructing new + children from scratch. + + -- Function: transient--insert-group group + This generic function formats the group and its elements and + inserts the result into the current buffer, which is a temporary + buffer. The contents of that buffer are later inserted into the + popup buffer. + + Functions that are called by this function may need to operate in + the buffer from which the transient was called. To do so they can + temporarily make the ‘transient--source-buffer’ the current buffer. + + +File: transient.info, Node: Prefix Classes, Next: Suffix Classes, Prev: Group Methods, Up: Classes and Methods + +5.3 Prefix Classes +================== + +Currently the ‘transient-prefix’ class is being used for all prefix +commands and there is only a single generic function that can be +specialized based on the class of a prefix command. + + -- Function: transient--history-init obj + This generic function is called while setting up the transient and + is responsible for initializing the ‘history’ slot. This is the + transient-wide history; many individual infixes also have a history + of their own. + + The default (and currently only) method extracts the value from the + global variable ‘transient-history’. + + A transient prefix command’s object is stored in the +‘transient--prefix’ property of the command symbol. While a transient +is active, a clone of that object is stored in the variable +‘transient--prefix’. A clone is used because some changes that are made +to the active transient’s object should not affect later invocations. + + +File: transient.info, Node: Suffix Classes, Next: Suffix Methods, Prev: Prefix Classes, Up: Classes and Methods + +5.4 Suffix Classes +================== + + • All suffix and infix classes derive from ‘transient-suffix’, which + in turn derives from ‘transient-child’, from which + ‘transient-group’ also derives (see *note Group Classes::). + + • All infix classes derive from the abstract ‘transient-infix’ class, + which in turn derives from the ‘transient-suffix’ class. + + Infixes are a special type of suffixes. The primary difference is + that infixes always use the ‘transient--do-stay’ pre-command, while + non-infix suffixes use a variety of pre-commands (see *note + Transient State::). Doing that is most easily achieved by using + this class, though theoretically it would be possible to define an + infix class that does not do so. If you do that then you get to + implement many methods. + + Also, infixes and non-infix suffixes are usually defined using + different macros (see *note Defining Suffix and Infix Commands::). + + • Classes used for infix commands that represent arguments should be + derived from the abstract ‘transient-argument’ class. + + • The ‘transient-switch’ class (or a derived class) is used for infix + arguments that represent command-line switches (arguments that do + not take a value). + + • The ‘transient-option’ class (or a derived class) is used for infix + arguments that represent command-line options (arguments that do + take a value). + + • The ‘transient-switches’ class can be used for a set of mutually + exclusive command-line switches. + + • The ‘transient-files’ class can be used for a ‘--’ argument that + indicates that all remaining arguments are files. + + • Classes used for infix commands that represent variables should + derived from the abstract ‘transient-variable’ class. + + • The ‘transient-information’ class is special in that suffixes that + use this class are not associated with a command and thus also not + with any key binding. Such suffixes are only used to display + arbitrary information, and that anywhere a suffix can appear. + Display-only suffix specifications take this form: + + ([LEVEL] :info DESCRIPTION [KEYWORD VALUE]...) + + The ‘:info’ keyword argument replaces the ‘:description’ keyword + used for other suffix classes. Other keyword arguments that you + might want to set, include ‘:face’, predicate keywords (such as + ‘:if’ and ‘:inapt-if’), and ‘:format’. By default the value of + ‘:format’ includes ‘%k’, which for this class is replaced with the + empty string or spaces, if keys are being padded in the containing + group. + + Magit defines additional classes, which can serve as examples for the +fancy things you can do without modifying Transient. Some of these +classes will likely get generalized and added to Transient. For now +they are very much subject to change and not documented. + + +File: transient.info, Node: Suffix Methods, Next: Prefix Slots, Prev: Suffix Classes, Up: Classes and Methods + +5.5 Suffix Methods +================== + +To get information about the methods implementing these generic +functions use ‘describe-function’. + +* Menu: + +* Suffix Value Methods:: +* Suffix Format Methods:: + + +File: transient.info, Node: Suffix Value Methods, Next: Suffix Format Methods, Up: Suffix Methods + +5.5.1 Suffix Value Methods +-------------------------- + + -- Function: transient-init-value obj + This generic function sets the initial value of the object OBJ. + + This function is called for all suffix commands, but unless a + concrete method is implemented this falls through to the default + implementation, which is a noop. In other words this usually only + does something for infix commands, but note that this is not + implemented for the abstract class ‘transient-infix’, so if your + class derives from that directly, then you must implement a method. + + -- Function: transient-infix-read obj + This generic function determines the new value of the infix object + OBJ. + + This function merely determines the value; ‘transient-infix-set’ is + used to actually store the new value in the object. + + For most infix classes this is done by reading a value from the + user using the reader specified by the ‘reader’ slot (using the + ‘transient-infix-value’ method described below). + + For some infix classes the value is changed without reading + anything in the minibuffer, i.e., the mere act of invoking the + infix command determines what the new value should be, based on the + previous value. + + -- Function: transient-prompt obj + This generic function returns the prompt to be used to read infix + object OBJ’s value. + + -- Function: transient-infix-set obj value + This generic function sets the value of infix object OBJ to VALUE. + + -- Function: transient-infix-value obj + This generic function returns the value of the suffix object OBJ. + + This function is called by ‘transient-args’ (which see), meaning + this function is how the value of a transient is determined so that + the invoked suffix command can use it. + + Currently most values are strings, but that is not set in stone. + ‘nil’ is not a value, it means “no value”. + + Usually only infixes have a value, but see the method for + ‘transient-suffix’. + + -- Function: transient-init-scope obj + This generic function sets the scope of the suffix object OBJ. + + The scope is actually a property of the transient prefix, not of + individual suffixes. However it is possible to invoke a suffix + command directly instead of from a transient. In that case, if the + suffix expects a scope, then it has to determine that itself and + store it in its ‘scope’ slot. + + This function is called for all suffix commands, but unless a + concrete method is implemented this falls through to the default + implementation, which is a noop. + + +File: transient.info, Node: Suffix Format Methods, Prev: Suffix Value Methods, Up: Suffix Methods + +5.5.2 Suffix Format Methods +--------------------------- + + -- Function: transient-format obj + This generic function formats and returns OBJ for display. + + When this function is called, then the current buffer is some + temporary buffer. If you need the buffer from which the prefix + command was invoked to be current, then do so by temporarily making + ‘transient--source-buffer’ current. + + -- Function: transient-format-key obj + This generic function formats OBJ’s ‘key’ for display and returns + the result. + + -- Function: transient-format-description obj + This generic function formats OBJ’s ‘description’ for display and + returns the result. + + -- Function: transient-format-value obj + This generic function formats OBJ’s value for display and returns + the result. + + -- Function: transient-show-help obj + Show help for the prefix, infix or suffix command represented by + OBJ. + + Regardless of OBJ’s type, if its ‘show-help’ slot is non-nil, that + must be a function, which takes OBJ is its only argument. It must + prepare, display and return a buffer, and select the window used to + display it. The ‘transient-show-help-window’ macro is intended for + use in such functions. + + For prefixes, show the info manual, if that is specified using the + ‘info-manual’ slot. Otherwise, show the manpage if that is + specified using the ‘man-page’ slot. Otherwise, show the command’s + documentation string. + + For suffixes, show the command’s documentation string. + + For infixes, show the manpage if that is specified. Otherwise show + the command’s documentation string. + + -- Macro: transient-with-help-window &rest body + Evaluate BODY, send output to ‘*Help*’ buffer, and display it in a + window. Select the help window, and make the help buffer current + and return it. + + -- Function: transient-show-summary obj &optional return + This generic function shows or, if optional RETURN is non-‘nil’, + returns a brief summary about the command at point or hovered with + the mouse. + + This function is called when the mouse is moved over a command and + (if the value of ‘transient-enable-popup-navigation’ is ‘verbose’) + when the user navigates to a command using the keyboard. + + If OBJ’s ‘summary’ slot is a string, that is used. If ‘summary’ is + a function, that is called with OBJ as the only argument and the + returned string is used. If ‘summary’ is or returns something + other than a string or nil, no summary is shown. If ‘summary’ is + or returns ‘nil’, the first line of the documentation string is + used, if any. + + If RETURN is non-‘nil’, this function returns the summary instead + of showing it. This is used when a tooltip is needed. + + +File: transient.info, Node: Prefix Slots, Next: Suffix Slots, Prev: Suffix Methods, Up: Classes and Methods + +5.6 Prefix Slots +================ + + • ‘show-help’, ‘man-page’ or ‘info-manual’ can be used to specify the + documentation for the prefix and its suffixes. The command + ‘transient-help’ uses the function ‘transient-show-help’ (which + see) to lookup and use these values. + + • ‘history-key’ If multiple prefix commands should share a single + value, then this slot has to be set to the same value for all of + them. You probably don’t want that. + + • ‘transient-suffix’ and ‘transient-non-suffix’ play a part when + determining whether the currently active transient prefix command + remains active/transient when a suffix or arbitrary non-suffix + command is invoked. See *note Transient State::. + + • ‘refresh-suffixes’ Normally suffix objects and keymaps are only + setup once, when the prefix is invoked. Setting this to ‘t’, + causes them to be recreated after every command. This is useful + when using ‘:if...’ predicates, and those need to be rerun for some + reason. Doing this is somewhat costly, and there is a risk of + losing state, so this is disabled by default and still considered + experimental. + + • ‘incompatible’ A list of lists. Each sub-list specifies a set of + mutually exclusive arguments. Enabling one of these arguments + causes the others to be disabled. An argument may appear in + multiple sub-lists. Arguments must me given in the same form as + used in the ‘argument’ or ‘argument-format’ slot of the respective + suffix objects, usually something like ‘--switch’ or ‘--option=%s’. + For options and ‘transient-switches’ suffixes it is also possible + to match against a specific value, as returned by + ‘transient-infix-value’, for example, ‘--option=one’. + + • ‘scope’ For some transients it might be necessary to have a sort of + secondary value, called a “scope”. See ‘transient-define-prefix’. + +Internal Prefix Slots +--------------------- + +These slots are mostly intended for internal use. They should not be +set in calls to ‘transient-define-prefix’. + + • ‘prototype’ When a transient prefix command is invoked, then a + clone of that object is stored in the global variable + ‘transient--prefix’ and the prototype is stored in the clone’s + ‘prototype’ slot. + + • ‘command’ The command, a symbol. Each transient prefix command + consists of a command, which is stored in a symbol’s function slot + and an object, which is stored in the ‘transient--prefix’ property + of the same symbol. + + • ‘level’ The level of the prefix commands. The suffix commands + whose layer is equal or lower are displayed. See *note Enabling + and Disabling Suffixes::. + + • ‘value’ The likely outdated value of the prefix. Instead of + accessing this slot directly you should use the function + ‘transient-get-value’, which is guaranteed to return the up-to-date + value. + + • ‘history’ and ‘history-pos’ are used to keep track of historic + values. Unless you implement your own ‘transient-infix-read’ + method you should not have to deal with these slots. + + +File: transient.info, Node: Suffix Slots, Next: Predicate Slots, Prev: Prefix Slots, Up: Classes and Methods + +5.7 Suffix Slots +================ + +Here we document most of the slots that are only available for suffix +objects. Some slots are shared by suffix and group objects, they are +documented in *note Predicate Slots::. + + Also see *note Suffix Classes::. + +Slots of ‘transient-suffix’ +--------------------------- + + • ‘key’ The key, a key vector or a key description string. + + • ‘command’ The command, a symbol. + + • ‘transient’ Whether to stay transient. See *note Transient + State::. + + • ‘format’ The format used to display the suffix in the popup buffer. + It must contain the following %-placeholders: + + • ‘%k’ For the key. + • ‘%d’ For the description. + • ‘%v’ For the infix value. Non-infix suffixes don’t have a + value. + + • ‘description’ The description, either a string or a function, which + is called with zero or one argument (the suffix object), and + returns a string. + + • ‘face’ Face used for the description. In simple cases it is easier + to use this instead of using a function as ‘description’ and adding + the styling there. ‘face’ is appended using + ‘add-face-text-property’. + + • ‘show-help’ A function used to display help for the suffix. If + unspecified, the prefix controls how help is displayed for its + suffixes. See also function ‘transient-show-help’. + + • ‘summary’ The summary displayed in the echo area, or as a tooltip. + If this is ‘nil’, which it usually should be, the first line of the + documentation string is used instead. See ‘transient-show-summary’ + for details. + +Slots of ‘transient-infix’ +-------------------------- + +Some of these slots are only meaningful for some of the subclasses. +They are defined here anyway to allow sharing certain methods. + + • ‘argument’ The long argument, e.g., ‘--verbose’. + + • ‘shortarg’ The short argument, e.g., ‘-v’. + + • ‘value’ The value. Should not be accessed directly. + + • ‘init-value’ Function that is responsible for setting the object’s + value. If bound, then this is called with the object as the only + argument. Usually this is not bound, in which case the object’s + primary ‘transient-init-value’ method is called instead. + + • ‘unsavable’ Whether the value of the suffix is not saved as part of + the prefixes. + + • ‘multi-value’ For options, whether the option can have multiple + values. If this is non-‘nil’, then the values are read using + ‘completing-read-multiple’ by default and if you specify your own + reader, then it should read the values using that function or + similar. + + Supported non-‘nil’ values are: + + • Use ‘rest’ for an option that can have multiple values. This + is useful e.g., for an ‘--’ argument that indicates that all + remaining arguments are files (such as ‘git log -- file1 + file2’). + + In the list returned by ‘transient-args’ such an option and + its values are represented by a single list of the form + ‘(ARGUMENT . VALUES)’. + + • Use ‘repeat’ for an option that can be specified multiple + times. + + In the list returned by ‘transient-args’ each instance of the + option and its value appears separately in the usual from, for + example: ‘("--another-argument" "--option=first" + "--option=second")’. + + In both cases the option’s values have to be specified in the + default value of a prefix using the same format as returned by + ‘transient-args’, e.g., ‘("--other" "--o=1" "--o=2" ("--" "f1" + "f2"))’. + + • ‘always-read’ For options, whether to read a value on every + invocation. If this is ‘nil’, then options that have a value are + simply unset and have to be invoked a second time to set a new + value. + + • ‘allow-empty’ For options, whether the empty string is a valid + value. + + • ‘history-key’ The key used to store the history. This defaults to + the command name. This is useful when multiple infixes should + share the same history because their values are of the same kind. + + • ‘reader’ The function used to read the value of an infix. Not used + for switches. The function takes three arguments, PROMPT, + INITIAL-INPUT and HISTORY, and must return a string. + + • ‘prompt’ The prompt used when reading the value, either a string or + a function that takes the object as the only argument and which + returns a prompt string. + + • ‘choices’ A list of valid values, or a function that returns such a + list. The latter is not implemented for ‘transient-switches’, + because I couldn’t think of a use-case. How exactly the choices + are used varies depending on the class of the suffix. + +Slots of ‘transient-variable’ +----------------------------- + + • ‘variable’ The variable. + +Slots of ‘transient-switches’ +----------------------------- + + • ‘argument-format’ The display format. Must contain ‘%s’, one of + the ‘choices’ is substituted for that. E.g., ‘--%s-order’. + + • ‘argument-regexp’ The regexp used to match any one of the switches. + E.g., ‘\\(--\\(topo\\|author-date\\|date\\)-order\\)’. + + +File: transient.info, Node: Predicate Slots, Prev: Suffix Slots, Up: Classes and Methods + +5.8 Predicate Slots +=================== + +Suffix and group objects share two sets of predicate slots that control +whether a group or suffix should be available depending on some state. +Only one slot from each set can be used at the same time. It is +undefined which slot is honored if you use more than one. + + Predicates from the first group control whether the suffix is present +in the menu at all. + + • ‘if’ Enable if predicate returns non-‘nil’. + • ‘if-not’ Enable if predicate returns ‘nil’. + • ‘if-non-nil’ Enable if variable’s value is non-‘nil’. + • ‘if-nil’ Enable if variable’s value is ‘nil’. + • ‘if-mode’ Enable if major-mode matches value. + • ‘if-not-mode’ Enable if major-mode does not match value. + • ‘if-derived’ Enable if major-mode derives from value. + • ‘if-not-derived’ Enable if major-mode does not derive from value. + + Predicates from the second group control whether the suffix can be +invoked. The suffix is shown in the menu regardless, but when it is +considered "inapt", then it is grayed out to indicated that it currently +cannot be invoked. + + • ‘inapt-if’ Inapt if predicate returns non-‘nil’. + • ‘inapt-if-not’ Inapt if predicate returns ‘nil’. + • ‘inapt-if-non-nil’ Inapt if variable’s value is non-‘nil’. + • ‘inapt-if-nil’ Inapt if variable’s value is ‘nil’. + • ‘inapt-if-mode’ Inapt if major-mode matches value. + • ‘inapt-if-not-mode’ Inapt if major-mode does not match value. + • ‘inapt-if-derived’ Inapt if major-mode derives from value. + • ‘inapt-if-not-derived’ Inapt if major-mode does not derive from + value. + + By default these predicates run when the prefix command is invoked, +but this can be changes, using the ‘refresh-suffixes’ prefix slot. See +*note Prefix Slots::. + + One more slot is shared between group and suffix classes, ‘level’. +Like the slots documented above, it is a predicate, but it is used for a +different purpose. The value has to be an integer between 1 and 7. +‘level’ controls whether a suffix or a group should be available +depending on user preference. See *note Enabling and Disabling +Suffixes::. + + +File: transient.info, Node: FAQ, Next: Keystroke Index, Prev: Classes and Methods, Up: Top + +Appendix A FAQ +************** + +A.1 Can I control how the popup buffer is displayed? +==================================================== + +Yes, see ‘transient-display-buffer-action’ in *note Configuration::. + +A.2 How can I copy text from the popup buffer? +============================================== + +To be able to mark text in Transient’s popup buffer using the mouse, you +have to add the below binding. Note that for technical reasons, the +region won’t be visualized, while doing so. After you have quit the +transient popup, you will be able to yank it in another buffer. + + (keymap-set transient-predicate-map + "<mouse-set-region>" + #'transient--do-stay) + +A.3 How can I autoload prefix and suffix commands? +================================================== + +If your package only supports Emacs 30, just prefix the definition with +‘;;;###autoload’. If your package supports released versions of Emacs, +you unfortunately have to use a long form autoload comment as described +in *note (elisp)Autoload::. + + ;;;###autoload (autoload 'magit-dispatch "magit" nil t) + (transient-define-prefix magit-dispatch () + ...) + +A.4 How does Transient compare to prefix keys and universal arguments? +====================================================================== + +See +<https://github.com/magit/transient/wiki/Comparison-with-prefix-keys-and-universal-arguments>. + +A.5 How does Transient compare to Magit-Popup and Hydra? +======================================================== + +See +<https://github.com/magit/transient/wiki/Comparison-with-other-packages>. + +A.6 Why did some of the key bindings change? +============================================ + +You may have noticed that the bindings for some of the common commands +do *not* have the prefix ‘C-x’ and that furthermore some of these +commands are grayed out while others are not. That unfortunately is a +bit confusing if the section of common commands is not shown +permanently, making the following explanation necessary. + + The purpose of usually hiding that section but showing it after the +user pressed the respective prefix key is to conserve space and not +overwhelm users with too much noise, while allowing the user to quickly +list common bindings on demand. + + That however should not keep us from using the best possible key +bindings. The bindings that do use a prefix do so to avoid wasting too +many non-prefix bindings, keeping them available for use in individual +transients. The bindings that do not use a prefix and that are *not* +grayed out are very important bindings that are *always* available, even +when invoking the “common command key prefix” or *any other* +transient-specific prefix. The non-prefix keys that *are* grayed out +however, are not available when any incomplete prefix key sequence is +active. They do not use the “common command key prefix” because it is +likely that users want to invoke them several times in a row and e.g., +‘M-p M-p M-p’ is much more convenient than ‘C-x M-p C-x M-p C-x M-p’. + + You may also have noticed that the “Set” command is bound to ‘C-x s’, +while Magit-Popup used to bind ‘C-c C-c’ instead. I have seen several +users praise the latter binding (sic), so I did not change it +willy-nilly. The reason that I changed it is that using different +prefix keys for different common commands, would have made the temporary +display of the common commands even more confusing, i.e., after pressing +‘C-c’ all the bindings that begin with the ‘C-x’ prefix would be grayed +out. + + Using a single prefix for common commands key means that all other +potential prefix keys can be used for transient-specific commands +*without* the section of common commands also popping up. ‘C-c’ in +particular is a prefix that I want to (and already do) use for Magit, +and also using that for a common command would prevent me from doing so. + + (Also see the next question.) + +A.7 Why does ‘q’ not quit popups anymore? +========================================= + +I agree that ‘q’ is a good binding for commands that quit something. +This includes quitting whatever transient is currently active, but it +also includes quitting whatever it is that some specific transient is +controlling. The transient ‘magit-blame’ for example binds ‘q’ to the +command that turns ‘magit-blame-mode’ off. + + So I had to decide if ‘q’ should quit the active transient (like +Magit-Popup used to) or whether ‘C-g’ should do that instead, so that +‘q’ could be bound in individual transient to whatever commands make +sense for them. Because all other letters are already reserved for use +by individual transients, I have decided to no longer make an exception +for ‘q’. + + If you want to get ‘q’’s old binding back then you can do so. Doing +that is a bit more complicated than changing a single key binding, so I +have implemented a function, ‘transient-bind-q-to-quit’ that makes the +necessary changes. See its documentation string for more information. + + +File: transient.info, Node: Keystroke Index, Next: Command and Function Index, Prev: FAQ, Up: Top + +Appendix B Keystroke Index +************************** + + +* Menu: + +* C-g: Aborting and Resuming Transients. + (line 27) +* C-g <1>: Aborting and Resuming Transients. + (line 27) +* C-h: Getting Help for Suffix Commands. + (line 11) +* C-M-n: Using History. (line 18) +* C-M-p: Using History. (line 13) +* C-q: Aborting and Resuming Transients. + (line 36) +* C-x a: Enabling and Disabling Suffixes. + (line 68) +* C-x C-k: Saving Values. (line 29) +* C-x C-s: Saving Values. (line 25) +* C-x l: Enabling and Disabling Suffixes. + (line 43) +* C-x n: Using History. (line 18) +* C-x p: Using History. (line 13) +* C-x s: Saving Values. (line 21) +* C-x t: Common Suffix Commands. + (line 18) +* C-z: Aborting and Resuming Transients. + (line 41) + + +File: transient.info, Node: Command and Function Index, Next: Variable Index, Prev: Keystroke Index, Up: Top + +Appendix C Command and Function Index +************************************* + + +* Menu: + +* transient--do-call: Transient State. (line 125) +* transient--do-exit: Transient State. (line 117) +* transient--do-leave: Transient State. (line 193) +* transient--do-quit-all: Transient State. (line 205) +* transient--do-quit-one: Transient State. (line 200) +* transient--do-recurse: Transient State. (line 133) +* transient--do-replace: Transient State. (line 153) +* transient--do-return: Transient State. (line 120) +* transient--do-stack: Transient State. (line 145) +* transient--do-stay: Transient State. (line 105) +* transient--do-stay <1>: Transient State. (line 190) +* transient--do-suspend: Transient State. (line 161) +* transient--do-suspend <1>: Transient State. (line 210) +* transient--do-warn: Transient State. (line 187) +* transient--history-init: Prefix Classes. (line 10) +* transient--insert-group: Group Methods. (line 19) +* transient-active-prefix: Using Infix Arguments. + (line 61) +* transient-append-suffix: Modifying Existing Transients. + (line 51) +* transient-arg-value: Using Infix Arguments. + (line 31) +* transient-args: Using Infix Arguments. + (line 22) +* transient-define-argument: Defining Suffix and Infix Commands. + (line 57) +* transient-define-infix: Defining Suffix and Infix Commands. + (line 26) +* transient-define-prefix: Defining Transients. (line 13) +* transient-define-suffix: Defining Suffix and Infix Commands. + (line 9) +* transient-format: Suffix Format Methods. + (line 6) +* transient-format-description: Suffix Format Methods. + (line 18) +* transient-format-key: Suffix Format Methods. + (line 14) +* transient-format-value: Suffix Format Methods. + (line 22) +* transient-get-suffix: Modifying Existing Transients. + (line 73) +* transient-help: Getting Help for Suffix Commands. + (line 11) +* transient-history-next: Using History. (line 18) +* transient-history-prev: Using History. (line 13) +* transient-infix-read: Suffix Value Methods. + (line 16) +* transient-infix-set: Suffix Value Methods. + (line 36) +* transient-infix-value: Suffix Value Methods. + (line 39) +* transient-init-scope: Suffix Value Methods. + (line 52) +* transient-init-value: Suffix Value Methods. + (line 6) +* transient-insert-suffix: Modifying Existing Transients. + (line 49) +* transient-prompt: Suffix Value Methods. + (line 32) +* transient-quit-all: Aborting and Resuming Transients. + (line 36) +* transient-quit-one: Aborting and Resuming Transients. + (line 27) +* transient-quit-seq: Aborting and Resuming Transients. + (line 27) +* transient-remove-suffix: Modifying Existing Transients. + (line 70) +* transient-replace-suffix: Modifying Existing Transients. + (line 66) +* transient-reset: Saving Values. (line 29) +* transient-resume: Aborting and Resuming Transients. + (line 53) +* transient-save: Saving Values. (line 25) +* transient-scroll-down: Other Commands. (line 17) +* transient-scroll-up: Other Commands. (line 12) +* transient-set: Saving Values. (line 21) +* transient-set-level: Enabling and Disabling Suffixes. + (line 43) +* transient-setup-children: Group Methods. (line 6) +* transient-show-help: Suffix Format Methods. + (line 26) +* transient-show-summary: Suffix Format Methods. + (line 51) +* transient-suffix-put: Modifying Existing Transients. + (line 77) +* transient-suffixes: Using Infix Arguments. + (line 38) +* transient-suspend: Aborting and Resuming Transients. + (line 41) +* transient-toggle-common: Common Suffix Commands. + (line 18) +* transient-toggle-level-limit: Enabling and Disabling Suffixes. + (line 68) +* transient-with-help-window: Suffix Format Methods. + (line 46) + + +File: transient.info, Node: Variable Index, Next: Concept Index, Prev: Command and Function Index, Up: Top + +Appendix D Variable Index +************************* + + +* Menu: + +* transient-align-variable-pitch: Configuration. (line 192) +* transient-current-command: Using Infix Arguments. + (line 52) +* transient-current-prefix: Using Infix Arguments. + (line 56) +* transient-current-suffixes: Using Infix Arguments. + (line 44) +* transient-default-level: Enabling and Disabling Suffixes. + (line 33) +* transient-detect-key-conflicts: Configuration. (line 217) +* transient-display-buffer-action: Configuration. (line 58) +* transient-enable-popup-navigation: Configuration. (line 36) +* transient-force-fixed-pitch: Configuration. (line 205) +* transient-force-single-column: Configuration. (line 100) +* transient-hide-during-minibuffer-read: Configuration. (line 188) +* transient-highlight-higher-levels: Configuration. (line 230) +* transient-highlight-mismatched-keys: Configuration. (line 142) +* transient-history-file: Using History. (line 33) +* transient-history-limit: Using History. (line 37) +* transient-levels-file: Enabling and Disabling Suffixes. + (line 38) +* transient-mode-line-format: Configuration. (line 109) +* transient-read-with-initial-input: Configuration. (line 181) +* transient-semantic-coloring: Configuration. (line 133) +* transient-show-common-commands: Common Suffix Commands. + (line 23) +* transient-show-popup: Configuration. (line 15) +* transient-substitute-key-function: Configuration. (line 160) +* transient-values-file: Saving Values. (line 31) + + +File: transient.info, Node: Concept Index, Next: GNU General Public License, Prev: Variable Index, Up: Top + +Appendix E Concept Index +************************ + + +* Menu: + +* aborting transients: Aborting and Resuming Transients. + (line 6) +* classes and methods: Classes and Methods. (line 6) +* command dispatchers: Technical Introduction. + (line 39) +* common suffix commands: Common Suffix Commands. + (line 6) +* defining infix commands: Defining Suffix and Infix Commands. + (line 6) +* defining suffix commands: Defining Suffix and Infix Commands. + (line 6) +* disabling suffixes: Enabling and Disabling Suffixes. + (line 6) +* enabling suffixes: Enabling and Disabling Suffixes. + (line 6) +* getting help: Getting Help for Suffix Commands. + (line 6) +* group specifications: Group Specifications. (line 6) +* invoking transients: Invoking Transients. (line 6) +* levels: Enabling and Disabling Suffixes. + (line 10) +* modifying existing transients: Modifying Existing Transients. + (line 6) +* quit transient: Aborting and Resuming Transients. + (line 6) +* resuming transients: Aborting and Resuming Transients. + (line 6) +* saving values of arguments: Saving Values. (line 6) +* scope of a transient: Defining Transients. (line 43) +* suffix specifications: Suffix Specifications. + (line 6) +* transient state: Transient State. (line 6) +* transient-level: Enabling and Disabling Suffixes. + (line 15) +* value history: Using History. (line 6) + + +File: transient.info, Node: GNU General Public License, Prev: Concept Index, Up: Top + +Appendix F GNU General Public License +************************************* + + Version 3, 29 June 2007 + + Copyright © 2007 Free Software Foundation, Inc. <https://fsf.org/> + + Everyone is permitted to copy and distribute verbatim copies of this + license document, but changing it is not allowed. + +Preamble +======== + +The GNU General Public License is a free, copyleft license for software +and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program—to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers’ and authors’ protection, the GPL clearly explains +that there is no warranty for this free software. For both users’ and +authors’ sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users’ freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + +TERMS AND CONDITIONS +==================== + + 0. Definitions. + + “This License” refers to version 3 of the GNU General Public + License. + + “Copyright” also means copyright-like laws that apply to other + kinds of works, such as semiconductor masks. + + “The Program” refers to any copyrightable work licensed under this + License. Each licensee is addressed as “you”. “Licensees” and + “recipients” may be individuals or organizations. + + To “modify” a work means to copy from or adapt all or part of the + work in a fashion requiring copyright permission, other than the + making of an exact copy. The resulting work is called a “modified + version” of the earlier work or a work “based on” the earlier work. + + A “covered work” means either the unmodified Program or a work + based on the Program. + + To “propagate” a work means to do anything with it that, without + permission, would make you directly or secondarily liable for + infringement under applicable copyright law, except executing it on + a computer or modifying a private copy. Propagation includes + copying, distribution (with or without modification), making + available to the public, and in some countries other activities as + well. + + To “convey” a work means any kind of propagation that enables other + parties to make or receive copies. Mere interaction with a user + through a computer network, with no transfer of a copy, is not + conveying. + + An interactive user interface displays “Appropriate Legal Notices” + to the extent that it includes a convenient and prominently visible + feature that (1) displays an appropriate copyright notice, and (2) + tells the user that there is no warranty for the work (except to + the extent that warranties are provided), that licensees may convey + the work under this License, and how to view a copy of this + License. If the interface presents a list of user commands or + options, such as a menu, a prominent item in the list meets this + criterion. + + 1. Source Code. + + The “source code” for a work means the preferred form of the work + for making modifications to it. “Object code” means any non-source + form of a work. + + A “Standard Interface” means an interface that either is an + official standard defined by a recognized standards body, or, in + the case of interfaces specified for a particular programming + language, one that is widely used among developers working in that + language. + + The “System Libraries” of an executable work include anything, + other than the work as a whole, that (a) is included in the normal + form of packaging a Major Component, but which is not part of that + Major Component, and (b) serves only to enable use of the work with + that Major Component, or to implement a Standard Interface for + which an implementation is available to the public in source code + form. A “Major Component”, in this context, means a major + essential component (kernel, window system, and so on) of the + specific operating system (if any) on which the executable work + runs, or a compiler used to produce the work, or an object code + interpreter used to run it. + + The “Corresponding Source” for a work in object code form means all + the source code needed to generate, install, and (for an executable + work) run the object code and to modify the work, including scripts + to control those activities. However, it does not include the + work’s System Libraries, or general-purpose tools or generally + available free programs which are used unmodified in performing + those activities but which are not part of the work. For example, + Corresponding Source includes interface definition files associated + with source files for the work, and the source code for shared + libraries and dynamically linked subprograms that the work is + specifically designed to require, such as by intimate data + communication or control flow between those subprograms and other + parts of the work. + + The Corresponding Source need not include anything that users can + regenerate automatically from other parts of the Corresponding + Source. + + The Corresponding Source for a work in source code form is that + same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of + copyright on the Program, and are irrevocable provided the stated + conditions are met. This License explicitly affirms your unlimited + permission to run the unmodified Program. The output from running + a covered work is covered by this License only if the output, given + its content, constitutes a covered work. This License acknowledges + your rights of fair use or other equivalent, as provided by + copyright law. + + You may make, run and propagate covered works that you do not + convey, without conditions so long as your license otherwise + remains in force. You may convey covered works to others for the + sole purpose of having them make modifications exclusively for you, + or provide you with facilities for running those works, provided + that you comply with the terms of this License in conveying all + material for which you do not control copyright. Those thus making + or running the covered works for you must do so exclusively on your + behalf, under your direction and control, on terms that prohibit + them from making any copies of your copyrighted material outside + their relationship with you. + + Conveying under any other circumstances is permitted solely under + the conditions stated below. Sublicensing is not allowed; section + 10 makes it unnecessary. + + 3. Protecting Users’ Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological + measure under any applicable law fulfilling obligations under + article 11 of the WIPO copyright treaty adopted on 20 December + 1996, or similar laws prohibiting or restricting circumvention of + such measures. + + When you convey a covered work, you waive any legal power to forbid + circumvention of technological measures to the extent such + circumvention is effected by exercising rights under this License + with respect to the covered work, and you disclaim any intention to + limit operation or modification of the work as a means of + enforcing, against the work’s users, your or third parties’ legal + rights to forbid circumvention of technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program’s source code as you + receive it, in any medium, provided that you conspicuously and + appropriately publish on each copy an appropriate copyright notice; + keep intact all notices stating that this License and any + non-permissive terms added in accord with section 7 apply to the + code; keep intact all notices of the absence of any warranty; and + give all recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, + and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to + produce it from the Program, in the form of source code under the + terms of section 4, provided that you also meet all of these + conditions: + + a. The work must carry prominent notices stating that you + modified it, and giving a relevant date. + + b. The work must carry prominent notices stating that it is + released under this License and any conditions added under + section 7. This requirement modifies the requirement in + section 4 to “keep intact all notices”. + + c. You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable + section 7 additional terms, to the whole of the work, and all + its parts, regardless of how they are packaged. This License + gives no permission to license the work in any other way, but + it does not invalidate such permission if you have separately + received it. + + d. If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has + interactive interfaces that do not display Appropriate Legal + Notices, your work need not make them do so. + + A compilation of a covered work with other separate and independent + works, which are not by their nature extensions of the covered + work, and which are not combined with it such as to form a larger + program, in or on a volume of a storage or distribution medium, is + called an “aggregate” if the compilation and its resulting + copyright are not used to limit the access or legal rights of the + compilation’s users beyond what the individual works permit. + Inclusion of a covered work in an aggregate does not cause this + License to apply to the other parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms + of sections 4 and 5, provided that you also convey the + machine-readable Corresponding Source under the terms of this + License, in one of these ways: + + a. Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b. Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that + product model, to give anyone who possesses the object code + either (1) a copy of the Corresponding Source for all the + software in the product that is covered by this License, on a + durable physical medium customarily used for software + interchange, for a price no more than your reasonable cost of + physically performing this conveying of source, or (2) access + to copy the Corresponding Source from a network server at no + charge. + + c. Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, + and only if you received the object code with such an offer, + in accord with subsection 6b. + + d. Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to + the Corresponding Source in the same way through the same + place at no further charge. You need not require recipients + to copy the Corresponding Source along with the object code. + If the place to copy the object code is a network server, the + Corresponding Source may be on a different server (operated by + you or a third party) that supports equivalent copying + facilities, provided you maintain clear directions next to the + object code saying where to find the Corresponding Source. + Regardless of what server hosts the Corresponding Source, you + remain obligated to ensure that it is available for as long as + needed to satisfy these requirements. + + e. Convey the object code using peer-to-peer transmission, + provided you inform other peers where the object code and + Corresponding Source of the work are being offered to the + general public at no charge under subsection 6d. + + A separable portion of the object code, whose source code is + excluded from the Corresponding Source as a System Library, need + not be included in conveying the object code work. + + A “User Product” is either (1) a “consumer product”, which means + any tangible personal property which is normally used for personal, + family, or household purposes, or (2) anything designed or sold for + incorporation into a dwelling. In determining whether a product is + a consumer product, doubtful cases shall be resolved in favor of + coverage. For a particular product received by a particular user, + “normally used” refers to a typical or common use of that class of + product, regardless of the status of the particular user or of the + way in which the particular user actually uses, or expects or is + expected to use, the product. A product is a consumer product + regardless of whether the product has substantial commercial, + industrial or non-consumer uses, unless such uses represent the + only significant mode of use of the product. + + “Installation Information” for a User Product means any methods, + procedures, authorization keys, or other information required to + install and execute modified versions of a covered work in that + User Product from a modified version of its Corresponding Source. + The information must suffice to ensure that the continued + functioning of the modified object code is in no case prevented or + interfered with solely because modification has been made. + + If you convey an object code work under this section in, or with, + or specifically for use in, a User Product, and the conveying + occurs as part of a transaction in which the right of possession + and use of the User Product is transferred to the recipient in + perpetuity or for a fixed term (regardless of how the transaction + is characterized), the Corresponding Source conveyed under this + section must be accompanied by the Installation Information. But + this requirement does not apply if neither you nor any third party + retains the ability to install modified object code on the User + Product (for example, the work has been installed in ROM). + + The requirement to provide Installation Information does not + include a requirement to continue to provide support service, + warranty, or updates for a work that has been modified or installed + by the recipient, or for the User Product in which it has been + modified or installed. Access to a network may be denied when the + modification itself materially and adversely affects the operation + of the network or violates the rules and protocols for + communication across the network. + + Corresponding Source conveyed, and Installation Information + provided, in accord with this section must be in a format that is + publicly documented (and with an implementation available to the + public in source code form), and must require no special password + or key for unpacking, reading or copying. + + 7. Additional Terms. + + “Additional permissions” are terms that supplement the terms of + this License by making exceptions from one or more of its + conditions. Additional permissions that are applicable to the + entire Program shall be treated as though they were included in + this License, to the extent that they are valid under applicable + law. If additional permissions apply only to part of the Program, + that part may be used separately under those permissions, but the + entire Program remains governed by this License without regard to + the additional permissions. + + When you convey a copy of a covered work, you may at your option + remove any additional permissions from that copy, or from any part + of it. (Additional permissions may be written to require their own + removal in certain cases when you modify the work.) You may place + additional permissions on material, added by you to a covered work, + for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material + you add to a covered work, you may (if authorized by the copyright + holders of that material) supplement the terms of this License with + terms: + + a. Disclaiming warranty or limiting liability differently from + the terms of sections 15 and 16 of this License; or + + b. Requiring preservation of specified reasonable legal notices + or author attributions in that material or in the Appropriate + Legal Notices displayed by works containing it; or + + c. Prohibiting misrepresentation of the origin of that material, + or requiring that modified versions of such material be marked + in reasonable ways as different from the original version; or + + d. Limiting the use for publicity purposes of names of licensors + or authors of the material; or + + e. Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f. Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified + versions of it) with contractual assumptions of liability to + the recipient, for any liability that these contractual + assumptions directly impose on those licensors and authors. + + All other non-permissive additional terms are considered “further + restrictions” within the meaning of section 10. If the Program as + you received it, or any part of it, contains a notice stating that + it is governed by this License along with a term that is a further + restriction, you may remove that term. If a license document + contains a further restriction but permits relicensing or conveying + under this License, you may add to a covered work material governed + by the terms of that license document, provided that the further + restriction does not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you + must place, in the relevant source files, a statement of the + additional terms that apply to those files, or a notice indicating + where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in + the form of a separately written license, or stated as exceptions; + the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly + provided under this License. Any attempt otherwise to propagate or + modify it is void, and will automatically terminate your rights + under this License (including any patent licenses granted under the + third paragraph of section 11). + + However, if you cease all violation of this License, then your + license from a particular copyright holder is reinstated (a) + provisionally, unless and until the copyright holder explicitly and + finally terminates your license, and (b) permanently, if the + copyright holder fails to notify you of the violation by some + reasonable means prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is + reinstated permanently if the copyright holder notifies you of the + violation by some reasonable means, this is the first time you have + received notice of violation of this License (for any work) from + that copyright holder, and you cure the violation prior to 30 days + after your receipt of the notice. + + Termination of your rights under this section does not terminate + the licenses of parties who have received copies or rights from you + under this License. If your rights have been terminated and not + permanently reinstated, you do not qualify to receive new licenses + for the same material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or + run a copy of the Program. Ancillary propagation of a covered work + occurring solely as a consequence of using peer-to-peer + transmission to receive a copy likewise does not require + acceptance. However, nothing other than this License grants you + permission to propagate or modify any covered work. These actions + infringe copyright if you do not accept this License. Therefore, + by modifying or propagating a covered work, you indicate your + acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically + receives a license from the original licensors, to run, modify and + propagate that work, subject to this License. You are not + responsible for enforcing compliance by third parties with this + License. + + An “entity transaction” is a transaction transferring control of an + organization, or substantially all assets of one, or subdividing an + organization, or merging organizations. If propagation of a + covered work results from an entity transaction, each party to that + transaction who receives a copy of the work also receives whatever + licenses to the work the party’s predecessor in interest had or + could give under the previous paragraph, plus a right to possession + of the Corresponding Source of the work from the predecessor in + interest, if the predecessor has it or can get it with reasonable + efforts. + + You may not impose any further restrictions on the exercise of the + rights granted or affirmed under this License. For example, you + may not impose a license fee, royalty, or other charge for exercise + of rights granted under this License, and you may not initiate + litigation (including a cross-claim or counterclaim in a lawsuit) + alleging that any patent claim is infringed by making, using, + selling, offering for sale, or importing the Program or any portion + of it. + + 11. Patents. + + A “contributor” is a copyright holder who authorizes use under this + License of the Program or a work on which the Program is based. + The work thus licensed is called the contributor’s “contributor + version”. + + A contributor’s “essential patent claims” are all patent claims + owned or controlled by the contributor, whether already acquired or + hereafter acquired, that would be infringed by some manner, + permitted by this License, of making, using, or selling its + contributor version, but do not include claims that would be + infringed only as a consequence of further modification of the + contributor version. For purposes of this definition, “control” + includes the right to grant patent sublicenses in a manner + consistent with the requirements of this License. + + Each contributor grants you a non-exclusive, worldwide, + royalty-free patent license under the contributor’s essential + patent claims, to make, use, sell, offer for sale, import and + otherwise run, modify and propagate the contents of its contributor + version. + + In the following three paragraphs, a “patent license” is any + express agreement or commitment, however denominated, not to + enforce a patent (such as an express permission to practice a + patent or covenant not to sue for patent infringement). To “grant” + such a patent license to a party means to make such an agreement or + commitment not to enforce a patent against the party. + + If you convey a covered work, knowingly relying on a patent + license, and the Corresponding Source of the work is not available + for anyone to copy, free of charge and under the terms of this + License, through a publicly available network server or other + readily accessible means, then you must either (1) cause the + Corresponding Source to be so available, or (2) arrange to deprive + yourself of the benefit of the patent license for this particular + work, or (3) arrange, in a manner consistent with the requirements + of this License, to extend the patent license to downstream + recipients. “Knowingly relying” means you have actual knowledge + that, but for the patent license, your conveying the covered work + in a country, or your recipient’s use of the covered work in a + country, would infringe one or more identifiable patents in that + country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or + arrangement, you convey, or propagate by procuring conveyance of, a + covered work, and grant a patent license to some of the parties + receiving the covered work authorizing them to use, propagate, + modify or convey a specific copy of the covered work, then the + patent license you grant is automatically extended to all + recipients of the covered work and works based on it. + + A patent license is “discriminatory” if it does not include within + the scope of its coverage, prohibits the exercise of, or is + conditioned on the non-exercise of one or more of the rights that + are specifically granted under this License. You may not convey a + covered work if you are a party to an arrangement with a third + party that is in the business of distributing software, under which + you make payment to the third party based on the extent of your + activity of conveying the work, and under which the third party + grants, to any of the parties who would receive the covered work + from you, a discriminatory patent license (a) in connection with + copies of the covered work conveyed by you (or copies made from + those copies), or (b) primarily for and in connection with specific + products or compilations that contain the covered work, unless you + entered into that arrangement, or that patent license was granted, + prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting + any implied license or other defenses to infringement that may + otherwise be available to you under applicable patent law. + + 12. No Surrender of Others’ Freedom. + + If conditions are imposed on you (whether by court order, agreement + or otherwise) that contradict the conditions of this License, they + do not excuse you from the conditions of this License. If you + cannot convey a covered work so as to satisfy simultaneously your + obligations under this License and any other pertinent obligations, + then as a consequence you may not convey it at all. For example, + if you agree to terms that obligate you to collect a royalty for + further conveying from those to whom you convey the Program, the + only way you could satisfy both those terms and this License would + be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have + permission to link or combine any covered work with a work licensed + under version 3 of the GNU Affero General Public License into a + single combined work, and to convey the resulting work. The terms + of this License will continue to apply to the part which is the + covered work, but the special requirements of the GNU Affero + General Public License, section 13, concerning interaction through + a network will apply to the combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new + versions of the GNU General Public License from time to time. Such + new versions will be similar in spirit to the present version, but + may differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the + Program specifies that a certain numbered version of the GNU + General Public License “or any later version” applies to it, you + have the option of following the terms and conditions either of + that numbered version or of any later version published by the Free + Software Foundation. If the Program does not specify a version + number of the GNU General Public License, you may choose any + version ever published by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future + versions of the GNU General Public License can be used, that + proxy’s public statement of acceptance of a version permanently + authorizes you to choose that version for the Program. + + Later license versions may give you additional or different + permissions. However, no additional obligations are imposed on any + author or copyright holder as a result of your choosing to follow a + later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY + APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE + COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM “AS IS” + WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE + RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. + SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL + NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN + WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES + AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR + DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE + THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA + BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD + PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER + PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF + THE POSSIBILITY OF SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided + above cannot be given local legal effect according to their terms, + reviewing courts shall apply local law that most closely + approximates an absolute waiver of all civil liability in + connection with the Program, unless a warranty or assumption of + liability accompanies a copy of the Program in return for a fee. + +END OF TERMS AND CONDITIONS +=========================== + +How to Apply These Terms to Your New Programs +============================================= + +If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least the +“copyright” line and a pointer to where the full notice is found. + + ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES. + Copyright (C) YEAR NAME OF AUTHOR + + 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/>. + + Also add information on how to contact you by electronic and paper +mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + PROGRAM Copyright (C) YEAR NAME OF AUTHOR + This program comes with ABSOLUTELY NO WARRANTY; for details type ‘show w’. + This is free software, and you are welcome to redistribute it + under certain conditions; type ‘show c’ for details. + + The hypothetical commands ‘show w’ and ‘show c’ should show the +appropriate parts of the General Public License. Of course, your +program’s commands might be different; for a GUI interface, you would +use an “about box”. + + You should also get your employer (if you work as a programmer) or +school, if any, to sign a “copyright disclaimer” for the program, if +necessary. For more information on this, and how to apply and follow +the GNU GPL, see <https://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your +program into proprietary programs. If your program is a subroutine +library, you may consider it more useful to permit linking proprietary +applications with the library. If this is what you want to do, use the +GNU Lesser General Public License instead of this License. But first, +please read <https://www.gnu.org/licenses/why-not-lgpl.html>. + + + +Tag Table: +Node: Top763 +Node: Introduction2976 +Ref: Some things that Transient can do3504 +Ref: Complexity in CLI programs3857 +Ref: Using Transient for composing interactive commands4458 +Node: Usage6700 +Node: Invoking Transients7068 +Node: Aborting and Resuming Transients8147 +Node: Common Suffix Commands10768 +Node: Saving Values12604 +Ref: Saving Values-Footnote-113975 +Node: Using History14168 +Node: Getting Help for Suffix Commands15742 +Node: Enabling and Disabling Suffixes17120 +Node: Other Commands20408 +Node: Configuration21384 +Ref: Essential Options21664 +Ref: Accessibility Options25732 +Ref: Auxiliary Options26055 +Ref: Developer Options31011 +Node: Modifying Existing Transients32259 +Node: Defining New Commands36451 +Node: Technical Introduction36814 +Node: Defining Transients42515 +Node: Binding Suffix and Infix Commands44982 +Node: Group Specifications45840 +Node: Suffix Specifications52391 +Node: Defining Suffix and Infix Commands56604 +Node: Using Infix Arguments59652 +Node: Transient State63289 +Ref: Pre-commands for Infixes68104 +Ref: Pre-commands for Suffixes68624 +Ref: Pre-commands for Non-Suffixes71078 +Ref: Special Pre-Commands72214 +Node: Classes and Methods72722 +Node: Group Classes74906 +Node: Group Methods76833 +Node: Prefix Classes78086 +Node: Suffix Classes79177 +Node: Suffix Methods82289 +Node: Suffix Value Methods82610 +Node: Suffix Format Methods85368 +Node: Prefix Slots88358 +Ref: Internal Prefix Slots90495 +Node: Suffix Slots91752 +Ref: Slots of transient-suffix92120 +Ref: Slots of transient-infix93554 +Ref: Slots of transient-variable96850 +Ref: Slots of transient-switches96952 +Node: Predicate Slots97315 +Node: FAQ99660 +Ref: Can I control how the popup buffer is displayed?99789 +Ref: How can I copy text from the popup buffer?99970 +Ref: How can I autoload prefix and suffix commands?100464 +Ref: How does Transient compare to prefix keys and universal arguments?100938 +Ref: How does Transient compare to Magit-Popup and Hydra?101181 +Ref: Why did some of the key bindings change?101375 +Ref: Why does q not quit popups anymore?103728 +Node: Keystroke Index104831 +Node: Command and Function Index106696 +Node: Variable Index113699 +Node: Concept Index115972 +Node: GNU General Public License118708 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: